janet/src/compiler/boot.dst

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

###
###
### Macros and Basic Functions
###
###

(var *env*
 "The current environment."
 _env)

(def defn :macro
 "Define a function"
  (fn [name & more]
   (def len (length 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 
     (if (< i len) (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] 
   (apply1 defn* (array-concat
    @[name :macro] more)))))

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

(defmacro def-
 "Define a private value that will not be exported."
 [name & more]
 (apply1 tuple (array-concat
  @['def 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 indexed? [x]
 (def t (type x))
 (if (= t :array) true (= t :tuple)))
(defn function? [x] 
 (def t (type x)) 
 (if (= t :function) true (= t :cfunction)))
(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 if-not
 "Sorthand for (if (not ... "
 [condition exp-1 exp-2]
 (tuple 'if condition exp-2 exp-1))

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

(defmacro when-not
 "Sorthand for (when (not ... "
  [condition & body]
  (tuple 'if condition nil (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)))

(defn apply
 "Evaluate to (f ...args), where the final value of args must be an array or
tuple and will be spliced into the function call. For example, (apply + 1 2 @[3 4])
evaluates to 10."
 [f & args]
  (def last (- (length args) 1))
  (apply1 f (array-concat (array-slice args 0 -2) (get args last))))

(defmacro switch
"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 atm (atomic? (ast-unwrap1 dispatch)))
  (def sym (if atm dispatch (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))))))
  (if atm
   (aux 0)
   (tuple 'do
    (tuple 'def sym dispatch)
    (aux 0))))

(defmacro let
"Create a scope and bind values to symbols. Each pair in bindings is
assigned as if with def, and the body of the let form returns the last
value."
 [bindings & body]
  (def head (ast-unwrap1 bindings))
  (if (odd? (length head)) (error "expected even number of bindings to let"))
  (def len (length head))
  (var i 0)
  (var accum @['do])
  (while (< i len)
   (array-push accum (tuple 'def
                     (get head i)
                     (get head (+ 1 i))))
   (+= i 2))
  (array-concat accum body)
  (apply1 tuple accum))

(defmacro for 
 "An imperative for loop over an integer range. Use with caution and discretion."
 [head & body]
  (def [sym start end _inc] (ast-unwrap1 head))
  (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 and
 "Evaluates to the last argument if all preceding elements are true, otherwise
evaluates to false."
 [& 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
 "Evaluates to the last argument if all preceding elements are false, otherwise
evaluates to true."
 [& forms]
 (def len (length forms))
 (if (= len 0) false ((fn aux [i]
  (def fi (get forms i))
  (if
   (>= (inc i) len) fi
   (do
    (if (atomic? (ast-unwrap1 fi))
     (tuple 'if fi fi (aux (inc i)))
     (do
      (def $fi (gensym))
      (tuple 'do (tuple 'def $fi fi)
        (tuple 'if $fi $fi (aux (inc i))))))))) 0)))

(defmacro coro
 "A wrapper for making fibers. Same as (fiber (fn [] ...body))."
 [& body]
 (tuple fiber (apply tuple 'fn [] body)))

(defmacro if-let
"Takes the first one or two forms in a vector and if both are true binds
 all the forms with let and evaluates the first expression else
 evaluates the second"
  [bindings tru fal]
  (def bindings (ast-unwrap1 bindings))
  (def len (length bindings))
  (if (zero? len) (error "expected at least 1 binding"))
  (if (odd? len) (error "expected an even number of bindings"))
  (defn aux [i]
    (def bl (get bindings i))
    (def br (get bindings (+ 1 i)))
    (if (>= i len)
     tru
     (do
      (def atm (atomic? (ast-unwrap1 bl)))
      (def sym (if atm bl (gensym)))
      (if atm 
       # Simple binding
       (tuple 'do
        (tuple 'def sym br)
        (tuple 'if sym (aux (+ 2 i)) fal))
       # Destructured binding
       (tuple 'do
        (tuple 'def sym br)
        (tuple 'if sym
         (tuple 'do 
          (tuple 'def bl sym)
          (aux (+ 2 i)))
         fal))))))
  (aux 0))

(defmacro default
 "Suplies a default argument when a value is nil."
 [sym default-value]
 (tuple 'def sym (tuple 'or sym default-value)))

(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]
  (tuple 'if-let bindings (tuple-prepend body 'do)))

(defn comp
"Takes multiple functions and returns a function that is the composition
 of those functions."
 [& functions]
 (switch (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))))))
      (tuple-slice functions 5 -1)))))

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

(defn complement
 "Returns a function that is the complement to the argument."
 [f]
 (fn [x] (not (f x))))

(defn extreme
 "Returns the most extreme value in args based on the orderer order.
Returns nil if args is empty."
 [order args]
 (def len (length args))
 (when (pos? len)
  (var ret (get args 0))
  (for [i 0 len]
   (def v (get args i))
   (if (order v ret) (:= ret v)))
  ret))

(defn max [& args] (extreme > args))
(defn min [& args] (extreme < args))
(defn max-order [& args] (extreme order> args))
(defn min-order [& args] (extreme order< args))

###
###
### Indexed Combinators
###
###

(def sort 
 "Sort an array in-place. Uses quicksort and is not a stable sort."
 (do

  (defn partition
   [a lo hi by]
   (def pivot (get a hi))
   (var i lo)
   (for [j lo hi]
    (def aj (get a j))
    (when (by aj pivot)
     (def ai (get a i))
     (put a i aj)
     (put a j ai)
     (++ i)))
   (put a hi (get a i))
   (put a i pivot)
   i)

  (defn sort-help
   [a lo hi by]
   (when (> hi lo)
    (def piv (partition a lo hi by))
    (sort-help a lo (- piv 1) by)
    (sort-help a (+ piv 1) hi by))
   a)

  (fn [a by]
    (sort-help a 0 (- (length a) 1) (or by order<)))))

(defn sorted
 "Returns the sorted version of an indexed data structure."
 [ind by]
 (def sa (sort (apply1 array ind) by))
 (if (= :tuple (type ind))
  (apply1 tuple sa)
  sa))

(defn reduce
 "Reduce, also know as foldleft in many languages, transform
an indexed type (array, tuple) with a function to produce a value."
 [f init ind]
 (var res init)
 (for [i 0 (length ind)]
  (:= res (f res (get ind i))))
 res)

(defn foreach
 "Call function f on every value in indexed ind."
 [f ind]
 (for [i 0 (length ind)]
  (f (get ind i))))

(defn map
 "Map a function over every element in an array or tuple and return
the same type as the input sequence."
 [f & inds]
 (def res @[])
 (def ninds (length inds))
 (if (= 0 ninds) (error "expected at least 1 indexed collection."))
 (var limit (length (get inds 0)))
 (for [i 0 ninds]
  (def l (length (get inds i)))
  (if (< l limit) (:= limit l)))
 (def [i1 i2 i3 i4] inds)
 (switch ninds
  1 (for [i 0 limit] (array-push res (f (get i1 i))))
  2 (for [i 0 limit] (array-push res (f (get i1 i) (get i2 i))))
  3 (for [i 0 limit] (array-push res (f (get i1 i) (get i2 i) (get i3 i))))
  4 (for [i 0 limit] (array-push res (f (get i1 i) (get i2 i) (get i3 i) (get i4 i))))
  (for [i 0 limit] 
   (def args @[])
   (for [j 0 ninds] (array-push args (get (get inds j) i)))
   (array-push res (apply1 f args))))
 res)

(defn mapcat
 "Map a function over every element in an array or tuple and 
use array concat to concatentae the results. Returns the same
type as the input sequence."
 [f ind t]
 (def res @[])
 (for [i 0 (length ind)]
  (array-concat res (f (get ind i))))
 (if (= :tuple (type (or t ind)))
  (apply1 tuple res)
  res))

(defn filter
 "Given a predicate, take only elements from an array or tuple for
which (pred element) is truthy. Returns the same type as the input sequence."
 [pred ind t]
 (def res @[])
 (for [i 0 (length ind)]
  (def item (get ind i))
  (if (pred item)
   (array-push res item)))
 (if (= :tuple (type (or t ind)))
  (apply1 tuple res)
  res))

(defn find-index
 "Find the index of indexed type for which pred is true. Returns nil if not found."
 [pred ind]
 (def len (length ind))
 (var i 0)
 (var going true)
 (while (if (< i len) going)
  (def item (get ind i))
  (if (pred item) (:= going false) (++ i)))
 (if going nil i))

(defn find
 "Find the first value in an indexed collection that satsifies a predicate. Returns
 nil if not found. Note their is no way to differentiate a nil from the indexed collection
 and a not found. Consider find-index if this is an issue."
 [pred ind]
 (get ind (find-index pred ind)))

(defn take-until
 "Given a predicate, take only elements from an indexed type that satsify
the predicate, and abort on first failiure. Returns a new indexed type that is
the same type as the input."
 [pred ind t]
 (def i (find-index pred ind))
 (if (= :tuple (type (or t ind)))
  (tuple-slice ind 0 i)
  (array-slice ind 0 i)))

(defn take-while
 "Same as (take-until (complement pred) ind t)."
 [pred ind t]
 (take-until (complement pred) ind t))

(defn drop-until
 "Given a predicate, remove elements from an indexed type that satsify
the predicate, and abort on first failiure."
 [pred ind t]
 (def i (find-index pred ind))
 (if (= :tuple (type (or t ind)))
  (tuple-slice ind i -1)
  (array-slice ind i -1)))

(defn drop-while
 "Same as (drop-until (complement pred) ind t)."
 [pred ind t]
 (drop-until (complement pred) ind t))

(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 (tuple '& $args) (apply1 tuple parts)))

(defmacro ->
 "Threading macro. Inserts x as the second value in the first form
in form, and inserts the modified firsts form into the second form
in the same manner, and so on. Useful for expressing pipelines of data."
 [x & forms]
 (defn fop [last nextform]
  (def n (ast-unwrap1 nextform))
  (def [h t] (if (= :tuple (type n))
        [tuple (get n 0) (array-slice n 1)]
        [tuple n @[]]))
  (def parts (array-concat @[h last] t))
  (apply1 tuple parts))
 (reduce fop x forms))

(defmacro ->>
 "Threading macro. Inserts x as the last value in the first form
in form, and inserts the modified firsts form into the second form
in the same manner, and so on. Useful for expressing pipelines of data."
 [x & forms]
 (defn fop [last nextform]
  (def n (ast-unwrap1 nextform))
  (def [h t] (if (= :tuple (type n))
        [tuple (get n 0) (array-slice n 1)]
        [tuple n @[]]))
  (def parts (array-concat @[h] t @[last]))
  (apply1 tuple parts))
 (reduce fop x forms))

(defn partial 
 "Partial function application."
 [f & more]
 (if (zero? (length more)) f
  (fn [& r] (apply1 f (array-concat @[] more r)))))

(defn every? [pred seq]
 (var res true)
 (var i 0)
 (def len (length seq))
 (while (< i len)
  (def item (get seq i))
  (if (pred item)
   (++ i)
   (do (:= res false) (:= i len))))
 res)

(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]
 (switch (type t)
  :tuple (reverse-tuple t)
  :array (reverse-array t)))

(defn zipcoll
"Creates an table or tuple from two arrays/tuples. If a third argument of
 :struct is given result is struct else is table."
  [keys vals t]
  (def res @{})
  (def lk (length keys))
  (def lv (length vals))
  (def len (if (< lk lv) lk lv))
  (for [i 0 len]
   (put res (get keys i) (get vals i)))
  (if (= :struct t)
    (table-to-struct res)
    res))

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

(defn keys
 "Get the keys of an associative data structure."
 [x]
 (def arr @[])
 (var k (next x nil))
 (while k
  (array-push arr k)
  (:= k (next x k)))
 arr)

(defn values
 "Get the values of an associative data structure."
 [x]
 (def arr @[])
 (var k (next x nil))
 (while k
  (array-push arr (get x k))
  (:= k (next x k)))
 arr)

(defn pairs
 "Get the values of an associative data structure."
 [x]
 (def arr @[])
 (var k (next x nil))
 (while k
  (array-push arr (tuple k (get x k)))
  (:= k (next x k)))
 arr)

###
###
### Pretty Printer
###
###

(defn pp 
 "Pretty print a value. Displays values inside collections, and is safe
to call on any table. Does not print table prototype information."
 [x]

  (def buf @"")
  (def indent @"\n")
  (def seen @{})
  (var nextid 0)

  # Forward declaration
  (var recur nil)

  (defn do-ds
   [y start end checkcycle dispatch]
   (def id (get seen y))
   (if (and checkcycle id)
    (do
     (buffer-push-string buf "<cycle ")
     (buffer-push-string buf (string id))
     (buffer-push-string buf ">"))
    (do
     (put seen y (++ nextid))
     (buffer-push-string buf start)
     (dispatch y)
     (buffer-push-string buf end))))

  (defn pp-seq [y]
   (def len (length y))
   (if (< len 5)
    (do
     (for [i 0 len]
      (when (not= i 0) (buffer-push-string buf " "))
      (recur (get y i))))
    (do
      (buffer-push-string indent "  ")
      (for [i 0 len]
       (when (not= i len) (buffer-push-string buf indent))
       (recur (get y i)))
      (buffer-popn indent 2)
      (buffer-push-string buf indent))))

  (defn pp-dict-nested [y]
   (buffer-push-string indent "  ")
   (def ps (sort (pairs y)))
   (for [i 0 (length ps)]
    (def [k v] (get ps i))
    (buffer-push-string buf indent)
    (recur k)
    (buffer-push-string buf " ")
    (recur v))
   (buffer-popn indent 2)
   (buffer-push-string buf indent))

  (defn pp-dict-simple [y]
   (def ps (sort (pairs y)))
   (for [i 0 (length ps)]
    (def [k v] (get ps i))
    (if (pos? i) (buffer-push-string buf " "))
    (recur k)
    (buffer-push-string buf " ")
    (recur v)))

  (defn pp-dict [y]
   ((if (> 4 (length y)) pp-dict-simple pp-dict-nested) y))

  (def printers {
   :array  (fn [y] (do-ds y "@[" "]" true pp-seq))
   :tuple  (fn [y] (do-ds y "(" ")" false pp-seq))
   :table  (fn [y] (do-ds y "@{" "}" true pp-dict))
   :struct  (fn [y] (do-ds y "{" "}" false pp-dict))
  })
  
  (:= recur (fn [y]
    (def p (get printers (type y)))
    (if p
     (p y)
     (buffer-push-string buf (describe y)))))

  (recur x)
  (buffer-push-string buf "\n")

  (file-write stdout buf))

###
###
### Macro Expansion
###
###

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

###
###
### Evaluation and Compilation
###
###

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

(defn 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."
 [env chunks onvalue onerr]

 # Are we done yet?
 (var going true)

 # Fiber stream of characters
 (def chars (coro
   (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))

 # Fiber stream of values
 (def vals (coro
  (def p (parser 1)) 
  (while going
    (switch (parser-status p)
     :full (yield (parser-produce p))
     :error (onerr "parse" (parser-error p))
     (switch (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"))))

 # Evaluate 1 source form
 (defn eval1 [source]
  (var good true)
  (def f (coro
    (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))))

 # Run loop
 (def oldenv *env*)
 (:= *env* env)
 (while going (eval1 (resume vals)))
 (:= *env* oldenv)

 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))
     (run-context newenv chunks identity default-error-handler)
     (file-close f)
     (put loading path nil)
     newenv)))))

(defn import* [env path & args]
 (def newenv (require path))
 (def {
  :prefix prefix
  } (apply1 table args))
 (var k (next newenv nil))
 (def prefix (if prefix prefix ""))
 (while k
  (def v (get newenv k))
  (when (not (get v :private))
   (put env (symbol prefix k) v))
  (:= k (next newenv k)))
 env)

(defmacro import [path & args]
 (apply tuple import* '_env path args))

(defn repl [getchunk]
 "Run a repl. The first paramets is an optional function to call to
get a chunk of soure code. Should return nil for end of file."
 (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))