janet/src/compiler/boot.dst

# Bootstrap the dst environment
# Copyright 2018 (C) Calvin Rose

(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]))
   (apply1 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))
   (apply1 defn* args))))

(defmacro defmacro-
 "Define a private macro that will not be exported."
 [name & more]
 (apply1 tuple (array-concat
  ['defmacro name :private] more)))

(defmacro defn-
 "Define a private function that will not be exported."
 [name & more]
 (apply1 tuple (array-concat
  ['defn name :private] more)))

(defn even? [x] (== 0 (% x 2)))
(defn odd? [x] (== 1 (% x 2)))
(defn nil? [x] (= x nil))
(defn zero? [x] (== x 0))
(defn pos? [x] (> x 0))
(defn neg? [x] (< x 0))
(defn one? [x] (== x 1))
(defn inc [x] (+ x 1))
(defn dec [x] (- x 1))
(def atomic? (do
  (def non-atomic-types {
   :array true
   :tuple true
   :table true
   :struct true
  })
  (fn [x] (not (get non-atomic-types (type x))))))

# C style macros for imperative sugar
(defmacro ++ [x] (tuple ':= x (tuple + x 1)))
(defmacro -- [x] (tuple ':= x (tuple - x 1)))
(defmacro += [x n] (tuple ':= x (tuple + x n)))
(defmacro -= [x n] (tuple ':= x (tuple - x n)))
(defmacro *= [x n] (tuple ':= x (tuple * x n)))
(defmacro /= [x n] (tuple ':= x (tuple / x n)))
(defmacro %= [x n] (tuple ':= x (tuple % x n)))
(defmacro &= [x n] (tuple ':= x (tuple & x n)))
(defmacro |= [x n] (tuple ':= x (tuple | x n)))
(defmacro ^= [x n] (tuple ':= x (tuple ^ x n)))
(defmacro >>= [x n] (tuple ':= x (tuple >> x n)))
(defmacro <<= [x n] (tuple ':= x (tuple << x n)))
(defmacro >>>= [x n] (tuple ':= x (tuple >>> x n)))

(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*
 [env 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 doc
 "Shows documentation for the given symbol."
 [sym]
 (tuple doc* '_env (tuple 'quote sym)))

(def apply
 (fn [f & args]
  (def last (- (length args) 1))
  (apply1 f (array-concat (array-slice args 0 -2) (get args last)))))

(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 and [& forms] 
 (def len (length forms))
 (if (= len 0) true ((fn aux [i]
  (cond
   (>= (inc i) len) (get forms i)
   (tuple 'if (get forms i) (aux (inc i)) false))) 0)))

(defmacro or [& forms] 
 (def len (length forms))
 (if (= len 0) false ((fn aux [i]
  (cond
   (>= (inc i) len) (get forms i)
   (tuple 'if (get forms i) true (aux (inc i))))) 0)))

(defn identity 
 "A function that returns its first argument."
[x] x)

(def iter (do
  (defn array-iter [x]
    (def len (length x))
    (var i 0)
    {
      :more (fn [] (< i len))
      :next (fn []
        (def ret (get x i))
        (:= i (+ i 1))
        ret) 
    })
  (def iters {
    :array array-iter
    :tuple array-iter
    :struct identity})
  (fn [x]
   (def makei (get iters (type x)))
   (if makei (makei x) (error "expected sequence")))))

(defn range2 [bottom top]
  (var i bottom)
  {
    :more (fn [] (< i top))
    :next (fn []
      (def ret i)
      (:= i (+ i 1))
      ret) 
  })

(defn range [top] (range2 0 top))

(defn doiter [itr] 
 (def {:more more :next next} (iter itr))
 (while (more) (next)))

(defn foreach [itr f] 
 (def {:more more :next next} (iter itr))
 (while (more) (f (next))))

(defn iter2array [itr] 
 (def {:more more :next next} (iter itr))
 (def a [])
 (while (more) (array-push a (next)))
 a)

(defn map [f itr]
 (def {:more more :next next} (iter itr))
 {:more more :next (fn [] (f (next)))})

(defn reduce [f start itr]
  (def itr (iter itr))
  (def {:more more :next next} itr)
  (if (more)
   (reduce f (f start (next)) itr)
   start))

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

(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))))
   (:= i (+ i 2)))
  (array-push accum (tuple-prepend body 'do))
  (apply1 tuple accum))

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

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

(defn values [x]
 (var lastkey (next x nil))
 {
    :more (fn [] lastkey)
    :next (fn []
        (def ret (get x lastkey))
        (:= 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 ':= 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))
  (apply1 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]))
  (apply1 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)
      (:= 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 unique [s]
  (def tab @{})
  (foreach s (fn [x] (put tab x true)))
  (keys tab))

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

(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) 
      (:= 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))
        (:= going false))))
    (when (not= :root (parser-status p))
     (onerr "parse" "unexpected end of source"))
    nil)))
 (defn more [] (if temp true 
  (do 
   (:= temp true)
   (:= tempval (resume f))
   going)))
 (defn next [] (if temp
  (do (:= 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)))
 (foreach (val-stream chunks onerr) doone)
 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* [env path & args]
 (def newenv (require path))
 (def {
  :prefix prefix
  } (apply1 table args))
 (foreach (pairs newenv) (fn [[k v]]
  (when (not (get v :private))
   (put env (symbol (if prefix prefix "") k) v)))))

(defmacro import [path & args]
 (apply1 tuple (array-concat [import* '_env path] args))) 

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