janet/src/compiler/boot.dst

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

(var *env*
 "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]))
   (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)))

# Basic predicates
(defn even? [x] (== 0 (% x 2)))
(defn odd? [x] (== 1 (% x 2)))
(defn zero? [x] (== x 0))
(defn pos? [x] (> x 0))
(defn neg? [x] (< x 0))
(defn one? [x] (== x 1))
(defn table? [x] (= (type x) :table ))
(defn struct? [x] (= (type x) :struct))
(defn array? [x] (= (type x) :array))
(defn tuple? [x] (= (type x) :tuple))
(defn boolean? [x] (= (type x) :boolean))
(defn true? [x] (= (type x) true))
(defn false? [x] (= (type x) false))
(defn nil? [x] (= x nil))
(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 and functions for imperative sugar
(defn inc [x] (+ x 1))
(defn dec [x] (- x 1))
(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)
 })

(defn partial [f & more]
 (if (zero? (length more)) f
  (fn [& r] (apply1 f (array-concat [] more r)))))

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

(defn juxt*
  [& funs]
  (def len (length funs))
  (fn [& args]
   (def ret [])
   (for [i 0 len]
    (array-push ret (apply1 (get funs i) args)))
   (apply1 tuple ret)))

(defmacro juxt
 [& funs]
 (def parts ['tuple])
 (def $args (gensym))
 (for [i 0 (length funs)]
  (array-push parts (tuple apply1 (get funs i) $args)))
 (tuple 'fn ['& $args] (apply1 tuple parts)))

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

(defn reverse-array
 "Reverses the order of the elements in a given array or tuple and returns a new array."
 [t]
 (var n (dec (length t)))
 (var reversed [])
 (while (>= n 0)
  (array-push reversed (get t n))
  (-- n))
  reversed)

(defn reverse-tuple
 "Reverses the order of the elements given an array or tuple and returns a tuple"
 [t]
 (apply1 tuple (reverse-array t)))

(defn reverse
 "Reverses order of elements in a given array or tuple"
 [t]
 (select (type t)
  :tuple (reverse-tuple t)
  :array (reverse-array t)))

(defmacro if-not
 "Sorthand for (if (not ... "
 [condition exp-1 exp-2]
 (tuple 'if (tuple not condition)
       exp-1
       exp-2))

(defmacro when-not
 "Sorthand for (when (not ... "
  [condition exp-1]
  (tuple 'when (tuple not condition) exp-1))

(defmacro if-let
"Takes the first one or two forms in a vector and if true binds
 all the forms with let and evaluates the first expression else
 evaluates the second"
  [bindings then else]
  (def head (ast-unwrap1 bindings))
  (tuple 'let head
         (tuple 'if (and (get head 1) (if (get head 2) (get head 3) true))
              then
              else)))

(defmacro when-let
"Takes the first one or two forms in vector and if true binds
 all the forms  with let and evaluates the body"
  [bindings & body]
  (def head (ast-unwrap1 bindings))
  (tuple 'let head
      (tuple
        'when
        (and (get head 1) (if (get head 2) (get head 3) true))
        (apply1 tuple (array-concat ['do] (ast-unwrap1 body))))))

(defn comp
"Takes multiple functions and returns a function that is the composition
 of those functions."
 [& functions]
 (select (length functions)
  0 nil
  1 (get functions 0)
  2 (let [[f g]       functions] (fn [x] (f (g x))))
  3 (let [[f g h]     functions] (fn [x] (f (g (h x)))))
  4 (let [[f g h i]   functions] (fn [x] (f (g (h (i x))))))
    (let [[f g h i j] functions]
     (apply comp (fn [x] (f (g (h (i (j x))))))
      (array-slice functions 5 -1)))))

(defn zipcoll
"Creates an table or tuple from two arrays/tuples. If a third argument of
 :struct is givent resault is struct else is table."
  [coll-1 coll-2 the-type]
  (var zipping-table @{})
  (def {:more more1 :next next1} (iter coll-1))
  (def {:more more2 :next next2} (iter coll-2))
  (while (and (more1) (more2))
    (put zipping-table (next1) (next2)))
  (if (struct? the-type)
    (table-to-struct zipping-table)
    zipping-table))

(defn update
"Accepts a key argument and passes its' associated value to a function.
 The key then, is associated to the function's return value"
  [coll a-key a-function & args]
  (def old-value (get coll a-key) )
  (put coll a-key (apply a-function old-value args)))

(defn merge
  "Merges mutliple tables/structs to one. If a key appears in more than one
   collection, then later values replace any previous ones.
   The type of the first collection determines the type of the resulting
   collection"
  [& colls]
  (def container @{})
  (for [i 0 (length colls)]
   (def c (get colls i))
   (var key (next c nil))
   (while (not= nil key)
     (put container key (get c key))
     (:= key (next c key))))
  (if (table? (get colls 0)) container (table-to-struct container)))

# Start pretty printer
(def pp (do
  (defn- pp-seq [pp seen buf a start end checkcycle]
   (if (and checkcycle (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 checkcycle]
   (if (and checkcycle (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 "[" "]" true))
   :tuple  (fn [pp seen buf x] (pp-seq pp seen buf x "(" ")"))
   :table  (fn [pp seen buf x] (pp-dict pp seen buf x "@{" "}" true))
   :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 macroexpand1
 "Expand macros in a form, but do not recursively expand macros."
 [x]

 (defn doarray [a]
  (def len (length a))
  (def newa [])
  (for [i 0 len]
   (array-push newa (macroexpand1 (get a i))))
  newa)

 (defn dotable [t]
  (def newt @{})
  (var key (next t nil))
  (while (not= nil key)
   (put newt (macroexpand1 key) (macroexpand1 (get t key)))
   (:= key (next t key)))
  newt)

 (defn expandlast [t]
  (def len (length t))
  (def last (get t (- len 1)))
  (tuple-append (tuple-slice t 0 -2) (macroexpand1 last)))

 (defn expandall [t]
  (def args (doarray (tuple-slice t 1)))
  (apply tuple (get t 0) args))

 (defn expandfn [t]
  (def args (doarray (tuple-slice t 2)))
  (apply tuple 'fn (get t 1) args))

  (def specs {
      ':= expandlast
      'ast-quote identity
      'def expandlast
      'do expandall
      'fn expandfn
      'if expandall
      'quote identity
      'var expandlast
      'while expandall
   })

 (defn dotup [t]
  (def h (get t 0))
  (def s (get specs h))
  (def entry (get *env* h))
  (def m (get entry :value))
  (def m? (get entry :macro))
  (cond
   s (s t)
   m? (apply1 m (tuple-slice t 1))
   (apply1 tuple (doarray t))))

 (defn doarray* [a]
  (def res (doarray a))
  (if (= (apply tuple res) (apply tuple a)) a res))

 (defn dotable* [t]
  (def res (dotable t))
  (if (= (table-to-struct res) (table-to-struct t)) t res))

 (def ux (ast-unwrap1 x))
 (select (type ux)
  :tuple (dotup ux)
  :array (doarray* ux)
  :struct (table-to-struct (dotable ux))
  :table (dotable* ux)
  ux))

(defn macroexpand
 "Expand macros completely."
 [x]
 (var previous x)
 (var current (macroexpand1 x))
 (var counter 0)
 (while (not= current previous)
  (if (> (++ counter) 200)
   (error "macro expansion too nested"))
  (:= previous current)
  (:= current (macroexpand1 current)))
 current)

(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]
  (var good true)
  (def f (fiber (fn []
    (def res (compile source env))
    (if (= (type res) :function)
      (res)
      (do
       (:= good false)
       (onerr "compile" (get res :error)))))))
  (def res (resume f))
   (if good
    (if (= (fiber-status f) :error)
     (onerr "runtime" res f)
     (onvalue res))))
 (foreach (val-stream chunks onerr) doone)
 env)))

(defn default-error-handler
 [t x f]
 (file-write stdout (string t " error: "))
 (pp x)
 (when f
  (def st (fiber-stack f))
  (def len (length st))
  (for [i 0 len]
   (def {
    :function func
    :tail tail
    :pc pc
    :c c
    :name name
    } (get st i))
   (file-write stdout "  in")
   (when c (file-write stdout " cfunction"))
   (when name (file-write stdout (string " " name)))
   (when func (file-write stdout (string " " func)))
   (when pc (file-write stdout (string " (pc=" pc ")")))
   (when tail (file-write stdout " (tailcall)"))
   (file-write stdout "\n"))))

(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))
     (def oldenv *env*)
     (:= *env* newenv)
     (run-context newenv chunks identity default-error-handler)
     (file-close f)
     (:= *env* oldenv)
     (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]
 (apply tuple 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 default-error-handler))