shithub: sl

ref: 5a4fb16e97cf9ed17c7d80cbfb17c7412d544da6
dir: /src/system.sl/

View raw version
;;;; standard library

;;; void

(def (void . rest)
  "Return the constant `#<void>` while ignoring any arguments.

   `#<void>` is mainly used when a function has side effects but does not
   produce any meaningful value to return, so even though `T` or `NIL` could
   be returned instead, in case of `#<void>` alone, REPL will not print
   it."
  #.(void))

(def (void? x)
  "Return `T` if `x` is `#<void>`, `NIL` otherwise."
  (eq? x #.(void)))

;;; syntax environment

(unless (bound? '*syntax-environment*)
  (def *syntax-environment* (table)))

(def (set-syntax! s v)
  (put! *syntax-environment* s v))

(def (get-syntax s)
  (get *syntax-environment* s NIL))

(defmacro (defmacro form . body)
  (let* {[doc+body (separate-doc-from-body body)]
         [doc      (car doc+body)]
         [body     (cdr doc+body)]}
    (when doc
      (sym-set-doc (car form) doc (cdr form)))
    `(void (set-syntax! ',(car form)
                  (λ ,(cdr form) ,@body)))))

(defmacro (letrec binds . body)
  `((λ ,(map car binds)
      ,.(map (λ (b) `(set! ,@b)) binds)
      ,@body)
    ,.(map void binds)))

(defmacro (let binds . body)
  (let ((lname NIL))
    (when (sym? binds)
      (set! lname binds)
      (set! binds (car body))
      (set! body (cdr body)))
    (let ((thelambda
           `(λ ,(map (λ (c) (if (cons? c) (car c) c))
                     binds)
              ,@body))
          (theargs
           (map (λ (c) (if (cons? c) (cadr c) (void)))
                binds)))
      (cons (if lname
                `(letrec ((,lname ,thelambda)) ,lname)
                thelambda)
            theargs))))

(defmacro (cond . clauses)
  (def (cond-clauses->if lst)
    (if (atom? lst)
        NIL
        (let ((clause (car lst)))
          (if (or (eq? (car clause) 'else)
                  (eq? (car clause) T))
              (if (not (cdr clause))
                  (car clause)
                  (cons 'begin (cdr clause)))
              (if (not (cdr clause))
                  ; test by itself
                  (list 'or
                        (car clause)
                        (cond-clauses->if (cdr lst)))
                  ; test => expression
                  (if (eq? (cadr clause) '=>)
                      (if (1arg-lambda? (caddr clause))
                          ; test => (λ (x) ...)
                          (let ((var (caadr (caddr clause))))
                            `(let ((,var ,(car clause)))
                               (if ,var
                                   ,(cons 'begin (cddr (caddr clause)))
                                   ,(cond-clauses->if (cdr lst)))))
                          ; test => proc
                          `(let ((b# ,(car clause)))
                             (if b#
                                 (,(caddr clause) b#)
                                 ,(cond-clauses->if (cdr lst)))))
                      (list 'if
                            (car clause)
                            (cons 'begin (cdr clause))
                            (cond-clauses->if (cdr lst)))))))))
  (cond-clauses->if clauses))

;;; props

;; This is implemented in a slightly different fashion as expected:
;;
;;     *properties* : key → { symbol → value }
;;
;; The assumption here is that keys will most likely be the same across multiple symbols
;; so it makes more sense to reduce the number of subtables for the *properties* table.
(unless (bound? '*properties*)
  (def *properties*
    "All properties of symbols recorded with `putprop` are recorded in this
     table."
    :doc-group prop
    (table)))

(def (putprop symbol key val)
  "Associate a property value with the symbol."
  :doc-group prop
  :doc-see getprop
  (let ((kt (get *properties* key NIL)))
    (unless kt
        (let ((ta (table)))
          (put! *properties* key ta)
          (set! kt ta)))
    (put! kt symbol val)
    val))

(def (getprop symbol key (def NIL))
  "Return a property value associated with the symbol or `def` if
   missing."
  :doc-group prop
  :doc-see putprop
  (let ((kt (get *properties* key NIL)))
    (or (and kt (get kt symbol def)) def)))

(def (remprop symbol key)
  "Remove a property value associated with the symbol."
  :doc-group prop
  (let ((kt (get *properties* key NIL)))
    (and kt (has? kt symbol) (del! kt symbol))))

;;; documentation

(def (separate-doc-from-body body (doc NIL))
  "Take a list of terms and return a pair `(doc . body)`, where the first
   element contains a list of documentation-related terms, and the second
   contains the rest of the terms."
  :doc-group doc
  (def (doc? kw)
    (and (> (str-length kw) 5)
         (eq? (str-rune kw 1) #\d)
         (eq? (str-rune kw 2) #\o)
         (eq? (str-rune kw 3) #\c)
         (eq? (str-rune kw 4) #\-)))
  (let {[hd (car body)]
        [tl (cdr body)]}
    (cond [(and (str? hd) (not doc) tl)
           (separate-doc-from-body tl (cons hd doc))]
          [(and doc (keyword? hd) (doc? (str hd)))
           (separate-doc-from-body (cdr tl) (cons (cons hd (car tl)) doc))]
          [else (cons (reverse doc) body)])))

(def (sym-set-doc symbol doc-seq . formals-list)
  "Set the documentation for the symbol."
  :doc-group doc
  (def (formals-clean fs)
    (when (atom? fs)
      (return fs))
    (let ((f (car fs)))
      (cons (if (and (cons? f)
                     (length> f 2))
                (subseq f 0 2)
                f)
            (formals-clean (cdr fs)))))
  (let* {[doc-only (str? doc-seq)]
         [doc (if doc-only doc-seq (car doc-seq))]
         [extra (if doc-only NIL (cdr doc-seq))]
         [formals-list (map formals-clean formals-list)]}
    (when (and (bound? 'str-join) doc)
      (let* {[lines (str-split doc "\n")]
             [hd (car lines)]
             [tl (cdr lines)]
             [snd (any (λ (s) (and (> (str-length s) 0)
                                   (eq? (str-rune s 0) #\space)
                                   s))
                       tl)]
             [indent (and snd
                          (- (length snd)
                             (length (str-trim snd " " ""))))]
             [trimmed (and snd
                        (map (λ (s) (if (<= indent (length s))
                                        (str-sub s indent)
                                        s))
                             tl))]
             [final (str-join (cons hd trimmed) "\n")]}
      (putprop symbol '*doc* final)
      (when extra (putprop symbol '*doc-extra* extra))))
    (when (cons? formals-list)
      (let* {[existing (getprop symbol '*formals-list*)]
             ; filter out duplicates
             [to-add (filter (λ (formals) (not (member formals existing)))
                             formals-list)]}
        (putprop symbol '*formals-list* (append existing to-add))))
    (void)))

(def (help-print-header term sigs (:kind NIL) (:lpad ""))
  "Format and print signature(s) of the term for `(help term)` output."
  :doc-group doc
  (if sigs
      (for-each (λ (sig) (princ lpad)
                         (print (cons term sig))
                         (newline))
                sigs)
      (begin
        (princ lpad)
        (if kind
            (princ (caddr term) " (group)")
            (print term))
        (newline)))
  (newline))

(defmacro (help term (kind NIL) (:print-header help-print-header))
  "Display documentation the specified term, if available.

   The optional parameter `kind` can be set to `group` to show
   documentation for the specified group instead of a single term.
   All available documentation groups can be displayed with `(help
   groups)`."
  :doc-group doc
  (let* {[doc-extra-term (and kind (cons (sym ":doc-" kind) term))]
         [docterm (if kind (list 'doc kind term) term)]
         [doc (getprop docterm '*doc*)]
         [formals-list (getprop docterm '*formals-list*)]}
    (def (print-sig term sigs lpad)
      (if sigs
          (for-each (λ (sig) (newline)
                             (princ lpad)
                             (print (cons term sig)))
                    sigs)
          (begin (newline)
                 (princ lpad)
                 (print term))))
    (def (first-line s)
      (let* {[nl (str-find s "\n")]}
        (if nl (str-sub s 0 nl) s)))
    (def (doc-group? k)
      (and (cons? k)
           (eq? (car k) 'doc)
           (eq? (cadr k) 'group)))
    (def (doc-extra-term? k)
      (and (atom? k)
           (member doc-extra-term (getprop k '*doc-extra*))))
    (def (table-keys-filter-sort tbl pred)
      (sort (table-foldl (λ (k _ z) (if (pred k) (cons k z) z)) NIL tbl) <))
    (if (eq? term 'groups)
        (for-each (λ (k) (princ (caddr k) ": " (first-line (getprop k '*doc*)))
                         (newline))
                  (table-keys-filter-sort (get *properties* '*doc*)
                                          doc-group?))
        (if (or doc formals-list)
            (begin (print-header docterm formals-list :kind kind)
                   (let* {[extra (getprop docterm '*doc-extra*)]
                          [fmt (filter (λ (v) (eq? (car v) :doc-fmt)) extra)]
                          [see (filter (λ (v) (eq? (car v) :doc-see)) extra)]}
                     (when doc
                       (princ (foldl (λ (fmt doc) ((cdr fmt) doc)) doc fmt))
                       (newline))
                     (when see
                       (newline)
                       (princ "See also:")
                       (newline)
                       (for-each (λ (v) (print-sig (cdr v)
                                                   (getprop (cdr v) '*formals-list*)
                                                   "    "))
                                 see)
                       (newline)))
                   (when kind
                     (newline)
                     (princ "Members:")
                     (newline)
                     (for-each (λ (k) (print-sig k
                                                 (getprop k '*formals-list*)
                                                 "    "))
                               (table-keys-filter-sort (get *properties* '*doc*)
                                                       doc-extra-term?))
                     (newline))
                   (void))
            (begin (princ "no help for " (if kind (str kind " ") "") term)
                   (when (and (not kind)
                              (sym? term)
                              (not (bound? term)))
                     (princ " (undefined)"))
                     (newline))))
  (void)))

;;; standard procedures

(def (member item lst)
  (cond ((equal? (car lst) item) lst)
        (lst                     (member item (cdr lst)))))

(def (memv item lst)
  (cond ((eqv? (car lst) item) lst)
        (lst                   (memv item (cdr lst)))))

(def (assoc-list . lst)
  (let ((s (cdr lst)))
    (when (cons? s)
      (cons (cons (car lst) (car s))
            (apply assoc-list (cdr s))))))

(def (assoc item lst)
  (cond ((equal? (caar lst) item) (car lst))
        (lst                      (assoc item (cdr lst)))))

(def (assv item lst)
  (cond ((eqv? (caar lst) item) (car lst))
        (lst                    (assv item (cdr lst)))))

(doc-group compare
  "Comparison operators.")

(def (> a . rest)
  "Return `T` if the arguments are in strictly decreasing order (previous
   one is greater than the next one)."
  :doc-group compare
  (let loop ((a a) (rest rest))
    (or (not rest)
        (and (< (car rest) a)
             (loop (car rest) (cdr rest))))))
(defmacro (> a . rest)
  `(< ,.(reverse rest) ,a))

(def (<= a . rest)
  "Return `T` if the arguments are in non-decreasing order (previous
   one is less than or equal to the next one)."
  :doc-group compare
  (let loop ((a a) (rest rest))
    (or (not rest)
        (unless (or (< (car rest) a)
                    (nan? a))
          (loop (car rest) (cdr rest))))))

(def (>= a . rest)
  "Return `T` if the arguments are in non-increasing order (previous
   one is greater than or equal to the next one)."
  :doc-group compare
  (let loop ((a a) (rest rest))
    (or (not rest)
        (unless (or (< a (car rest))
                    (nan? a))
          (loop (car rest) (cdr rest))))))

(def (negative? x)
  "Return `T` if `x` is negative."
  :doc-group compare
  (< x 0))

(def (zero? x)
  "Return `T` if `x` is zero."
  :doc-group compare
  (= x 0))

(def (positive? x)
  "Return `T` if `x` is greater than zero."
  :doc-group compare
  (> x 0))

(def (even? x)
  (= (logand x 1) 0))

(def (odd? x)
  (not (even? x)))

(def (identity x)
  "Return `x`."
  x)

(def (1+ n)
  "Equivalent to `(+ n 1)`."
  (+ n 1))

(def (1- n)
  "Equivalent to `(- n 1)`."
  (- n 1))

(def (div x y)
  (+ (div0 x y)
     (or (and (< x 0)
              (or (and (< y 0) 1)
                  -1))
         0)))

(def (mod0 x y)
  (- x (* (div0 x y) y)))

(def (mod x y)
  (- x (* (div x y) y)))

(def (random n)
  (if (int? n)
      (mod (rand) n)
      (* (rand-double) n)))

(def (abs x)
  (if (< x 0)
      (- x)
      x))

(def (max x0 . xs)
  (if xs
      (foldl (λ (a b) (if (< a b) b a))
             x0
             xs)
      x0))

(def (min x0 . xs)
  (if xs
      (foldl (λ (a b) (if (< a b) a b))
             x0
             xs)
      x0))

(def (rune? x)
  (eq? (type-of x) 'rune))

(def (arr? x)
  (or (vec? x)
      (let ((tx (type-of x)))
        (and (cons? tx) (eq? (car tx) 'arr)))))

(def (closure? x)
  (and (fn? x)
       (not (builtin? x))))

(def (caar x) (car (car x)))
(def (cdar x) (cdr (car x)))
(def (cddr x) (cdr (cdr x)))
(def (caaar x) (car (car (car x))))
(def (caadr x) (car (car (cdr x))))
(def (cadar x) (car (cdr (car x))))
(def (caddr x) (car (cdr (cdr x))))
(def (cdaar x) (cdr (car (car x))))
(def (cdadr x) (cdr (car (cdr x))))
(def (cddar x) (cdr (cdr (car x))))
(def (cdddr x) (cdr (cdr (cdr x))))
(def (caaaar x) (car (car (car (car x)))))
(def (caaadr x) (car (car (car (cdr x)))))
(def (caadar x) (car (car (cdr (car x)))))
(def (caaddr x) (car (car (cdr (cdr x)))))
(def (cadaar x) (car (cdr (car (car x)))))
(def (cadadr x) (car (cdr (car (cdr x)))))
(def (caddar x) (car (cdr (cdr (car x)))))
(def (cadddr x) (car (cdr (cdr (cdr x)))))
(def (cdaaar x) (cdr (car (car (car x)))))
(def (cdaadr x) (cdr (car (car (cdr x)))))
(def (cdadar x) (cdr (car (cdr (car x)))))
(def (cdaddr x) (cdr (car (cdr (cdr x)))))
(def (cddaar x) (cdr (cdr (car (car x)))))
(def (cddadr x) (cdr (cdr (car (cdr x)))))
(def (cdddar x) (cdr (cdr (cdr (car x)))))
(def (cddddr x) (cdr (cdr (cdr (cdr x)))))

(let ((*values* (list '*values*)))
  (set! values
        (λ vs
          (if (and (cons? vs) (not (cdr vs)))
              (car vs)
              (cons *values* vs))))
  (set! call-with-values
        (λ (producer consumer)
          (let ((res (producer)))
            (if (and (cons? res) (eq? *values* (car res)))
                (apply consumer (cdr res))
                (consumer res))))))

;;; list utilities

(def (every pred lst)
  (or (atom? lst)
      (and (pred (car lst))
           (every pred (cdr lst)))))

(def (any pred lst)
  (and (cons? lst)
       (or (pred (car lst))
           (any pred (cdr lst)))))

(def (list? a)
  "Return `T` if the value is either `NIL` or a cons cell, `NIL`
   otherwise."
  (or (not a) (cons? a)))

(def (proper-list? a)
  "Return `T` is the value is a proper list.  That is, a non-circular
   list with the last element being `NIL`, as opposed to a dotted list.

   Examples:

       (proper-list? NIL)     → T
       (proper-list? '(1))    → T
       (proper-list? '(1 . 2) → NIL
       (def l '(1))
       (set-cdr! l l)         → #0=(1 . #0#)
       (length l)             → +inf.0
       (proper-list? l)       → NIL"
  (def (proper? a b)
    (let* {[a (cdr a)]
           [b (cdr b)]
           [b (if (cons? b) (cdr b) b)]}
      (if (and (cons? a) (cons? b) (not (eq? a b)))
          (proper? a b)
          (and (or (not a) (cons? a)) (not b)))))
  (or (not a) (and (cons? a) (proper? a a))))

(def (list-tail lst n)
  (if (<= n 0)
      lst
      (list-tail (cdr lst) (- n 1))))

(def (list-ref lst n)
  (car (list-tail lst n)))

(doc-group list
  "Working with lists.")

(def (length= seq n)
  "Perform a bounded length test.

   Use this instead of `(= (length seq) n)`, since it avoids unnecessary
   work and always terminates."
  :doc-group list
  (cond ((< n 0)     NIL)
        ((cons? seq) (length= (cdr seq) (- n 1)))
        (else        (= (length seq) n))))

(def (length> seq n)
  (cond ((< n 0)     T)
        ((cons? seq) (length> (cdr seq) (- n 1)))
        (else        (> (length seq) n))))

(def (append . lists)
  (def (copy- last l)
    (if (not l)
        last
        (let {[next (cons (car l) NIL)]}
          (set-cdr! last next)
          (copy- next (cdr l)))))
  (def (append- last lists)
    (unless (cdr lists)
            (set-cdr! last (car lists))
            (return))
    (append- (copy- last (car lists)) (cdr lists)))
  (let {[fst (cons NIL NIL)]}
    (append- fst lists)
    (cdr fst)))

(def (copy-list l (n NIL))
  (def (copy- last l n)
    (and n (= n 0) (return))
    (unless l (return))
    (let {[next (cons (car l) NIL)]}
      (set-cdr! last next)
      (copy- next (cdr l) (and n (1- n)))))
  (let {[fst (cons NIL NIL)]}
    (copy- fst l n)
    (cdr fst)))

(def (subseq seq start (end NIL))
  (def strlen (and (str? seq) (str-length seq)))
  (def (length>? seq n)
    (if strlen (> strlen n) (length> seq n)))
  (unless (length>? seq (1- start)) (bounds-error "start" start))
  (unless (<= start end) (bounds-error "start <= end" (list start end)))
  (and end (not (length>? seq (1- end))) (bounds-error "end" end))
  (def (subseq-l seq n)
    (if (= n 0)
        (copy-list seq (and end (- end start)))
        (subseq-l (cdr seq) (1- n))))
  (def (subseq-av alloc)
    (let* {[end (or end (length seq))]
           [av (alloc (- end start))]}
      (for start (1- end)
        (λ (i) (aset! av (- i start) (aref seq i))))
      av))
  (cond ((cons? seq) (subseq-l seq start))
        ((vec? seq) (subseq-av vec-alloc))
        ((str? seq) (if end (str-sub seq start end) (str-sub seq start)))
        ((arr? seq) (let {[atype (cadr (type-of seq))]}
                      (subseq-av (λ (n) (arr-alloc atype n 0)))))))

(def (last-pair l)
  (if (atom? (cdr l))
      l
      (last-pair (cdr l))))

(def (lastcdr l)
  (if (atom? l)
      l
      (cdr (last-pair l))))

(def (to-proper l)
  (cond ((not l) l)
        ((atom? l) (list l))
        (else (cons (car l) (to-proper (cdr l))))))

(def (map! f lst)
  (prog1 lst
         (while (cons? lst)
           (set-car! lst (f (car lst)))
           (set! lst (cdr lst)))))

(def (filter pred lst)
  (def (filter- f lst acc)
    (cdr
     (prog1 acc
       (while (cons? lst)
              (when (pred (car lst))
                (set! acc
                      (cdr (set-cdr! acc (cons (car lst) NIL)))))
              (set! lst (cdr lst))))))
  (filter- pred lst (list NIL)))

(def (partition pred lst)
  (def (partition- pred lst yes no)
    (let ((vals
           (prog1
            (cons yes no)
            (while (cons? lst)
              (if (pred (car lst))
                  (set! yes (cdr (set-cdr! yes (cons (car lst) NIL))))
                  (set! no  (cdr (set-cdr! no  (cons (car lst) NIL)))))
              (set! lst (cdr lst))))))
      (values (cdr (car vals)) (cdr (cdr vals)))))
  (partition- pred lst (list NIL) (list NIL)))

(def (count f l)
  (def (count- f l n)
    (if (not l)
        n
        (count- f (cdr l) (if (f (car l))
                              (+ n 1)
                              n))))
  (count- f l 0))

(def (nestlist f zero n)
  (and (> n 0)
       (cons zero (nestlist f (f zero) (- n 1)))))

(def (foldr f zero lst)
  (if (not lst)
      zero
      (f (car lst) (foldr f zero (cdr lst)))))

(def (foldl f zero lst)
  (if (not lst)
      zero
      (foldl f (f (car lst) zero) (cdr lst))))

(def (reverse- zero lst)
  (if (not lst)
      zero
      (reverse- (cons (car lst) zero) (cdr lst))))

(def (reverse lst)
  (reverse- NIL lst))

(def (reverse!- prev l)
  (while (cons? l)
    (set! l (prog1 (cdr l)
                   (set-cdr! l (prog1 prev
                                      (set! prev l))))))
  prev)

(def (reverse! l)
  (reverse!- NIL l))

(def (copy-tree l)
  (if (atom? l)
      l
      (cons (copy-tree (car l))
            (copy-tree (cdr l)))))

(def (delete-duplicates lst)
  (if (length> lst 20)
      (let ((ta (table)))
        (let loop ((l lst) (acc NIL))
          (if (atom? l)
              (reverse! acc)
              (if (has? ta (car l))
                  (loop (cdr l) acc)
                  (begin
                    (put! ta (car l) T)
                    (loop (cdr l) (cons (car l) acc)))))))
      (if (atom? lst)
          lst
          (let ((elt  (car lst))
                (tail (cdr lst)))
            (if (member elt tail)
                (delete-duplicates tail)
                (cons elt
                      (delete-duplicates tail)))))))

(def (find-if p lst (:key identity)
                    (:start 0)
                    (:end NIL)
                    (:from-end NIL))
  (def (find-if- lst)
    (if (or (not lst) (p (key (car lst))))
        (car lst)
        (find-if- (cdr lst))))
  (set! lst (subseq lst start end))
  (when from-end (set! lst (reverse! lst)))
  (find-if- lst))

(def (find e lst (:key identity)
                 (:test equal?)
                 (:start 0)
                 (:end NIL)
                 (:from-end NIL))
  (find-if (λ (x) (test e x))
           lst
           :key key
           :start start
           :end end
           :from-end from-end))

; you are not expected to understand this -- spew

(def (zip-with f . lst)
  (apply map f lst))

(def (zip . lst)
  (apply map list lst))

;;; backquote

(def (revappend l1 l2)
  (reverse-  l2 l1))

(def (nreconc l1 l2)
  (reverse!- l2 l1))

(def (self-evaluating? x)
  (and (not (gensym? x))
       (or (and (atom? x)
                (not (sym? x)))
           (and (const? x)
                (sym? x)
                (eq? x (top-level-value x))))))

(defmacro (quasiquote x) (bq-process x 0))

(def (splice-form? x)
  (or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
                         (eq? (car x) 'unquote-nsplicing)
                         (and (eq? (car x) 'unquote)
                              (length> x 2))))
      (eq? x 'unquote)))

;; bracket without splicing
(def (bq-bracket1 x d)
  (if (and (cons? x) (eq? (car x) 'unquote))
      (if (= d 0)
          (cadr x)
          (list cons ''unquote
                (bq-process (cdr x) (- d 1))))
      (bq-process x d)))

(def (bq-bracket x d)
  (cond ((atom? x)  (list list (bq-process x d)))
        ((eq? (car x) 'unquote)
         (if (= d 0)
             (cons list (cdr x))
             (list list (list cons ''unquote
                              (bq-process (cdr x) (- d 1))))))
        ((eq? (car x) 'unquote-splicing)
         (if (= d 0)
             (list 'copy-list (cadr x))
             (list list (list list ''unquote-splicing
                              (bq-process (cadr x) (- d 1))))))
        ((eq? (car x) 'unquote-nsplicing)
         (if (= d 0)
             (cadr x)
             (list list (list list ''unquote-nsplicing
                              (bq-process (cadr x) (- d 1))))))
        (else  (list list (bq-process x d)))))

(def (bq-process x d)
  (cond ((sym? x)  (list 'quote x))
        ((vec? x)
         (let ((body (bq-process (vec->list x) d)))
           (if (eq? (car body) list)
               (cons vec (cdr body))
               (list apply vec body))))
        ((atom? x)  x)
        ((eq? (car x) 'quasiquote)
         (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
        ((eq? (car x) 'unquote)
         (if (and (= d 0) (length= x 2))
             (cadr x)
             (list cons ''unquote (bq-process (cdr x) (- d 1)))))
        ((not (any splice-form? x))
         (let ((lc    (lastcdr x))
               (forms (map (λ (x) (bq-bracket1 x d)) x)))
           (if (not lc)
               (cons list forms)
               (if (not (cdr forms))
                   (list cons (car forms) (bq-process lc d))
                   (nconc (cons list* forms) (list (bq-process lc d)))))))
        (else
         (let loop ((p x) (q NIL))
           (cond ((not p) ;; proper list
                  (cons 'nconc (reverse! q)))
                 ((cons? p)
                  (cond ((eq? (car p) 'unquote)
                         ;; (... . ,x)
                         (cons 'nconc
                               (nreconc q
                                        (if (= d 0)
                                            (cdr p)
                                            (list (list list ''unquote)
                                                  (bq-process (cdr p)
                                                               (- d 1)))))))
                        (else
                         (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
                 (else
                  ;; (... . x)
                  (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))

;;; standard macros

(def (quote-value v)
  (if (self-evaluating? v)
      v
      (list 'quote v)))

(defmacro (let* binds . body)
  (if (atom? binds)
      `((λ () ,@body))
      `((λ (,(caar binds))
          ,@(if (cons? (cdr binds))
                `((let* ,(cdr binds) ,@body))
                body))
        ,(cadar binds))))

(defmacro (when c . body)
  (list 'if c (cons 'begin body) NIL))

(defmacro (unless c . body)
  (list 'if c NIL (cons 'begin body)))

(defmacro (case key . clauses)
  (def (vals->cond key v)
    (cond ((eq? v 'else)   'else)
          ((not v)         NIL)
          ((sym? v)        `(eq?  ,key ,(quote-value v)))
          ((atom? v)       `(eqv? ,key ,(quote-value v)))
          ((not (cdr v))   `(eqv? ,key ,(quote-value (car v))))
          ((every sym? v)
                           `(memq ,key ',v))
          (else            `(memv ,key ',v))))
  (let ((g (gensym)))
    `(let ((,g ,key))
       (cond ,.(map (λ (clause)
                      (cons (vals->cond g (car clause))
                            (cdr clause)))
                    clauses)))))

(defmacro (do vars test-spec . commands)
  (let ((test-expr (car test-spec))
        (vars  (map car  vars))
        (inits (map cadr vars))
        (steps (map (λ (x)
                      (if (cons? (cddr x))
                          (caddr x)
                          (car x)))
                    vars)))
    `(letrec ((loop# (λ ,vars
                       (if ,test-expr
                           (begin
                             ,@(cdr test-spec))
                           (begin
                             ,@commands
                             (loop# ,.steps))))))
       (loop# ,.inits))))

; SRFI 8
(defmacro (receive formals expr . body)
  `(call-with-values (λ () ,expr)
     (λ ,formals ,@body)))

(defmacro (dotimes var . body)
  (let ((v (car var))
        (cnt (cadr var)))
    `(for 0 (- ,cnt 1)
          (λ (,v) ,@body))))

(def (map-int f n)
  (and (> n 0)
       (let ((first (cons (f 0) NIL))
             (acc NIL))
         (set! acc first)
         (for 1 (1- n)
              (λ (i) (set-cdr! acc (cons (f i) NIL))
                     (set! acc (cdr acc))))
         first)))

(def (iota n)
  (map-int identity n))

(defmacro (with-bindings binds . body)
  (let ((vars (map car binds))
        (vals (map cadr binds))
        (olds (map (λ (x) (gensym)) binds)))
    `(let ,(map list olds vars)
       ,@(map (λ (v val) `(set! ,v ,val)) vars vals)
       (unwind-protect
        (begin ,@body)
        (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))

;;; exceptions

(def (error . args)
  (raise (cons 'error args)))

(def (arg-error . args)
  (raise (cons 'arg-error args)))

(def (type-error . args)
  (raise (cons 'type-error args)))

(def (bounds-error . args)
  (raise (cons 'bounds-error args)))

(defmacro (throw tag value)
  `(raise (list 'thrown-value ,tag ,value)))

(defmacro (catch tag expr)
  `(trycatch ,expr
             (λ (e#) (if (and (cons? e#)
                              (eq? (car  e#) 'thrown-value)
                              (eq? (cadr e#) ,tag))
                         (caddr e#)
                         (raise e#)))))

(defmacro (unwind-protect expr finally)
  `(let ((thk# (λ () ,finally)))
     (prog1 (trycatch ,expr
                      (λ (e#) (thk#) (raise e#)))
            (thk#))))

;;; debugging utilities

(defmacro (assert expr)
  `(if ,expr T (raise '(assert-failed ,expr))))

(defmacro (assert-fail expr . what)
  `(assert (trycatch (begin ,expr NIL)
                     (λ (e) ,(if what
                                 `(eq? (car e) ',(car what))
                                 T)))))

(def traced?
  (let ((sample-traced-lambda (λ args (write (cons 'x args))
                                      (newline)
                                      (apply #.apply args))))
    (λ (f)
      (and (closure? f)
           (equal? (fn-code f)
                   (fn-code sample-traced-lambda))))))

(def (trace symbol)
  (let ((func (top-level-value symbol)))
    (when (not (traced? func))
      (set-top-level-value! symbol
                            (eval
                              `(λ args#
                                  (write (cons ',symbol args#))
                                  (newline)
                                  (apply ',func args#))))))
  (void))

(def (untrace symbol)
  (let ((func (top-level-value symbol)))
    (when (traced? func)
      (set-top-level-value! symbol
                            (aref (fn-vals func) 3))))
  (void))

(defmacro (time expr)
  `(let ((t0# (time-now)))
     (prog1
      ,expr
      (princ "Elapsed time: " (- (time-now) t0#) " seconds" *linefeed*))))

;;; text I/O

(def (print . args)
  (for-each write args))

(def (princ . args)
  (with-bindings ((*print-readably* NIL))
                 (for-each write args)))

(def (newline (io *io-out*))
  (io-write io *linefeed*)
  (void))

(def (io-readline s) (io-readuntil s #\linefeed))

; call f on an io until the io runs out of data
(def (read-all-of f s)
  (let loop ((lines NIL)
             (curr  (f s)))
    (if (io-eof? s)
        (reverse! lines)
        (loop (cons curr lines) (f s)))))

(def (io-readlines s)
  (read-all-of io-readline s))

(def (read-all s)
  (read-all-of read s))

(def (io-readall s)
  (let ((b (buffer)))
    (io-copy b s)
    (io->str b)))

(defmacro (with-output-to io . body)
  `(with-bindings ((*io-out* ,io))
                  ,@body))

(defmacro (with-input-from io . body)
  `(with-bindings ((*io-in* ,io))
                  ,@body))

;;; vector functions

(def (list->vec l)
  (map 'vec identity l))

(def (vec->list v)
  (map 'list identity v))

;;; table functions

(def (table-pairs ta)
  (table-foldl (λ (k v z) (cons (cons k v) z))
               NIL ta))

(def (table-keys ta)
  (table-foldl (λ (k v z) (cons k z))
               NIL ta))

(def (table-values ta)
  (table-foldl (λ (k v z) (cons v z))
               NIL ta))

(def (table-clone ta)
  (let ((nt (table)))
    (table-foldl (λ (k v z) (put! nt k v))
                 NIL ta)
    nt))

(def (table-invert ta)
  (let ((nt (table)))
    (table-foldl (λ (k v z) (put! nt v k))
                 NIL ta)
    nt))

;;; string functions

(def (str-tail s n)
  (str-sub s n))

(def (str-trim s at-start at-end)
  (def (trim-start s runes i L)
    (if (and (< i L) (str-find runes (str-rune s i)))
        (trim-start s runes (1+ i) L)
        i))
  (def (trim-end s runes i)
    (if (and (> i 0) (str-find runes (str-rune s (1- i))))
        (trim-end s runes (1- i))
        i))
  (let ((L (str-length s)))
    (str-sub s
                (trim-start s at-start 0 L)
                (trim-end   s at-end   L))))

(def (str-map f s)
  (let ((b (buffer))
        (n (str-length s)))
    (let ((i 0))
      (while (< i n)
         (io-putrune b (f (str-rune s i)))
         (set! i (1+ i))))
    (io->str b)))

(def (str-rep s k)
  (cond ((< k 4)
         (cond ((<= k 0) "")
               ((=  k 1) (str s))
               ((=  k 2) (str s s))
               (else     (str s s s))))
        ((odd? k) (str s (str-rep s (- k 1))))
        (else     (str-rep (str s s) (/ k 2)))))

(def (str-lpad s n c)
  (str (str-rep c (- n (str-length s))) s))

(def (str-rpad s n c)
  (str s (str-rep c (- n (str-length s)))))

(def (print-to-str . args)
  (let ((b (buffer)))
    (for-each (λ (a) (write a b)) args)
    (io->str b)))

(def (str-join strlist sep)
  (if (not strlist)
      ""
      (let ((b (buffer)))
        (io-write b (car strlist))
        (for-each (λ (s) (io-write b sep)
                         (io-write b s))
                  (cdr strlist))
        (io->str b))))

;;; structs

(def (S struct . rest)
  (let ((constructor (getprop struct 'constructor)))
    (if constructor
        (apply constructor rest)
        (error "no default constructor for struct: " struct))))

(defmacro (defstruct . rest)
  (let* {[docs+rest (separate-doc-from-body (cdr rest))]
         [docs (car docs+rest)]
         [def (cdr docs+rest)]
         [name (car rest)]}
  (def (fmt doc)
    (let* {[cut (str-find doc "\n\n")]
           [hd (if cut (str-sub doc 0 cut) doc)]
           [tl (if cut (str-sub doc cut) "")]
           [def (str-split (print-to-str (list* 'defstruct name def)) "\n")]}
      (str hd
           "\n\n    "
           (str-join def "\n    ")
           tl)))
  (when docs
    (sym-set-doc name (append docs (list (cons :doc-fmt fmt)))))
  `(%defstruct% ,name ,@def)))

(defmacro (%defstruct% name
                       (:type 'vec)
                       (:named T named-supplied)
                       (:constructor T constructor-supplied)
                       (:conc-name T conc-name-supplied)
                       (:predicate T predicate-supplied)
                       . slots)
  (def (slot-opts slot)
    ; transform slot description to slot options assoc list
    ; eg: (a NIL :read-only T) → ((:read-only . T))
    (when (atom? slot)
      (return NIL))
    (let {[valid-keys '(:read-only)]
          [opts (apply assoc-list (cddr slot))]}
      (for-each (λ (opt) (unless (member (car opt) valid-keys)
                           (error (str "invalid option in slot " (car slot)
                                       " of struct " name
                                       ": " opt))))
                opts)
      opts))
  (def (tokw slots)
    ; transform slots descriptions to keyworded arguments
    ; eg: (a (b 1) (c NIL :read-only T)) → ((:a NIL) (:b 1) (:c NIL))
    (map (λ (slot) (let* {[name-cons (and (cons? slot)
                                          (car slot))]
                          [name (or name-cons slot)]
                          [tail (or (and name-cons
                                         (cdr slot))
                                (list NIL))]}
                     (when (or (not (sym? name))
                               (keyword? name))
                       (error "invalid slot name: " name))
                     (list (sym #\: name)
                           (if (cons? tail)
                               (car tail)
                               NIL))))
         slots))
  (let* {[num-slots (length slots)]
         ; list of slot names
         [slots-car (map (λ (f) (if (cons? f) (car f) f))
                         slots)]
         ; slots, but with default values added (if not set)
         ; and keywords for names
         [slots-kw (tokw slots)]
         ; slot options
         [slots-opts (map slot-opts slots)]
         ; underlying type, either vector or list
         [isvec (if (eq? type 'vec)
                    T
                    (unless (eq? type 'list)
                      (arg-error "invalid struct type: " type)))]
         ; should the struct name appear as the first element?
         [named (and (if isvec
                         (or named (arg-error "structs of type `vec` are always :named T"))
                         (and named named-supplied))
                     (list name))]
         ; struct's predicate name
         [predicate (or (and (eq? predicate T)
                             (sym name #\?))
                        predicate)]
         [is? (and predicate
                   (if named
                       predicate
                       (when predicate-supplied
                         (arg-error "predicate not possible unless the struct is :named T"))))]
         ; what (type-of ...) should return if predicate is defined
         [type-of-value (if isvec
                            (list 'struct name)
                            (list name '…))]
         ; constructor name and arguments
         [constructor-default? (eq? constructor T)]
         [constructor
           (and constructor ; NIL means none to make at all
                (or (and (atom? constructor) ; a single argument
                         (cons (or (and (eq? constructor T) ; T means the defaults
                                        (sym "make-" name))
                                   constructor) ; else a custom name
                               slots-kw))
                    constructor))] ; anything else means custom name and args
         ; accessor prefix
         [access (or (and (eq? conc-name T)
                          (str name "-"))
                     conc-name)]}
    (def (make-constructor args)
      `(λ ,args
         ,(if isvec
             `(,type '%struct%
                     ',name
                     ,@(foldr (λ (s z) (cons (sym ":" s) (cons s z)))
                              NIL
                              slots-car))
             (if named `(list ',@named ,@slots-car)
                       `(list          ,@slots-car)))))
   `(begin
      ; predicate
      ,(when is?
         `(def (,is? s)
            ,(if isvec
                 `(equal? (type-of s) ',type-of-value)
                 `(and [eq? (aref s 0) ',name]
                       [= (length s) ,(1+ num-slots)]))))
      ; constructor
      ,(when constructor
         `(def ,(car constructor) ,(make-constructor (cdr constructor))))

      ; default constructor
      ,(when isvec
         `(putprop ',name
                   'constructor
                   ,(if constructor-default?
                        (car constructor)
                        (make-constructor slots-kw))))

      ; accessor per slot
      ,@(map-int (λ (i) [let* {[opts (list-ref slots-opts i)]
                               [fld (list-ref slots-car i)]
                               [fun (if access (sym access fld) fld)]
                               [iv (if isvec (+ (* 2 i) 1) i)]}
                          `(def (,fun s (v NIL v-supplied?))
                             ,(when is?
                                `(unless (,is? s)
                                   (type-error ',type-of-value s)))
                             (if (not v-supplied?)
                                 (aref s ,[+ (if named 1 0) iv])
                                 ,(if (assv :read-only opts)
                                      `(error (str "slot " ',fld " in struct " ',name " is :read-only"))
                                      `(aset! s ,[+ (if named 1 0) iv] v))))])
                 num-slots))))

;;; toplevel

(def (macrocall? e)
  (and (sym? (car e))
       (get-syntax (car e))))

(def (macroexpand-1 e)
  (if (atom? e)
      e
      (let ((f (macrocall? e)))
        (if f
            (apply f (cdr e))
            e))))

(def (macroexpand e)
  ; symbol resolves to toplevel; i.e. has no shadowing definition
  (def (top? s env) (not (or (bound? s) (assq s env))))

  (def (splice-begin body)
    (cond ((atom? body) body)
          ((equal? body '((begin)))
           body)
          ((and (cons? (car body))
                (eq? (caar body) 'begin))
           (append (splice-begin (cdar body)) (splice-begin (cdr body))))
          (else
           (cons (car body) (splice-begin (cdr body))))))

  (def *expanded* (list '*expanded*))

  (def (expand-body body env)
    (if (atom? body)
        body
        (let* ((body  (if (top? 'begin env)
                          (splice-begin body)
                          body))
               (def?  (top? 'def env))
               (dvars (and def? (get-defined-vars body)))
               (env   (nconc (map list dvars) env)))
          (if (not def?)
              (map (λ (x) (expand-in x env)) body)
              (let* ((ex-nondefs    ; expand non-definitions
                      (let loop ((body body))
                        (cond ((atom? body) body)
                              ((and (cons? (car body))
                                    (eq? 'def (caar body)))
                               (cons (car body) (loop (cdr body))))
                              (else
                               (let ((form (expand-in (car body) env)))
                                 (set! env (nconc
                                            (map list (get-defined-vars form))
                                            env))
                                 (cons
                                  (cons *expanded* form)
                                  (loop (cdr body))))))))
                     (body ex-nondefs))
                (while (cons? body) ; now expand deferred definitions
                       (if (not (eq? *expanded* (caar body)))
                           (set-car! body (expand-in (car body) env))
                           (set-car! body (cdar body)))
                       (set! body (cdr body)))
                ex-nondefs)))))

  (def (expand-lambda-list l env)
    (if (atom? l)
        l
        (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
                  (cons (caar l)
                        (cons (expand-in (cadar l) env)
                              (cddar l)))
                  (car l))
              (expand-lambda-list (cdr l) env))))

  (def (l-vars l)
    (cond ((atom? l)       (list l))
          ((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
          (else            (cons (car l)  (l-vars (cdr l))))))

  (def (expand-lambda e env)
    (let ((formals (cadr e))
          (name    (lastcdr e))
          (body    (cddr e))
          (vars    (l-vars (cadr e))))
      (let ((env   (nconc (map list vars) env)))
        `(λ ,(expand-lambda-list formals env)
           ,.(expand-body body env)
           . ,name))))

  (def (expand-define e env)
    (if (or (not (cdr e)) (atom? (cadr e)))
        (if (not (cddr e))
            e
            (let* ((name     (cadr e))
                   (doc+body (separate-doc-from-body (cddr e)))
                   (doc      (car doc+body))
                   (body     (cdr doc+body)))
              (when doc
                (sym-set-doc name doc))
              `(def ,name ,(expand-in (car body) env))))
        (let* ((formals  (cdadr e))
               (name     (caadr e))
               (doc+body (separate-doc-from-body (cddr e)))
               (doc      (car doc+body))
               (body     (cdr doc+body))
               (vars     (l-vars formals))
               (menv     (nconc (map list vars) env)))
          (when doc
            (sym-set-doc name doc formals))
          `(def ,(cons name (expand-lambda-list formals menv))
             ,.(expand-body body menv)))))

  (def (expand-let-syntax e env)
    (let ((binds (cadr e)))
      (cons 'begin
            (expand-body (cddr e)
                         (nconc
                          (map (λ (bind)
                                 (list (car bind)
                                       ((compile-thunk
                                         (expand-in (cadr bind) env)))
                                       env))
                               binds)
                          env)))))

  ; given let-syntax definition environment (menv) and environment
  ; at the point of the macro use (lenv), return the environment to
  ; expand the macro use in. TODO
  (def (local-expansion-env menv lenv) menv)

  (def (expand-in e env)
    (if (atom? e)
        e
        (let* ((head (car e))
               (bnd  (assq head env))
               (default (λ ()
                          (let loop ((e e))
                            (if (atom? e)
                                e
                                (cons (if (atom? (car e))
                                          (car e)
                                          (expand-in (car e) env))
                                      (loop (cdr e))))))))
          (cond ((and bnd (cons? (cdr bnd)))  ; local macro
                 (expand-in (apply (cadr bnd) (cdr e))
                            (local-expansion-env (caddr bnd) env)))
                ((macrocall? e) => (λ (f)
                                     (expand-in (apply f (cdr e)) env)))
                ((or bnd                      ; bound lexical or toplevel var
                     (not (sym? head))
                     (bound? head))
                 (default))
                ((eq? head 'quote)      e)
                ((eq? head 'λ)          (expand-lambda e env))
                ((eq? head 'def)        (expand-define e env))
                ((eq? head 'let-syntax) (expand-let-syntax e env))
                (else                   (default))))))
  (expand-in e NIL))

(def (eval x)
  ((compile-thunk (macroexpand x))))

(def (load-process x)
  (eval x))

(def (load filename)
  (let ((F (file filename :read)))
    (trycatch
     (let next (prev E v)
       (if (not (io-eof? F))
           (next (read F)
                 prev
                 (begin (load-process E) (void)))
           (begin (io-close F)
                  ; evaluate last form in almost-tail position
                  (void (load-process E)))))
     (λ (e)
       (io-close F)
       (raise `(load-error ,e))))))

(def (repl)
  (*prompt*)
  (io-flush *io-out*)
  (def (prompt)
    (let ((v (trycatch (read *io-in* :whitespace T)
                       (λ (e) (io-discardbuffer *io-in*)
                              (raise e)))))
      (and (not (io-eof? *io-in*))
           (let ((V (load-process v)))
             (if (void? V)
                 (when (void? v)
                   (*prompt*)
                   (io-flush *io-out*))
                 (begin (print V)
                        (newline)))
             (void (set! that V))))))
  (def (reploop)
    (when (trycatch (prompt)
                    (λ (e)
                      (top-level-exception-handler e)
                      T))
          (reploop)))
  (reploop)
  (newline))

(def (top-level-exception-handler e)
  (with-output-to *stderr*
                  (print-exception e)
                  (print-stack-trace (stacktrace))))

(def (print-stack-trace st)
  (def (find-in-f f tgt path)
    (let ((path (cons (fn-name f) path)))
      (if (eq? (fn-code f)
               (fn-code tgt))
          (throw 'ffound path)
          (let ((v (fn-vals f)))
            (for 0 (1- (length v))
                 (λ (i) (when (closure? (aref v i))
                          (find-in-f (aref v i) tgt path))))))))
  (def (fname f e)
    (let ((p (catch 'ffound
                    (begin
                      (for-each (λ (topfun)
                                  (find-in-f topfun f NIL))
                                e)
                      NIL))))
      (if p
          (str-join (map str (reverse! p)) "/")
          (if (builtin? f) (fn-name f) "λ"))))
  (let ((e (filter closure? (map (λ (s) (and (bound? s)
                                             (top-level-value s)))
                                 (environment))))
        (n 0))
    (for-each
     (λ (f)
       (princ "(" (fname (aref f 1) e))
       (for 2 (1- (length f))
         (λ (i) (princ " ")
                (print (aref f i))))
       (princ ")" *linefeed*)
       (when (= n 0)
         (fn-disasm (aref f 1) (aref f 0)))
       (set! n (+ n 1)))
     (reverse! st))))

(def (print-exception e)
  (def (print-value v)
    (with-bindings ((*print-level* (or *exception-print-level*
                                       *print-level*))
                    (*print-length* (or *exception-print-length*
                                        *print-length)))
      (print v)))
  (let* {[loc (and (list? e)
                   (list? (car e))
                   (io? (caar e))
                   (car e))]
         [e (if loc (cdr e) e)]
         [k (and e (sym? (car e)) (car e))]
         [a (and k (cdr e))]}
    (when loc
      (princ (io-filename (car loc)) ":" (cadr loc) ":" (caddr loc) ": "))
    (cond ((eq? k 'type-error)
           (princ "type error: ")
           (unless (length= a 2)
             (princ (car a) ": ")
             (set! a (cdr a)))
           (for-each (λ (s) (princ s ": ")) (cddr a))
           (princ "expected " (car a) ", got " (type-of (cadr a)) ": ")
           (print-value (cadr a)))

          ((eq? k 'bounds-error)
           (princ "index " (cadr a) " out of bounds for ")
           (print-value (car a)))

          ((eq? k 'unbound-error)
           (princ "eval: variable " (car a) " has no value"))

          ((eq? k 'error)
           (princ "error: ")
           (apply princ a))

          ((eq? k 'load-error)
           (print-exception (car a))
           (return))

          ((eq? k 'parse-error)
           (princ "parsing error: ")
           (apply princ a))

          ((eq? k 'arg-error)
           (princ "arguments error: ")
           (apply princ a))

          ((eq? k 'key-error)
           (princ "key not found: " (car a)))

          ((eq? k 'const-error)
           (princ (if (keyword? (car a))
                      "keywords are read-only: "
                      "tried to modify a constant: "))
           (print (car a)))

          ((eq? k 'io-error)
           (princ "I/O error: ")
           (apply princ a))

          ((eq? k 'assert-failed)
           (princ "assertion failed: ")
           (apply princ a))

          ((or (eq? k 'divide-error)
               (eq? k 'memory-error))
           (apply princ a))

          (else (princ "*** Unhandled exception: ")
                (print e)))
    (newline)))

(def (sort l cmp (:key identity))
  (if (not (cdr l))
      l
      (let ((piv (car l)))
        (receive (less grtr)
                 (partition (λ (x) (cmp (key x) (key piv))) (cdr l))
                 (nconc (sort less cmp :key key)
                        (list piv)
                        (sort grtr cmp :key key))))))

(def (make-system-image fname)
  (let ((f (file fname :write :create :truncate))
        (excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
                    *print-pretty* *print-width* *print-readably*
                    *print-level* *print-length* *os-name* *interactive*
                    *prompt* *os-version* *exception-print-level*
                    *exception-print-length* ptr)))
    (with-bindings ((*print-pretty* T)
                    (*print-readably* T))
      (let* ((syms
              (filter (λ (s)
                        (and (bound? s)
                             (not (const? s))
                             (or (not (builtin? (top-level-value s)))
                                 (not (equal? (str s) ; alias of builtin
                                              (str (top-level-value s)))))
                             (not (memq s excludes))
                             (not (io? (top-level-value s)))))
                      (sort (environment) #.<)))
             (data (apply nconc (map list syms (map top-level-value syms)))))
        (write data f)
        (io-write f *linefeed*))
      (io-close f))))

; initialize globals that need to be set at load time
(def (__init_globals)
  (let ((defprompt (if (equal? *os-name* "macos")
                       (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
                       (λ () (princ "#;> ")))))
    (set! *prompt*
      "Function called by REPL to signal the user input is required.

       Default function prints `#;> `."
      defprompt))
  (set! *exception-print-level* 3)
  (set! *exception-print-length* 64)
  (set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
  (set! *linefeed* "\n")
  (set! *exit-hooks* NIL)
  (set! *io-out* *stdout*)
  (set! *io-in* *stdin*)
  (set! *io-err* *stderr*))

(def (__script fname)
  (trycatch (load fname)
            (λ (e) (top-level-exception-handler e)
                   (exit (str e)))))

(def (__rcscript)
  (let* ((homevar (case *os-name*
                    (("unknown") NIL)
                    (("plan9") "home")
                    (("macos") (princ "\x1b]0;StreetLISP v0.999\007") NIL)
                    (else "HOME")))
         (home (and homevar (os-getenv homevar)))
         (rcpath (case *os-name*
                   (("plan9") "lib/slrc")
                   (else ".slrc")))
         (fname (and home (str home *directory-separator* rcpath))))
    (and fname (path-exists? fname) (load fname))))

(def (__start argv interactive)
  (__init_globals)
  (set! *argv* argv)
  (set! *interactive* interactive)
  (if (cons? (cdr argv))
      (begin (set! *argv* (cdr argv))
             (__script (cadr argv)))
      (set! *interactive* T))
  (when *interactive*
    (__rcscript)
    (repl))
  (exit))

(def (add-exit-hook fun)
  "Puts an one-argument function on top of the list of exit hooks.

   On shutdown each exit hook is called with the exit status as a single
   argument, which is (usually) `NIL` on success and a string describing
   an error otherwise."
  (set! *exit-hooks* (cons fun *exit-hooks*))
  (void))

(def (__finish status)
  "A function called right before exit by the VM."
  (when (bound? '*exit-hooks*)
    (for-each (λ (f) (f status)) *exit-hooks*)))