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 defn-
 "Define a private function that will not be exported."
 [name & more]
 (apply tuple (array-concat
  ['defn name :private] more)))

(defmacro comment
 "Ignores the body of the comment."
 [])

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

(defmacro cond
"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
 "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 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))

(defn identity 
 "A function that returns its first argument."
[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 domap [f s] 
 (def {:more more :next next} (seq s))
 (while (more) (f (next))))

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

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

(defn filter [pred s]
 (def s (seq s))
 (def {:more more :next next} s)
 (var alive true)
 (var temp nil)
 (var isnew true)
 (defn nextgood []
   (if alive
    (if (more)
     (do
      (def n (next))
      (if (pred n) n (nextgood)))
     (varset! alive false))))
 (defn nnext [] (def ret temp) (varset! temp (nextgood)) ret)
 (defn nmore [] (when isnew (varset! isnew false) (nnext)) alive)
 {:more nmore :next nnext})

(defn even? [x] (== 0 (% x 2)))
(defn odd? [x] (== 1 (% x 2)))
(defn nil? [x] (= x nil))
(defn zero? [x] (== x 0))
(defn one? [x] (== x 1))
(defn inc [x] (+ x 1))
(defn dec [x] (- x 1))

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

(defmacro ->
 [x & forms]
 (defn fop [last nextform]
  (def n (ast-unwrap1 nextform))
  (def [h t] (if (= :tuple (type n))
        [(get n 0) (array-slice n 1)]
        [n []]))
  (def parts (array-concat [h last] t))
  (apply tuple parts))
 (reduce fop x forms))

(defmacro ->>
 [x & forms]
 (defn fop [last nextform]
  (def n (ast-unwrap1 nextform))
  (def [h t] (if (= :tuple (type n))
        [(get n 0) (array-slice n 1)]
        [n []]))
  (def parts (array-concat [h] t [last]))
  (apply tuple parts))
 (reduce fop x forms))

# Start pretty printer
(def pp (do
  (defn- pp-seq [pp seen buf a start end]
   (if (get seen a)
    (buffer-push-string buf "<cycle>")
    (do
     (put seen a true)
     (def len (length a))
     (buffer-push-string buf start)
     (for [i 0 len]
      (when (not= i 0) (buffer-push-string buf " "))
      (pp seen buf (get a i)))
     (buffer-push-string buf end)))
   buf)

  (defn- pp-dict [pp seen buf a start end]
   (if (get seen a)
    (buffer-push-string buf "<cycle>")
    (do
     (put seen a true)
     (var k (next a nil))
     (buffer-push-string buf start)
     (while k
      (def v (get a k))
      (pp seen buf k)
      (buffer-push-string buf " ")
      (pp seen buf v)
      (varset! k (next a k))
      (when k (buffer-push-string buf " ")))
     (buffer-push-string buf end)))
   buf)

  (def printers :private {
   :array  (fn [pp seen buf x] (pp-seq pp seen buf x "[" "]"))
   :tuple  (fn [pp seen buf x] (pp-seq pp seen buf x "(" ")"))
   :table  (fn [pp seen buf x] (pp-dict pp seen buf x "@{" "}"))
   :struct (fn [pp seen buf x] (pp-dict pp seen buf x "{" "}"))
  })

  (defn- default_printer [pp seen buf x] 
   (buffer-push-string buf (describe x)) 
   buf)

  (defn- pp1 [seen buf x]
    (def pmaybe (get printers (type x)))
    (def p (if pmaybe pmaybe default_printer))
    (p pp1 seen buf x))

  (fn [x] (print (pp1 @{} @"" x)))))
# End pretty printer

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

(def run-context 
"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)
 # Stream of characters
 (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)
 # Stream of values
 (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 [[k v]]
  (when (not (get v :private))
   (put *env* (symbol (if prefix prefix "") k) v)))
 (doseq (map one (pairs env))))

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