janet/src/compiler/boot.dst

(def defmacro macro
  (fn [name & more] (tuple 'def name 'macro (tuple-prepend (tuple-prepend more name) 'fn))))

(defmacro defn
 [name & more] 
 (tuple 'def name (tuple-prepend (tuple-prepend more name) 'fn)))

(defmacro when
 [cond & body] 
 (tuple 'if cond (tuple-prepend body 'do)))

(defmacro or [x y] (tuple 'if x true y))
(defmacro and [x y] (tuple 'if x y false))

(def identity (fn [x] x))

(def seq (do
  (defn array-seq [x]
    (def len (length x))
    (var i 0)
    {
      :more (fn [] (< i len))
      :next (fn []
        (def ret (get x i))
        (varset! i (+ i 1))
        ret) 
    })
  (defn fiber-seq [x]
    {
      :more (fn [] (or
            (= (fiber-status x) :pending)
            (= (fiber-status x) :new)))
      :next (fn []
          (resume x))
    })
  (def seqs {
    :array array-seq
    :tuple array-seq
    :fiber fiber-seq
    :struct (fn [x] x)})
  (fn [x]
   (def makeseq (get seqs (type x)))
   (if makeseq (makeseq x) (error "expected sequence")))))

(defn range [top]
  (var i 0)
  {
    :more (fn [] (< i top))
    :next (fn []
      (def ret i)
      (varset! i (+ i 1))
      ret) 
  })

(defn doseq [s] 
 (def s (seq s))
 (def more? (get s :more))
 (def getnext (get s :next))
 (while (more?)
    (getnext)))

(defn map [f s]
 (def s (seq s))
 (def more (get s :more))
 (def getnext (get s :next))
 {
  :more more
  :next (fn [] (f (getnext)))
 })

(defn reduce [f start s]
  (def s (seq s))
  (def more? (get s :more))
  (def getnext (get s :next))
  (var ret start)
  (while (more?)
    (varset! ret (f ret (getnext))))
  ret)

(defmacro for [head & body]
  (def head (ast-unwrap1 head))
  (def sym (get head 0))
  (def start (get head 1))
  (def end (get head 2))
  (def _inc (get head 3))
  (def inc (if _inc _inc 1))
  (def endsym (gensym))
  (tuple 'do
    (tuple 'var sym start)
    (tuple 'def endsym end)
    (tuple 'while (tuple '< sym endsym)
     (tuple-prepend body 'do)
     (tuple 'varset! sym (tuple '+ sym inc)))))

(defn even? [x] (== 0 (% x 2)))
(defn odd? [x] (== 1 (% x 2)))

(defmacro let [bindings & body]
  (def head (ast-unwrap1 bindings))
  (when (odd? (length head)) (error "expected even number of bindings to let"))
  (var accum ['do])
  (for [i 0 (length head) 2]
   (array-push accum (tuple 'def 
                     (get head i)
                     (get head (+ 1 i)))))
  (array-push accum (tuple-prepend body 'do))
  (apply tuple accum))

(defn pairs [x]
 (var lastkey (next x nil))
 {
    :more (fn [] lastkey)
    :next (fn []
        (def ret (tuple lastkey (get x lastkey)))
        (varset! lastkey (next x lastkey))
        ret)
 })

(defn keys [x]
 (var lastkey (next x nil))
 {
    :more (fn [] lastkey)
    :next (fn []
        (def ret lastkey)
        (varset! lastkey (next x lastkey))
        ret)
 })

(defn values [x]
 (var lastkey (next x nil))
 {
    :more (fn [] lastkey)
    :next (fn []
        (def ret (get x lastkey))
        (varset! lastkey (next x lastkey))
        ret)
 })

# Compile time

(var *read* nil)
(var *onvalue* identity)
(var *env* (setproto @{} _env))

(def require-loading @{})

(defn onerr [t e]
 (print (string t " error: " e)))

(defn char-stream [getchunk]
 (fiber (fn []
   (def buf @"")
   (var len 1)
   (while (< 0 len)
      (buffer-clear buf)
      (getchunk buf) 
      (varset! len (length buf))
      (for [i 0 len]
        (yield (get buf i))))
   0)))

(defn val-stream [chars ondone]
 (fiber (fn []
    (def p (parser 1)) 
    (var going true)
    (while going
      (def s (parser-status p)) 
      (if (= s :full)
       (yield (parser-produce p))
       (if (= s :error)
        (onerr "parse" (parser-error p))
        (do
         (def stat (fiber-status chars))
         (if (or (= :new stat) (= :pending stat))
          (parser-byte p (resume chars))
          (varset! going false))))))
    (ondone))))

(defn require [path]
 (when (get require-loading path)
  (error (string "circular dependency: module " path " is already loading")))
 (def oldread *read*)
 (def oldonvalue *onvalue*)
 (def oldenv *env*)
 (def f (file-open path))
 (defn getter [buf] (file-read f 1024 buf) buf)
 (defn resetter []
    (put require-loading path nil)
    (varset! *read* oldread)
    (varset! *onvalue* oldonvalue)
    (varset! *env* oldenv)
    (file-close f)
    nil)
 (def cs (char-stream getter))
 (def vs (val-stream cs resetter))
 (varset! *onvalue* identity)
 (varset! *read* (fn [] (resume vs)))
 (varset! *env* (setproto @{} _env))
 *env*)

(defn dorepl []
 (def oldread *read*)
 (defn getter [buf]
    (file-write stdout ">> ")
    (file-read stdin :line buf))
 (defn resetter []
    (varset! *read* oldread)
    nil)
 (def cs (char-stream getter))
 (def vs (val-stream cs resetter))
 (varset! *onvalue* (fn [ret]
  (put *env* '_ @{'value ret})
  (describe ret)))
 (varset! *read* (fn [] (resume vs))))

(defn dostring [str]
 (def oldread *read*)
 (defn getter [buf]
    (buffer-push-string buf str)
    (buffer-push-string buf "\n"))
 (defn resetter []
    (varset! *read* oldread)
    nil)
 (def cs (char-stream getter))
 (def vs (val-stream cs resetter))
 (varset! *onvalue* identity)
 (varset! *read* (fn [] (resume vs))))

(defn init-loop []
 (while *read*
  (def wrapper (fiber (fn []
    (while *read*
      (def source (*read*))
      (def res (compile source *env*))
      (if (= (type res) :function)
        (*onvalue* (res))
        (onerr "compile" (get res :error)))))))
  (def eb (resume wrapper))
  (if (= (fiber-status wrapper) :error) (onerr "runtime" eb wrapper))))

(defn init-repl [] (dorepl) (init-loop))