janet/src/compiler/boot.dst

# Capture the current env
(var *env*
 "A var that points to the current environment."
 _env)

(def defn macro
 "Define a function"
  (fn [name & more] 
   (def fstart (fn recur [i]
    (def ith (ast-unwrap1 (get more i)))
    (def t (type ith))
    (def tuple? (= t :tuple))
    (def array? (= t :array))
    (if (if tuple? tuple? array?) i (recur (+ i 1)))))
   (def start (fstart 0))
   (def fnbody (tuple-prepend (tuple-prepend (tuple-slice more start) name) 'fn))
   (def formargs (array-concat ['def name] (array-slice more 0 start) [fnbody]))
   (apply tuple formargs)))

(def defmacro macro
 "Define a macro."
 (do
  (def defn* (get (get _env 'defn) 'value))
  (fn [name & more] 
   (def args (array-concat [] name 'macro more))
   (apply defn* args))))

(defmacro when
 "(when cond & body)
 Evaluates the body when the condition is true. Otherwise returns nil."
 [cond & body] 
 (tuple 'if cond (tuple-prepend body 'do)))

(defmacro cond
 "(cond & body)
 Evaluates conditions sequentially until the first true condition
 is found, and then executes the corresponding body. If there are an
 odd number of forms, the last expression is executed if no forms
 are matched. If there are no matches, return nil."
 [& pairs]
  (defn aux [i]
    (def restlen (- (length pairs) i))
    (if (= restlen 0) nil
     (if (= restlen 1) (get pairs i)
      (tuple 'if (get pairs i)
       (get pairs (+ i 1))
       (aux (+ i 2))))))
  (aux 0))

(defn doc
 "(doc sym)
 Shows documentation for the given symbol."
 [sym]
 (def x (get *env* sym))
 (if (not x)
  (print "symbol " x " not found.")
  (do
   (def d (get x 'doc))
   (print "\n" (if d d "no documentation found.") "\n"))))

(defmacro select
"(select dispatch & body)
 Select the body that equals the dispatch value. When pairs
 has an odd number of arguments, the last is the default expression.
 If no match is found, returns nil"
 [dispatch & pairs]
  (def sym (gensym))
  (defn aux [i]
    (def restlen (- (length pairs) i))
    (if (= restlen 0) nil
     (if (= restlen 1) (get pairs i)
      (tuple 'if (tuple = sym (get pairs i))
       (get pairs (+ i 1))
       (aux (+ i 2))))))
  (tuple 'do
   (tuple 'def sym dispatch)
   (aux 0)))

(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 {:more more :next next} (seq s))
 (while (more) (next)))

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

(defn reduce [f start s]
  (def {:more more :next next} (seq s))
  (if (more)
   (reduce f (f start (next)) s)
   start))

(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"))
  (def len (length head))
  (var [i accum] [0 ['do]])
  (while (< i len)
   (array-push accum (tuple 'def 
                     (get head i)
                     (get head (+ 1 i))))
   (varset! i (+ i 2)))
  (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)
 })

(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)))))

# Compile time

(defn make-env [parent]
 (def parent (if parent parent _env))
 (def newenv (setproto @{} parent))
 newenv)
(put _env '_env nil)

(def run-context 
 "(run-context env chunks onvalue onerr)
 Run a context. This evaluates expressions of dst in an environment,
 and is encapsulates the parsing, compilation, and evaluation of dst.
 env is the environment to evaluate the code in, chunks is a function
 that returns strings or buffers of source code (from a repl, file,
 network connection, etc. onvalue and onerr are callbacks that are
 invoked when a result is returned and when an error is produced,
 respectively.
 
 This function can be used to implemement a repl very easily, simply
 pass a function that reads line from stdin to chunks, and print to
 onvalue."
(do
(defn val-stream [chunks onerr]
 (var going true)
 (def chars (fiber (fn []
   (def buf @"")
   (var len 1)
   (while (< 0 len)
      (buffer-clear buf)
      (chunks buf) 
      (varset! len (length buf))
      (for [i 0 len]
        (yield (get buf i))))
   0)))
 (var temp nil)
 (var tempval nil)
 (def f (fiber (fn []
    (def p (parser 1)) 
    (while going
      (select (parser-status p)
       :full (yield (parser-produce p))
       :error (onerr "parse" (parser-error p))
       (select (fiber-status chars)
        :new (parser-byte p (resume chars))
        :pending (parser-byte p (resume chars))
        (varset! going false)))))))
 (defn more [] (if temp true 
  (do 
   (varset! temp true)
   (varset! tempval (resume f))
   going)))
 (defn next [] (if temp
  (do (varset! temp nil) tempval)
  (resume f)))
 {:more more :next next})

(fn [env chunks onvalue onerr]
 (defn doone [source]
  (def f (fiber (fn []
    (def res (compile source env))
    (if (= (type res) :function)
      (res)
      (onerr "compile" (get res :error))))))
  (def res (resume f))
  (if (= (fiber-status f) :error)
   (onerr "runtime" res)
   (onvalue res)))
 (def oldenv *env*)
 (varset! *env* env) 
 (doseq (map doone (val-stream chunks onerr)))
 (varset! *env* oldenv)
 env)))

(def require (do
 (def cache @{})
 (def loading @{})
 (fn [path]
   (when (get loading path)
    (error (string "circular dependency: module " path " is loading")))
   (def check (get cache path))
   (if check check (do
     (def newenv (make-env))
     (put cache path newenv)
     (put loading path true)
     (def f (file-open path))
     (defn chunks [buf] (file-read f 1024 buf))
     (run-context newenv chunks identity
      (fn [t x] (print (string t " error: " x))))
     (file-close f)
     (put loading path nil)
     newenv)))))

(defn import [path & args]
 (def env (require path))
 (def {
  :prefix prefix
  } (apply table args))
 (defn one [pair]
  (def [k v] pair)
  (put *env* (symbol (if prefix prefix "") k) v))
 (doseq (map one (pairs env))))

(defn repl []
 (def newenv (make-env))
 (defn chunks [buf]
    (file-write stdout ">> ")
    (file-read stdin :line buf))
 (defn onvalue [x]
  (put newenv '_ @{'value x})
  (describe x))
 (run-context newenv chunks onvalue
  (fn [t x] (print (string t " error: " x)))))