;;;; 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."
  :doc-group misc
  :doc-see void?
  #.(void))

(def (void? v)
  "Return `T` if `v` is `#<void>`, `NIL` otherwise."
  :doc-group type
  :doc-group misc
  :doc-see void
  (eq? v #.(void)))

;;; syntax environment

(unless (bound? '*syntax-environment*)
  (def *syntax-environment*
    "Table containing macro definitions.

     The keys are macro names, the values are their application functions."
    :doc-group syntax
    :doc-see get-syntax
    :doc-see set-syntax!
    (table)))

(def (set-syntax! sym fn)
  "Associate a macro name with its application function."
  :doc-group syntax
  :doc-see get-syntax
  (put! *syntax-environment* sym fn))

(def (get-syntax sym)
  "Return a macro application function based on its name, or `NIL` if
   it's not defined."
  :doc-group syntax
  :doc-see set-syntax!
  (get *syntax-environment* sym NIL))

;;; 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 def-supplied?))
  "Return a property value associated with the symbol or `def` if
   missing.

   If the default value is not supplied and the property is missing,
   an exception will be thrown."
  :doc-group prop
  :doc-see putprop
  (let ((kt (get *properties* key NIL)))
    (if def-supplied?
        (or (and kt (get kt symbol def)) def)
        (if kt
            (get kt symbol)
            (raise (list 'key-error key))))))

(def (remprop symbol key)
  "Remove a property value associated with the symbol."
  :doc-group prop
  (void (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)
    (<= :doc-a kw :doc-z))
  (let {[hd (car body)]
        [tl (cdr body)]}
    (cond [(and (str? hd) (not doc) tl)
           (separate-doc-from-body tl (cons hd doc))]
          [(and doc (doc? 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 (> (length s) 0)
                                   (rune-whitespace? (str-rune s 0))
                                   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)
      (putprop symbol
               '*formals-list*
               (delete-duplicates [append (getprop symbol '*formals-list* NIL)
                                          formals-list])))
    #.(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
  (def (print-type e)
    (set! print-type void)
    (princ " ;; ["
           [cond
             ((not (sym? e)) (type-of e))
             ((and (sym? e) (bound? e)) (type-of (top-level-value term)))
             ((get-syntax e) "macro")
             (else "any")]
           "]"))
  (if sigs
      (for-each (λ (sig) (princ lpad)
                         (print (cons term sig))
                         (print-type term)
                         (newline))
                sigs)
      (princ lpad)
      (if kind
          (begin (princ (caddr term))
                 (print-type "doc group"))
          (print term)
          (print-type term))
      (newline))
  (newline))

(defmacro (help topic (:print-header help-print-header) . rest)
  "Display documentation for a specific term or group of terms, if
   available.

   An optional symbol `group` is used to query for documentation on a
   group instead of a single term.  All available documentation groups
   can be displayed with `(help groups)`.

   Asterisk can be added to the beginning and/or end of the term in order
   to list the matching terms defined in the current environment.  This
   can be useful to recall a function's name.

   Examples:

       (help str?)       ; show documentation for str?
       (help groups)     ; show documentation groups
       (help type group) ; list items for dealing with types
       (help group type) ; same as ^
       (help str->*)     ; find functions converting from strings
       (help *->str)     ; find functions converting to strings
       (help *num*)      ; find anything related to numbers"
  :doc-group doc
  (let* {[term (if (eq? topic 'group) (car rest) topic)]
         [kind (if (eq? topic term) (car rest) topic)]
         [doc-extra-term (and kind (cons (sym ":doc-" kind) term))]
         [docterm (if kind (list 'doc kind term) term)]
         [doc (getprop docterm '*doc* NIL)]
         [formals-list (getprop docterm '*formals-list* NIL)]
         [term-bound (and (sym? term) (bound? term))]}
    (def (environment-find-matching)
      (let* {[s (str term)]
             [ts (eq? 0 (str-find s "*"))] ; starts with
             [s (or (and ts (str-sub s 1)) s)]
             [ei (1- (length s))]
             [te (eq? (str-find s "*") ei)]
             [s (or (and te (str-sub s 0 ei)) s)]
             [slen (length s)]
             [matches? (λ (term) (let* {[name (str term)]
                                        [i (str-find name s)]
                                        [nlen (and i (length name))]}
                                   (and i
                                        (or ts (= 0 i))
                                        (or te (= nlen (+ i slen))))))]
             [matching (nconc (filter matches? (environment))
                              (filter matches? (table-keys *syntax-environment*)))]}
        (when matching
          (for-each (λ (term) (princ term) (newline))
                    (sort matching <)))))
    (def (print-sig term sigs lpad)
      (if sigs
          (for-each (λ (sig) (newline)
                             (princ lpad)
                             (princ (cons term sig)))
                    sigs)
          (newline)
          (princ lpad)
          (princ term)))
    (def (first-line s)
      (str-sub s 0 (str-find s "\n")))
    (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* NIL))))
    (def (table-keys-filter-sort tbl pred)
      (sort (table-fold (λ (k _ z) (if (pred k) (cons k z) z)) NIL tbl) <))
    (if (eq? term 'groups)
        (for-each (λ (k) (princ (str-rpad (str (caddr k)) 10)
                                (first-line (getprop k '*doc* NIL)))
                         (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* NIL)]
                          [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* NIL)
                                                   "    "))
                                 see)
                       (newline)))
                   (when kind
                     (newline)
                     (princ "Members:")
                     (newline)
                     (for-each (λ (k) (print-sig k
                                                 (getprop k '*formals-list* NIL)
                                                 "    "))
                               (table-keys-filter-sort (get *properties* '*doc*)
                                                       doc-extra-term?))
                     (newline))
                   #.(void))
            (unless (and (not term-bound) (environment-find-matching))
              (princ "no help for " (if kind (str kind " ") "") term)
              (when (and (not kind)
                         (sym? term)
                         (not term-bound))
                (princ " (undefined)"))
                (newline))))
  (void)))

;;; standard procedures

(def (member item lst)
  "Return the tail of a list beginning with the item, or `NIL` otherwise.
   List elements are compared to the `item` using `equal?`.

   Examples:

       (member 1 '(3 2 1 0))
       ; ↳ (1 0)

       (member 1 '(2 3))
       ; ↳ NIL"
  :doc-group list
  :doc-see memq
  :doc-see memv
  (cond ((equal? (car lst) item) lst)
        (lst                     (member item (cdr lst)))))

(def (memv item lst)
  "Return the tail of a list beginning with the item, or `NIL` otherwise.
   List elements are compared to the `item` using `eqv?`."
  :doc-group list
  :doc-see member
  :doc-see memq
  (cond ((eqv? (car lst) item) lst)
        (lst                   (memv item (cdr lst)))))

(def (assoc-list . kvs)
  "Construct an association list from the arguments.

   Every two arguments are expected to be a key and a value associated
   with that key.

   Examples:

       (assoc-list 'a 0 'b 1)
       ; ↳ ((a . 0) (b . 1))"
  :doc-group list
  :doc-see assoc
  (let ((s (cdr kvs)))
    (when (cons? s)
      (cons (cons (car kvs) (car s))
            (apply assoc-list (cdr s))))))

(def (assoc key lst)
  "Return a pair of a matching key and the associated value, or `NIL` if
   none matched.  Keys are compared using `equal?`.

   Examples:

       (def L (assoc-list 'a 0 'b 1))
       (assoc 'b L)
       ; ↳ (b . 1)
       (assoc 'c L)
       ; ↳ NIL"
  :doc-group list
  :doc-see assoc-list
  :doc-see assq
  :doc-see assv
  (cond ((equal? (caar lst) key) (car lst))
        (lst                     (assoc key (cdr lst)))))

(def (assv key lst)
  "Return a pair of a matching key and the associated value, or `NIL` if
   none matched.  Keys are compared using `eqv?`."
  :doc-group list
  :doc-see assoc
  :doc-see assq
  (cond ((eqv? (caar lst) key) (car lst))
        (lst                   (assv key (cdr lst)))))

(doc-group compare
  "Comparison operators.")

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

(def (<= v . 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 ((v v) (rest rest))
    (or (not rest)
        (unless (or (< (car rest) v)
                    (nan? v))
          (loop (car rest) (cdr rest))))))

(def (>= v . 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 ((v v) (rest rest))
    (or (not rest)
        (unless (or (< v (car rest))
                    (nan? v))
          (loop (car rest) (cdr rest))))))

(doc-group number
  "Operations on numbers, mathematical constants.")

(def (negative? n)
  "Return `T` if `n` is a negative number. Shorthand for `(< n 0)`."
  :doc-group number
  :doc-group compare
  (< n 0))

(def (zero? n)
  "Return `T` if `n` is zero. Shorthand for `(= n 0)`."
  :doc-group number
  :doc-group compare
  (= n 0))

(def (positive? n)
  "Return `T` if `n` is greater than zero. Shorthand for `(> n 0)`."
  :doc-group number
  :doc-group compare
  (< 0 n))

(def (even? n)
  "Return `T` if `n` is an even integer, `NIL` otherwise."
  :doc-group number
  :doc-see odd?
  (= (logand n 1) 0))

(def (odd? n)
  "Return `T` if `n` is an odd integer, `NIL` otherwise."
  :doc-group number
  :doc-see even?
  (not (even? n)))

(def (1+ n)
  "Equivalent to `(+ n 1)` - increment by one."
  :doc-group number
  :doc-see 1-
  (+ n 1))

(def (1- n)
  "Equivalent to `(- n 1)` - decrement by one."
  :doc-group number
  :doc-see 1+
  (- n 1))

(def (div a n)
  "Return the quotient of the Euclidean division `a/n`.

   Examples:

       (div 10 3)
       ; ↳ 3

       (div -10 3)
       ; ↳ -4

       (div -10 -3)
       ; ↳ 4

       (div 10 -3)
       ; ↳ -3"
  :doc-group number
  :doc-see mod
  :doc-see div0
  (+ (div0 a n)
     (or (and (< a 0)
              (or (and (< n 0) 1)
                  -1))
         0)))

(def (mod a n)
  "Return the remainder of the Euclidean division `a/n`.

   Examples:

       (mod  10 3)
       ; ↳ 1

       (mod -10 3)
       ; ↳ 2

       (mod -10 -3)
       ; ↳ 2

       (mod  10 -3)
       ; ↳ 1"
  :doc-group number
  :doc-see div
  :doc-see mod0
  (- a (* (div a n) n)))

(def (mod0 a n)
  "Return the remainder of the truncated division `a/n`.

   Examples:

       (mod0 10 3)
       ; ↳ 1

       (mod0 -10 3)
       ; ↳ -1

       (mod0 -10 -3)
       ; ↳ -1

       (mod0 10 -3)
       ; ↳  1"
  :doc-group number
  :doc-see div0
  :doc-see mod
  (- a (* (div0 a n) n)))

(def (random max)
  "Return a random number in the range `[0, max]` (inclusive).

   The result is either an integer or a floating point number, depending
   on the type of the `max` argument.

   Examples:

       (random 1)
       ; ↳ 1

       (random 1.0)
       ; ↳ 0.69517"
  :doc-group rand
  (if (int? max)
      (mod0 (rand) max)
      (* (rand-f64) max)))

(def (abs n)
  "Return absolute value of the argument."
  :doc-group number
  (if (< n 0)
      (- n)
      n))

(def (max v . rest)
  «Return the largest among the arguments.

   Examples:

       (max 3 1 9 4)
       ; ↳ 9

       (max 'c 'h 'z 'a)
       ; ↳ z

       (max "t" "g" "a")
       ; ↳ "t"»
  :doc-group compare
  :doc-see min
  (if rest
      (foldl (λ (a b) (if (< a b) b a))
             v
             rest)
      v))

(def (min v . rest)
  «Return the smallest among the arguments.

   Examples:

       (min 3 1 9 4)
       ; ↳ 1

       (min 'c 'h 'z 'a)
       ; ↳ a

       (min "t" "g" "a")
       ; ↳ "a"»
  :doc-group compare
  :doc-see max
  (if rest
      (foldl (λ (a b) (if (< a b) a b))
             v
             rest)
      v))

(doc-group misc
  "Miscellaneous.")

(def (identity v)
  "Return `v`."
  :doc-group misc
  v)

(doc-group type
  "Dealing with types.")

(def (rune? v)
  "Return `T` if the value is a rune, `NIL` otherwise."
  :doc-group type
  :doc-group string
  :doc-see rune
  (eq? (type-of v) 'rune))

(def (arr? v)
  "Return `T` if the argument is either a vector or an array, `NIL`
   otherwise."
  :doc-group type
  :doc-see vec?
  :doc-see arr
  :doc-see vec
  (or (vec? v)
      (let ((tx (type-of v)))
        (and (cons? tx) (eq? (car tx) 'arr)))))

(def (closure? v)
  "Return `T` if the argument is a function that is implemented in LISP
   (as opposed to a C builtin), `NIL` otherwise.

   Examples:

       (closure? closure?)
       ; ↳ T

       (closure? length)
       ; ↳ NIL"
  :doc-group type
  :doc-see fn?
  (and (fn? v)
       (not (builtin? v))))

(defmacro (defc*r name)
  "Define a shorthand for list access using `car` and `cdr`.

   Examples:

       (defc*r caaaaaaaaddr) ; define the function"
  :doc-group list
  (let* {[s (str name)]
         [n (- (length s) 2)]
         [expr (foldl (λ (i z) (cons (if (eq? #\a (str-rune s (- n i)))
                                         'car
                                         'cdr)
                                     (list z)))
                      'lst
                      (iota n))]}
    `(def (,name lst)
       ,(str "Shorthand for " expr ".")
       :doc-group list
       ,expr)))

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

(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

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

(def (every pred lst)
  «Return `T` if the predicate is true for _every_ element of the list,
   `NIL` otherwise.

   Example:

      ; is every number odd?
      (every odd? '(1 3 5 7))
      ; ↳ T

      ; is every string longer than one rune?
      (every (λ (s) (length> s 1))
             '("ab" "cd" "e"))
      ; ↳ NIL»
  :doc-group list
  :doc-see any
  (or (not lst)
      (and (pred (car lst))
           (every pred (cdr lst)))))

(def (any pred lst)
  «Return `T` if the predicate is true for _any_ element of the list,
   `NIL` otherwise.

   Example:

      ; is there any even number?
      (any even? '(1 3 5 7))
      ; ↳ NIL

      ; is there any string longer than one rune?
      (any (λ (s) (length> s 1))
           '("ab" "cd" "e"))
      ; ↳ T»
  :doc-group list
  :doc-see every
  (and (cons? lst)
       (or (pred (car lst))
           (any pred (cdr lst)))))

(def (list? v)
  "Return `T` if the value is either `NIL` or a cons cell, `NIL`
   otherwise."
  :doc-group list
  :doc-group type
  :doc-see list
  :doc-see proper-list?
  (or (not v) (cons? v)))

(def (proper-list? v)
  "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:

       ; empty list
       (proper-list? NIL)
       ; ↳ T

       ; a list with one element
       (proper-list? '(1))
       ; ↳ T

       ; a pair, cdr of the cell is 2
       (proper-list? '(1 . 2))
       ; ↳ NIL

       ; on a circular list
       (def l '(1))
       (set-cdr! l l)
       ; ↳ #0=(1 . #0#)
       (length l)
       ; ↳ +inf.0
       (proper-list? l)
       ; ↳ NIL"
  :doc-group list
  :doc-group type
  :doc-see list?
  (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 v) (and (cons? v) (proper? v v))))

(def (nthcdr lst n)
  "Return the reminder of the list after at most `n` elements, or `NIL`
   if the list is shorter.

   Examples:

       (def l '(a b c))
       (nthcdr l 1)
       ; ↳ (b c)
       (nthcdr l 2)
       ; ↳ (c)
       (nthcdr l 10)
       ; ↳ NIL"
  :doc-group list
  :doc-see nth
  (if (<= n 0)
      lst
      (nthcdr (cdr lst) (- n 1))))

(def (nth lst n)
  "Return nth element of the list, or `NIL` if the list is shorter.

   Examples:

       (def l '(a b c))
       (nth l 0)
       ; ↳ a
       (nth l 2)
       ; ↳ c
       (nth l 10)
       ; ↳ NIL"
  :doc-group list
  :doc-see nthcdr
  (car (nthcdr lst n)))

(def (length= seq n)
  "Perform a bounded length test and return `T` if the length is `n`,
   `NIL` otherwise.

   Use this instead of `(= (length seq) n)`, since it avoids unnecessary
   work and always terminates.

   The value of `seq` can be of any sequence type."
  :doc-group list
  :doc-see length<
  :doc-see length>
  (cond ((< n 0)     NIL)
        ((cons? seq) (length= (cdr seq) (- n 1)))
        (else        (= (length seq) n))))

(def (length> seq n)
  "Perform a bounded length test and return `T` if the length is greater
   than `n`, `NIL` otherwise.

   Use this instead of `(> (length seq) n)`, since it avoids unnecessary
   work and always terminates.

   The value of `seq` can be of any sequence type."
  :doc-group list
  :doc-see length<
  :doc-see length=
  (cond ((< n 0)     T)
        ((cons? seq) (length> (cdr seq) (- n 1)))
        (else        (> (length seq) n))))

(def (length< seq n)
  "Shorthand for a bounded length test `(< (length seq) n)`."
  :doc-group list
  :doc-see length=
  :doc-see length>
  (not (length> seq (- n 1))))

(def (append . lists)
  "Return the concatenation of the arguments.

   Lists are copied, except the last one, which becomes the `cdr` of the
   final dotted pair.  It's returned as is if it was the only argument.
   No lists are changed in-place.

   Examples:

       (append '(1) '(2 3) '(4))
       ; ↳ (1 2 3 4)

       (append '(1))
       ; ↳ (1)"
  :doc-group list
  :doc-see nconc
  :doc-see revappend
  (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 lst (n NIL))
  "Return a copy of the list.

   The number of elements to be copied can be limited with the optional
   argument `n`.

   Examples:

       (def a '(1 2 3 4))
       (def b (copy-list a))
       b
       ; ↳ (1 2 3 4)
       (eq? a b)
       ; ↳ NIL
       (equal? a b)
       ; ↳ T
       (copy-list a 3)
       ; ↳ (1 2 3)
       (copy-list a 10)
       ; ↳ (1 2 3 4)"
  :doc-group list
  :doc-see copy-tree
  :doc-see nthcdr
  :doc-see subseq
  (def (copy- last lst n)
    (and n (= n 0) (return))
    (unless lst (return))
    (let {[next (cons (car lst) NIL)]}
      (set-cdr! last next)
      (copy- next (cdr lst) (and n (1- n)))))
  (let {[fst (cons NIL NIL)]}
    (copy- fst lst n)
    (cdr fst)))

(def (subseq seq start (end NIL))
  «Return a bounded part of a sequence.

   The returned value is always a copy of the subsequence of the
   original.  It is an error if either `start` or `end` (if specified)
   are out of bounds.

   Examples:

       (subseq "hello" 1 2)
       ; ↳ "e"

       (subseq '(1 2 3) 0 2)
       ; ↳ (1 2)

       (subseq #(a b c) 2)
       ; ↳ #(c)»
  :doc-group list
  :doc-see str-sub
  :doc-see copy-list
  :doc-see nthcdr
  (unless (<= start end)
    (arg-error "start <= end: " start " <= " end))
  (def (subseq-l seq n)
    (if (= n 0)
        (let* ((e (and end (- end start)))
               (seq- (copy-list seq e)))
          (prog1 seq-
            (when (and e (length< seq- e))
              (bounds-error seq end))))
        (if (cons? seq)
            (subseq-l (cdr seq) (1- n))
            (bounds-error seq start))))
  (def (subseq-av alloc)
    (let* {[n (length seq)]
           [end (or end n)]
           [av (if (< n end) (bounds-error seq end) (alloc (- end start)))]}
      (for start 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) (str-sub seq start end))
        ((arr? seq) (let {[atype (cadr (type-of seq))]}
                      (subseq-av (λ (n) (arr-alloc atype n 0)))))))

(def (last-pair lst)
  "Return the last cell (pair) of the list.

   Examples:

       (last-pair '(1 2 3))
       ; ↳ (3)

       (last-pair '(1 2 . 3))
       ; ↳ (2 . 3)"
  :doc-group list
  :doc-see last-pair
  (if (atom? (cdr lst))
      lst
      (last-pair (cdr lst))))

(def (last-cdr lst)
  "Return the second element of the last cell in the list.

   It will always evaluate to `NIL` with any proper list.

   Examples:

       (last-cdr '(1 2 3))
       ; ↳ NIL

       (last-cdr '(1 2 . 3))
       ; ↳ 3"
  :doc-group list
  :doc-see last-pair
  (if (atom? lst)
      lst
      (cdr (last-pair lst))))

(def (to-proper lst)
  "Return a proper list that is a copy of the original list.

   Examples:

       (to-proper '(1 2))
       ; ↳ (1 2)

       (to-proper '(1 . 2))
       ; ↳ (1 2)"
  :doc-group list
  :doc-see proper-list?
  (cond ((not lst) lst)
        ((atom? lst) (list lst))
        (else (cons (car lst) (to-proper (cdr lst))))))

(def (filter pred lst)
  "Return a copy of the list with only the elements of the original
   that satisfy the predicate.

   Examples:

       (filter odd? '(0 1 2 3 4))
       ; ↳ (1 3)"
  :doc-group list
  :doc-see partition
  (def (filter- 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- lst (list NIL)))

(def (partition pred lst)
  "Return two lists where the first contains the elements of the original
   list which satisfy the predicate and the second containing the rest of
   the elements.

   Both lists will have the elements appear in the same order as in the
   original list.

   Examples:

       ; split the list into numbers and non-numbers
       (def q '(1a 1 0 2b e 3))
       (receive (nums other) (partition num? q)
         (print nums other)
         (newline))
       ; ↳ (1 0 3) (1a 2b e)"
  :doc-group list
  :doc-see filter
  (unless (fn? pred)
    (type-error 'fn pred))
  (def (partition- 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- lst (cons NIL NIL) (cons NIL NIL)))

(def (count pred lst)
  «Return the number of elements in the list that satisfy the predicate.

   Examples:

       (count (λ (s) (length> s 1))
              '("ab" "c" "d" "ef"))
       ; ↳ 2»
  :doc-group list
  (def (count- lst n)
    (if lst
        (count- (cdr lst) (if (pred (car lst))
                              (+ n 1)
                              n))
        n))
  (count- lst 0))

(def (iterate fn zero n)
  «Return the list of length `n` containing results of applying function
   `fn` to `zero`, 0 through `n` times.

   The result is of form

       [zero (fn zero) (fn (fn zero)) (fn (fn (fn zero))) …]

   Examples:

       (iterate 1+ 5 3)
       ; ↳ (5 6 7)

       (iterate (λ (x) (* x x)) 2 5)
       ; ↳ (2 4 16 256 65536)

       (iterate (λ (s) (str-sub s 1)) "hello" 5)
       ; ↳ ("hello" "ello" "llo" "lo" "o")»
  :doc-group list
  (and (> n 0)
       (cons zero (iterate fn (fn zero) (- n 1)))))

(def (foldr fn zero seq)
  "Reduce the sequence to a single value by repeatedly applying the function
   right-associatively.

   The function should be of the form `(fn elt acc)`, with `elt` being successive
   elements of the sequence and `acc` initially set to `zero` and subsequently
   to the previous value of the function application.

   The result will be:

       (fn e₀ (fn e₁ (…(fn eₙ zero)…)))

   Note that `foldr` is NOT tail call recursive.

   Examples:

       (foldr cons NIL (iota 5))
       ; ↳ (0 1 2 3 4)

       (foldr + 0 (iota 5))
       ; ↳ 10"
  :doc-group list
  :doc-see foldl
  :doc-see foldr1
  (def (foldr-l zero lst)
    (if lst
        (fn (car lst) (foldr-l zero (cdr lst)))
        zero))
  (def (foldr-avs acc)
    (let {[l (length seq)]}
      (def (fold- i zero)
        (if (< i l)
            (fn (acc seq i) (fold- (1+ i) zero))
            zero))
      (fold- 0 zero)))
  (cond ((or (vec? seq) (arr? seq))
         (foldr-avs aref))
        ((str? seq)
         (foldr-avs str-rune))
        (else
         (foldr-l zero seq))))

(def (foldl fn zero seq)
  "Reduce the sequence to a single value by repeatedly applying the function
   left-associatively.

   The function should be of the form `(fn elt acc)`, with `elt` being successive
   elements of the sequence and `acc` initially set to `zero` and subsequently
   to the previous value of the function application.

   The result will be:

       (fn eₙ (…(fn e₁ (fn e₀ zero))…))

   Note that `foldl` is tail call recursive.

   Examples:

       (foldl cons NIL (iota 5))
       ; ↳ (4 3 2 1 0)

       (foldl + 0 (iota 5))
       ; ↳ 10"
  :doc-group list
  :doc-see foldr
  :doc-see foldl1
  (def (foldl-l zero lst)
    (if lst
        (foldl-l (fn (car lst) zero) (cdr lst))
        zero))
  (def (foldl-avs acc)
    (let {[l (length seq)]}
      (def (fold- i zero)
        (if (< i l)
            (fold- (1+ i) (fn (acc seq i) zero))
            zero))
      (fold- 0 zero)))
  (cond ((or (vec? seq) (arr? seq))
         (foldl-avs aref))
        ((str? seq)
         (foldl-avs str-rune))
        (else
         (foldl-l zero seq))))

(def (foldl1 fn lst)
  "Same as `foldl` but using the first element of the list as the
   initial accumulator.

   Examples:

       (foldl1 * (iota 6 1))
       ; ↳ 720"
  :doc-group list
  :doc-see foldl
  :doc-see foldr1
  (foldl fn (car lst) (cdr lst)))

(def (foldr1 fn lst)
  "Same as `foldr` but using the first element of the list as the
   initial accumulator.

   Examples:

       (foldr1 + (iota 10))
       ; ↳ 45"
  :doc-group list
  :doc-see foldr
  :doc-see foldl1
  (foldr fn (car lst) (cdr lst)))

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

(def (reverse lst)
  "Return the list with its elements in reverse order.

   The original list is copied to construct the reversed version.

   Examples:

       (def a '(1 2 3))
       (reverse a)
       ; ↳ (3 2 1)
       a
       ; ↳ (1 2 3)"
  :doc-group list
  :doc-see reverse!
  (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! lst)
  "Return the list with its elements in reverse order.

   The original list may be modified by this function since it's a
   destructive operation.

   Examples:

       (def a '(1 2 3))
       (reverse! a)
       ; ↳ (3 2 1)
       a
       ; ↳ (1) ; original list has been modified in-place"
  :doc-group list
  :doc-see reverse
  (reverse!- NIL lst))

(def (revappend lst tail)
  "Return list with its elements in reverse order, with `tail` appended
   to its end.

   The original list is copied to construct the reversed version.

   Examples:

       (def a '(4 5 6))
       (revappend a '(3 2 1))
       ; ↳ (6 5 4 3 2 1)
       a
       ; ↳ (4 5 6)"
  :doc-group list
  :doc-see nreconc
  (reverse- tail lst))

(def (nreconc lst tail)
  "Return list with its elements in reverse order, with `tail` appended
   to its end.

   The original list may be modified by this function.

   Examples:

       (def a '(4 5 6))
       (nreconc a '(3 2 1))
       ; ↳ (6 5 4 3 2 1)"
  :doc-group list
  :doc-see revappend
  (reverse!- tail lst))

(def (copy-tree lst)
  "Return a recursive copy of the list.

   Unlike `copy-list`, this function copies subelements of the list
   recursively.

   Examples:

       (def a '(1 (2 3)))
       (def b (copy-tree a))
       (equal? a b)
       ; ↳ T
       (eq? a b)
       ; ↳ NIL
       (equal? (cadr a) (cadr b))
       ; ↳ T
       (eq? (cadr a) (cadr b))
       ; ↳ NIL"
  :doc-group list
  :doc-see copy-list
  (if (atom? lst)
      lst
      (cons (copy-tree (car lst))
            (copy-tree (cdr lst)))))

(def (delete-duplicates lst)
  "Return a copy of the list with duplicated elements removed.

   Elements are tested for duplicates using `equal?`.  The order of the
   elements is preserved in the resulting list.

   Examples:

       (delete-duplicates '(a 0 b c1 a b 3 c 5))
       ; ↳ (a 0 b c1 3 c 5)"
  :doc-group list
  (let ((ta (table)))
    (let loop ((l lst) (acc NIL))
      (if (atom? l)
          (reverse! acc)
          (if (has? ta (car l))
              (loop (cdr l) acc)
              (put! ta (car l) T)
              (loop (cdr l) (cons (car l) acc)))))))

(def (find-if pred lst (:key identity)
                       (:start 0)
                       (:end NIL)
                       (:from-end NIL))
  (def (find-if- lst)
    (if (or (not lst) (pred (key (car lst))))
        (car lst)
        (find-if- (cdr lst))))
  (unless (and (= start 0)
               (not end)
               (not from-end))
    (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 fn . lst)
  (apply map fn lst))

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

(def (map-int fn count)
  «Return a list of elements generated by repeated calls to `fn`.

   The lambda `fn` will be called with a single argument which is an
   increasing number in the range `[0, count)` (exclusive).  The
   resulting list contains the values returned by `fn`.


   Examples:

       (map-int even? 5)
       ; ↳ (T NIL T NIL T)

       (map-int (λ (i) (str i i i)) 4)
       ; ↳ ("000" "111" "222" "333")»
  :doc-group list
  :doc-see iota
  (and (> count 0)
       (let* ((first (cons (fn 0) NIL))
              (acc first))
         (for 1 count
              (λ (i) (set-cdr! acc (cons (fn i) NIL))
                     (set! acc (cdr acc))))
         first)))

; SRFI 1
(def (iota count (start 0) (step 1))
  "Return a list of generated indices.

   The sequence of numbers generated will contain the elements

       (start start+step … start+(count-1)*step)

   Examples:

       (iota 4)
       ; ↳ (0 1 2 3)

       (iota 4 6)
       ; ↳ (6 7 8 9)

       (iota 4 6 -0.5)
       ; ↳ (6 5.5 5.0 4.5)"
  :doc-group list
  :doc-see map-int
  (map-int (λ (x) (+ start (* x step))) count))

(def (sort lst less-than? (:key identity))
  «Return a copy of the list sorted by comparing elements with the
   two-argument function `less-than?`.

   An optional keyworded argument `:key` is used to provide a function to
   retrieve terms (the _key_) from the list items in order to perform
   comparison.  By default the terms compared are the list elements
   themselves.

   Examples:

       ; simple sort (note: symbols > numbers)
       (sort '(1a 1 0 2b e 3) <)
       ; ↳ (0 1 3 1a 2b e)

       ; sort in lexicographical order (as strings)
       (sort '(1a 1 0 2b e 3) < :key str)
       ; ↳ (0 1 1a 2b 3 e)

       ; sort by type (note how the numbers stayed in the same order)
       (sort '(3 "a" 1 a #\a 2)
             (λ (a b) (< (type-of a) (type-of b))))
       ; ↳ (3 1 2 #\a "a" a)»
  :doc-group list
  :doc-see partition
  (if (not (cdr lst))
      lst
      (let ((piv (car lst)))
        (receive (less grtr)
                 (partition (λ (x) (less-than? (key x) (key piv))) (cdr lst))
                 (nconc (sort less less-than? :key key)
                        (list piv)
                        (sort grtr less-than? :key key))))))

;;; backquote

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

(defdoc (quote expr)
  «Leave the expression unevaluated.

   Shorthand for `(quote expr)`.

   Examples:

       '(0 1 (+ 2 3)) ; same as (quote (0 1 (+ 2 3)))
       ; ↳ (0 1 (+ 2 3))»
  :doc-group syntax
  :doc-see "(quasiquote expr)"
  :doc-see "(unquote expr)")

(defmacro (quasiquote expr)
  «Same as `'expr` but allows evaluating ("unquoting") parts of
   the expression.

   Shorthand for `(quasiquote expr)`.

   Examples:

       `(0 1 (+ 2 3)) ; same as (quasiquote (0 1 (+ 2 3)))
       ; ↳ (0 1 (+ 2 3))»
  :doc-group syntax
  :doc-see "(unquote expr)"
  :doc-see "(quote expr)"
  (bq-process expr 0))

(defmacro (unquote expr)
  «Evaluate the expression, which is a part of a quasiquoted expression
   itself.

   Shorthand for `(unquote expr)`.

   Examples:

       `(0 1 ,(+ 2 3)) ; same as (quasiquote (0 1 (unquote (+ 2 3))))
       ; ↳ (0 1 5)»
  :doc-group syntax
  :doc-see "(quasiquote expr)"
  :doc-see "(quote expr)"
  (cons 'unquote expr))

;; 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)
  (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)))
  (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    (last-cdr 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

(doc-group syntax
  "StreetLISP syntax and macros.")

(defmacro (with-output-to io . body)
  «Evaluate expressions in `body` with `*io-out*` set to `io` during the
   evaluation.

   Examples:

       ; write a string "hello, world!" to a file
       ; end with a newline
       (with-output-to (file "/tmp/1.txt" :create :truncate :write)
         (print "hello, world!")
         (newline))»
  :doc-group io
  :doc-see with-input-from
  `(with-bindings ((*io-out* ,io))
                  ,@body))

(defmacro (with-input-from io . body)
  «Evaluate expressions in `body` with `*io-in*` set to `io` during the
   evaluation.

   Examples:

       ; read a single expression from a file
       ; and print it
       (with-output-to (file "/tmp/1.txt" :read)
         (print (read *io-in*))
         (newline))»
  :doc-group io
  :doc-see with-output-to
  `(with-bindings ((*io-in* ,io))
                  ,@body))

(defmacro (defmacro form . body)
  «Define a new macro.

   Examples:

       (defmacro (inc! v)
         "Increments and returns the value."
         :doc-group my-cool-macros
         :doc-see my-other-cool-macro
         (if (num? v)
             (1+ v)
             `(set! ,v (1+ ,v))))
       (inc! 1)
       ; ↳ 2
       (set! x 1)
       (inc! x)
       ; ↳ 2
       x
       ; ↳ 2»
  :doc-group syntax
  :doc-see macroexpand
  (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)))
    `(begin (set-syntax! ',(car form)
                         (λ ,(cdr form) ,@body))
            #.(void))))

(defmacro (and . rest)
  «Return `NIL` and stop evaluating the arguments if one of them
   evaluated to `NIL`.  Return the last value otherwise.

   Examples:

       (and)
       ; ↳ T

       (and 1 2 (print 'yes) 3)
       ; ‼ yes
       ; ↳ 3

       (and 1 NIL (print 'yes) 3)
       ; ↳ NIL»
  :doc-group syntax
  :doc-see or
  :doc-see not
  `($and ,@rest))

(defmacro (or . rest)
  «Return the first evaluated argument that is not `NIL` and stop
   evaluating the rest of the arguments.  Return `NIL` otherwise.

   Examples:

       (or)
       ; ↳ NIL

       (or 1 2 (print 'first) (print 'second) 3)
       ; ↳ 1

       (or NIL NIL (print 'first) (print 'second) 3)
       ; ‼ first»
  :doc-group syntax
  :doc-see and
  :doc-see not
  `($or ,@rest))

(defmacro (for start limit fn)
  "Call the function `f` with a single argument in a loop until the argument
   reaches `limit` or greater.

   The argument is incremented by `1` after each call, with the initial value
   set to `start`.

   Examples:

       (for 0 2 (λ (i) (print i)))
       ; ‼ 01"
  :doc-group syntax
  :doc-see while
  `(#.void (let {[i# ,start] [n# ,limit]}
     (while (< i# n#)
       (,fn i#)
       (set! i# (+ i# 1))))))

(def (for start limit fn) ; counterpart for (apply for …
  (for start limit fn))

(defdoc (def form body₀ . rest)
  «Assign the function (first form) or the result of the expression
   (second form) to the identifier.

   Documentation for the definition may also be supplied after `form` in
   the same manner as with `defdoc`.

   Function definitions themselves may contain other definitions internal
   to the function.

   Examples:

       ; a function with documentation (first form)
       (def (f x)
         "Return the square of doubled `x`.

          Examples:

              (f 3)
              ; ↳ 36"
         :doc-group cool-funcs ; documentation group for (help groups)
         :doc-see g ; reference another function in the documentation
         (def (g y) ; an internal function
           (+ y y))
         (* (g x) (g x)))
       (f 2)
       ; ↳ 16

       ; a variable (second form)
       (def x (length "hello"))
       x
       ; ↳ 5»
  :doc-group syntax
  :doc-see defdoc
  :doc-see set!)

(defdoc (def id expr))

(defmacro (def id expr . rest)
  (cons '$def (cons id (cons expr rest))))

(defmacro (set! id expr . rest)
  "Evaluate the expression, assign the result to the identifier and
   return the value.

   The identifier must already be bound in the same environment,
   otherwise this results in a compilation error.

   Multiple identifiers and expressions may be specified in pairs.  The
   returned value will be the result of the last expression.

   Examples:

       (def a NIL)
       (def b NIL)
       (def c NIL)
       (set! a 1 b 2 c (+ a b))
       ; ↳ 3
       a
       ; ↳ 1
       b
       ; ↳ 2
       c
       ; ↳ 3"
  :doc-group syntax
  :doc-see set-top-level-value!
  (let {[first (list '$set! id expr)]}
    (if (not rest)
        first
        (cons '$begin
              (cons first
                    [let loop ((p rest))
                      (when p
                        (unless (cdr p)
                          (arg-error "set!: odd number of arguments"))
                        (cons (list '$set! (car p) (cadr p))
                              (loop (cddr p))))])))))

(defmacro (begin . body)
  «Evaluate the expressions in order and return the result of the last
   expression.

   Examples:

       (if 1
           (begin (print 1)
                  (newline)
                  'ignored
                  'done)
           (print 0)
           (newline)
           'else)
       ; ‼ 1
       ; ↳ done»
  :doc-group syntax
  :doc-see prog1
  (cons '$begin body))

(defmacro (if cond then . else)
  «Return the result of `then` if `cond` evaluated as "true", `else`
   otherwise.

   The `else` is not optional unlike in many other LISP implementations.
   Primary purpose is to spot errors involving wrong parenthesis
   placement.  Another reason is to force a certain coding style.

   Examples:

       (def x '(1))
       (if x (begin (print "yep!") (newline) 'yes) 0)
       ; ‼ yep!
       ; ↳ yes
       (if (str? x) 1 (print "nope!") (newline) 'no)
       ; ‼ nope!
       ; ↳ no»
  :doc-group syntax
  :doc-see when
  :doc-see unless
  (unless else
    (arg-error "if without an else branch"))
  (list '$if cond then (cons 'begin else)))

(defmacro (when cond . body)
  «Shorthand for `(if cond body NIL)`.

   A non-empty body is required.

   Examples:

       (when (eq? cmd 'exit)
         (princ "exiting!")
         (newline)
         (exit))»
  :doc-group syntax
  :doc-see unless
  :doc-see if
  (unless body
    (arg-error "when without a body"))
  (list 'if cond (cons 'begin body) NIL))

(defmacro (unless cond . body)
  «Shorthand for `(if cond NIL body)`.

   A non-empty body is required.

   Examples:

       (unless (cons? x)
         (princ "oops!")
         (newline)
         (type-error 'cons x))»
  :doc-group syntax
  :doc-see when
  :doc-see if
  (unless body
    (arg-error "unless without a body"))
  (list 'if cond NIL (cons 'begin body)))

(defmacro (return (value (void)))
  «Return from the function with the specified value as the result.

   Examples:

       (def (f x) (when (not x)
                    (return 0))
                  (princ "hi")
                  (newline)
                  1)
       (f 'a)
       ; ‼ hi
       ; ↳ 1
       (f NIL)
       ; ↳ 0»
  :doc-group syntax
  (list '$return value))

(defmacro (prog1 expr . rest)
  «Evaluate the expressions in order, return the result of the first one.

   Examples:

       (prog1 (+ 1 2 3)
              (print "hi")
              (newline))
       ; ↳ 6»
  :doc-group syntax
  :doc-see begin
  (cons '$prog1 (cons expr rest)))

(defmacro (while cond . body)
  «Evaluate the body expressions until `cond` evaluates to `NIL`.

   Examples:

       (def x 3)
       (while (> x 0)
         (princ #\x)
         (set! x (1- x)))
       ; ‼ xxx»
  :doc-group syntax
  :doc-see for
  (cons '$while (cons cond body)))

(defmacro (trycatch try catch)
  «Return the result of evaluation of the expression `try` or, if an
   exception has been thrown, the one-argument function `catch`.

   Examples:

       (trycatch (+ 1 2) (λ (e) e))
       ; ↳ 3
       (trycatch (+ 1 NIL) (λ (e) e))
       ; ↳ (type-error num NIL)»
  :doc-group syntax
  :doc-see unwind-protect
  (list '$trycatch try catch))

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

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

(defmacro (let binds . body)
  (let ((lname NIL))
    (when (sym? binds)
      (set! lname binds
            binds (car body)
            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))

(defmacro (case key . clauses)
  (def (quote-value v)
    (if (self-evaluating? v)
        v
        (list '$quote v)))
  (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))
                           ,@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
          (λ (,v) ,@body))))

(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 . msg)
  "Raise an error exception."
  :doc-group error
  (raise (cons 'error msg)))

(def (arg-error . msg)
  "Raise an argument error exception."
  :doc-group error
  (raise (cons 'arg-error msg)))

(def (type-error expected-type got-value . msg)
  "Raise a type error exception."
  :doc-group error
  (raise (list* 'type-error expected-type got-value msg)))

(def (bounds-error seq index . msg)
  "Raise a bounds error exception."
  :doc-group error
  (raise (list* 'bounds-error seq index msg)))

(defmacro (throw tag value)
  "Raise an exception consisting of a tag and a value.

   This exception can be caught by `catch`."
  :doc-group error
  :doc-see catch
  `(raise (list 'thrown-value ,tag ,value)))

(defmacro (catch tag expr)
  "Evaluate `expr` and catch any exception thrown while evaluating by a
   call to `throw` with the specified `tag`.

   If no exception was thrown, return the result of the expression.  In
   case an exception thrown has a different tag, raise it further, to be
   caught on a higher level of exception handling logic."
  :doc-group error
  :doc-see catch
  :doc-see unwind-protect
  `(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)
  «Evaluate `expr` first, then `finally`, regardless of whether
   evaluating the former resulted in any exception thrown or not.

   If an exception has been thrown, it will be raised _after_ evaluating
   `finally`, else the result of `expr` is returned.

   Examples:

       (unwind-protect (begin (print "a")     (newline)
                              (print (/ 1 0)) (newline) ; an error here
                              (print "b")     (newline)
                       (begin (print "c")     (newline))))
       ; ↳ "a"
       ; ↳ "c"
       ; ‼ /: division by zero»
  :doc-group error
  :doc-see catch
  `(let ((thk# (λ () ,finally)))
     (prog1 (trycatch ,expr
                      (λ (e#) (thk#) (raise e#)))
            (thk#))))

;;; debugging utilities

(doc-group debug
  "Debugging utilities.")

(defmacro (assert expr)
  «Throw an exception if `expr` evaluates to `NIL`.  Return `T` in any
   other case.

   Examples:

       (def s "abc")
       (assert (= (length s) 3))
       ; ↳ T
       (assert (eq? (str-rune s 0) #\x))
       ; ‼ assertion failed: ...»
  :doc-group debug
  :doc-see assert-fail
  `(if ,expr T (raise '(assert-failed ,expr))))

(defmacro (assert-fail expr . what)
  «Throw an "assertion failed" exception if evaluating `expr` itself does
   not result in an exception thrown. Return `T` otherwise.

   To test for a specific exception type, an optional `what` argument can
   be used.

   Examples:

       (def s "abc")
       (assert-fail (= (length s) 3))
       ; ‼ assertion failed: ...
       (assert-fail (= s 1) type-error)
       ; ↳ T»
  :doc-group debug
  :doc-see assert
  `(assert (trycatch (begin ,expr NIL)
                     (λ (e) ,(if what
                                 `(eq? (car e) ',(car what))
                                 T)))))

(def (traced? fn)
  "Return `T` if the tracing is enabled for the function, `NIL`
   otherwise.

   Examples:

       (traced? map)
       ; ↳ NIL
       (trace 'map)
       (traced? map)
       ; ↳ T
       (untrace 'map)
       (traced? map)
       ; ↳ NIL"
  :doc-group debug
  :doc-see trace
  :doc-see untrace
  (let ((sample-traced-lambda (λ args (write (cons 'x args))
                                      (newline)
                                      (apply #.apply args))))
      (and (closure? fn)
           (equal? (fn-code fn)
                   (fn-code sample-traced-lambda)))))

(def (trace sym)
  «Enable tracing for the function bound to the symbol.

   When tracing is enabled for the function, before evaluating the call
   the name and arguments will be printed to `*io-out*`.

   Examples:

       (trace 'map)
       (map odd? (list (+ 1 2) (+ 3 4)))
       ; ‼ (map #fn("n170051S:" #(even?) odd? 6) (3 7))
       ; ↳ (T T)»
  :doc-group debug
  :doc-see untrace
  :doc-see traced?
  (let ((fn (top-level-value sym)))
    (when (not (traced? fn))
      (set-top-level-value! sym
                            (eval
                              `(λ args#
                                  (write (cons ',sym args#))
                                  (newline)
                                  (apply ',fn args#))))))
  #.(void))

(def (untrace sym)
  «Disable tracing for the function bound to the symbol.

   Examples:

       (trace 'map)
       (map odd? (list (+ 1 2) (+ 3 4)))
       ; ‼ (map #fn("n170051S:" #(even?) odd? 6) (3 7))
       ; ↳ (T T)
       (untrace 'map)
       (map odd? (list (+ 1 2) (+ 3 4)))
       ; ↳ (T T)»
  :doc-group debug
  :doc-see trace
  :doc-see traced?
  (let ((func (top-level-value sym)))
    (when (traced? fn)
      (set-top-level-value! sym
                            (aref (fn-vals fn) 3))))
  #.(void))

(defmacro (time expr)
  "Display the elapsed time of evaluating `expr` to `*io-out*`, return
   the result of the evaluated expression.

   Examples:

       (time (begin (sleep 0.1) 12345))
       ; ‼ Elapsed time: 0.10013356 seconds
       ; ↳ 12345"
  :doc-group debug
  `(let ((t0# (time-now)))
     (prog1
      ,expr
      (princ "Elapsed time: " (- (time-now) t0#) " seconds" *linefeed*))))

;;; text I/O

(def (print . args)
  «Print the arguments to *io-out* with `*print-readably*` set to `T`.

   Multiple arguments are separated with a single `#\space`.

   Examples:

       (print 1 2 "abc")
       ; ‼ 1 2 "abc"»
  :doc-group io
  :doc-see princ
  (let {[a (car args)]
        [d (cdr args)]}
    (with-bindings ((*print-readably* T))
      (write a)
      (when d
        (for-each (λ (e) (princ " ") (write e))
                  d))))
  #.(void))

(def (princ . args)
  «Print the arguments to *io-out* with `*print-readably*` set to `NIL`.

   Examples:

       (princ 1 2 "abc")
       ; ‼ 12abc»
  :doc-group io
  :doc-see print
  (with-bindings ((*print-readably* NIL))
                 (for-each write args)))

(def (newline (io *io-out*))
  «Write a single OS-specific line feed to the output.

   On most systems it's a single character - `#\linefeed` (`\n`).»
  :doc-group io
  :doc-see *linefeed*
  (io-write io *linefeed*)
  #.(void))

(def (io-read-line io)
  «Return a single line of input read from `io`.

   Reading stops at either a `#\linefeed` character or upon reaching EOF.
   The line feed character is included in the returned value unless EOF
   has been reached beforehand.

   EOF (`#<eof-object>`) is returned if the IO object had no data.

   Examples:

       ; read one line from the kernel messages file
       (io-read-line (file "/dev/kmesg"))
       ; ↳ "127 holes free\n"

       ; /dev/null has no data - EOF is returned
       (eof-object? (io-read-line (file "/dev/null")))
       ; ↳ T»
  :doc-group io
  :doc-see eof-object?
  :doc-see io-read-lines
  (io-read-until io #\linefeed)) ; FIXME read until *linefeed* instead?

(def (read-all-of fn io)
  "Call `fn` on an IO object until it runs out of data.  Return the list
   containing the values returned by `fn` on each call."
  :doc-group io
  :doc-see read-all
  :doc-see io-read-lines
  (let loop ((lines NIL)
             (curr (fn io)))
    (if (eof-object? curr)
        (reverse! lines)
        (loop (cons curr lines) (fn io)))))

(def (io-read-lines io)
  «Return a list of lines read from the IO object until it ran out of
   data.

   The file is split into lines by `#\linefeed`.  Each string will have
   the character, except the last line if EOF has been reached
   beforehand.

   Examples:

       ; read current process' segments on Plan 9
       (def seg (file (str "/proc/" (getpid) "/segment")))
       (io-read-lines seg)
       ; ↳ ("Stack     1feff0000 1ffff0000    1\n"
            "Text   R     10000    70000    1\n"
            "Data         70000    d0000    1\n"
            "Bss          d0000   1a0000    1\n"
            "Bss       1fcff0000 1feff0000    1\n"
            "Bss       1faff0000 1fcff0000    1\n")»
  :doc-group io
  :doc-see io-read-line
  :doc-see io-read-all
  (read-all-of io-read-line io))

(def (io-read-all io)
  «Return a string containing all of the data read from the IO object
   until it ran out of data.

   An empty string (`""`) is returned if the IO object had no data.

   Examples:

       ; read current user on Plan 9
       (io-read-all (file "/dev/user"))
       ; ↳ "glenda"»
  :doc-group io
  :doc-see read-all
  :doc-see io-read-lines
  (let ((b (buffer)))
    (io-copy b io)
    (io->str b)))

(def (read-all io)
  «Return a list of terms read from the IO object until it ran out of
   data.

   Examples:

       ; read current process' status file on Plan 9
       (def status (file (str "/proc/" (getpid) "/status")))
       (read-all status)
       ; ↳ (sl glenda Pread 40 0 4940 0 0 0 1856 10 10)»
  :doc-group io
  :doc-see io-read-all
  (read-all-of read io))

;;; vector functions

(def (list->vec lst)
  "Return the list converted to a vector.

   Examples:

       (list->vec '(1 2 a))
       ; ↳ #(1 2 a)"
  :doc-group list
  :doc-see vec->list
  (apply vec lst))

(def (vec->list vc)
  "Return the vector converted to a list.

   Examples:

       (vec->list #(1 2 a))
       ; ↳ (1 2 a)"
  :doc-group list
  :doc-see list->vec
  (apply list vc))

;;; table functions

(doc-group table
  "Tables of keys with associated values.")

(def (table->assoc-list ta)
  "Return the table converted to an association list (pairs of each
   key and value).

   Examples:

       (def t #table(a 1 b 2 c 1))
       (table->assoc-list t)
       ; ↳ ((a . 1) (b . 2) (c . 1))"
  :doc-group table
  :doc-see table-keys
  :doc-see table-values
  (table-fold (λ (k v z) (cons (cons k v) z))
               NIL ta))

(def (table-keys ta)
  "Return the list of all keys of the table.

   Examples:

       (def t #table(a 1 b 2 c 1))
       (table-keys t)
       ; ↳ (a b c)"
  :doc-group table
  :doc-see table-values
  (table-fold (λ (k v z) (cons k z))
               NIL ta))

(def (table-values ta)
  "Return the list of all values of the table.

   Examples:

       (def t #table(a 1 b 2 c 1))
       (table-values t)
       ; ↳ (1 2 1)"
  :doc-group table
  :doc-see table-keys
  (table-fold (λ (k v z) (cons v z))
               NIL ta))

(def (copy-table ta)
  "Return a new copy of the table with the keys and values preserved.

   No copies of the keys nor values are created - original ones are
   reused.

   Examples:

       (def t #table(a (1 2 3)))
       (def q (copy-table t))
       (eq? t q)
       ; ↳ NIL
       (eq? (get t 'a) (get q 'a))
       ; ↳ T"
  :doc-group table
  :doc-see table->assoc-list
  (let ((nt (table)))
    (table-fold (λ (k v z) (put! nt k v))
                 NIL ta)
    nt))

(def (table-invert ta)
  "Return a new table with the keys and values from the original table
   but entries _inverted_ - values to keys and keys to values.

   Note that if the original table had several keys mapped to the same
   value, only one such mapping will be stored in the new table.

   Examples:

       (def t #table(a 1 b 2 c 1))
       (table-invert t)
       ; ↳ #table(1 a  2 b)"
  :doc-group table
  :doc-see table-values
  (let ((nt (table)))
    (table-fold (λ (k v z) (put! nt v k))
                 NIL ta)
    nt))

;;; string functions

(def (num->str n (:base 10))
  «Return the number formatted as a string.

   Floating point numbers can only be formatted in base 10.  Bignums are
   supported with bases 2, 4, 8, 10, 16 and 32.  The rest of the
   numerical types are valid for any base from 2 to 36.

   Note: unlike other LISP dialects, StreetLISP's base-32 encoding is
   done according to RFC 4648.

   Examples:

       (num->str 65535 :base 16)
       ; ↳ "FFFF"

       (num->str (s8 -7))
       ; ↳ "-7"»
  :doc-group string
  (unless (num? n)
    (type-error 'num n))
  (unless (int? base)
    (type-error 'base n))
  (unless (<= 2 base 36)
    (arg-error "invalid/unsupported base: " base))
  (unless (or (int? n) (= base 10))
    (arg-error "invalid/unsupported base with floating point: " base))
  (unless (or (not (bignum? n)) (= base 10) (zero? (logand base (1- base))))
    (arg-error "invalid/unsupported base with bignum: " base))
  (with-bindings {[*print-base* base]
                  [*print-ptr-base* base]
                  [*print-radix* NIL]
                  [*print-ptr-radix* NIL]
                  [*print-readably* NIL]}
    (let {[b (buffer)]}
      (write n b)
      (prog1 (io->str b)
             (io-close b)))))

(def (str-trim s (lead-pred rune-whitespace?) (trail-pred lead-pred))
  «Return the portion of the string with all leading runes satisfying
   `lead-pred` (and trailing runes satisfying `trail-pred`) removed.

   Without predicates explicitly specified, `str-trim` will remove
   whitespace from both sides of the string.

   Pass `NIL` as the predicate to disable trimming on either side.

   Examples:

       (str-trim " \nhello\t\v")
       ; ↳ "hello"

       (str-trim " \nhello\t\v"
                 (λ (r) (str-find " \v" r)))
       ; ↳ "\nhello\t"

       (str-trim "123abc!456def"
                 rune-numeric?
                 rune-alphabetic?)
       ; ↳ "abc!456"»
  :doc-group string
  :doc-see str-sub
  :doc-see str-map
  (def (trim-start i L)
    (if (and (< i L) (lead-pred (str-rune s i)))
        (trim-start (1+ i) L)
        i))
  (def (trim-end i)
    (if (and (> i 0) (trail-pred (str-rune s (1- i))))
        (trim-end (1- i))
        i))
  (let ((L (length s)))
    (str-sub s
             (if lead-pred (trim-start 0 L) 0)
             (if trail-pred (trim-end L) L))))

(def (str-map fn s)
  «Return the concatenation of the values produced by `fn` when applying
   to each rune of the string `s`.

   Function `fn` may return a value of any type suitable for `io-write` -
   a rune, string, array of C primitives.  If `fn` returns `NIL`, the
   rune is ignored.

   Examples:

       (str-map rune-upcase
                "hello, world!")
       ; ↳ "HELLO, WORLD!"

       (str-map (λ (r) (str r r))
                "hello")
       ; ↳ "hheelllloo"

       (str-map (λ (r) (and (not (rune-whitespace? r)) r))
                "! this is great !")
       ; ↳ "!thisisgreat!"»
  :doc-group string
  (let ((b (buffer))
        (n (length s)))
    (let ((i 0))
      (while (< i n)
         (let {[r (fn (str-rune s i))]}
           (when r
             (io-write b r)))
         (set! i (1+ i))))
    (io->str b)))

(def (str-rep term k)
  «Return the concatenation of the term formatted as a string, repeated
   `k` times.

   Examples:

       (str-rep "oi" 3)
       ; ↳ "oioioi"

       (str-rep #\ы 5)
       ; ↳ "ыыыыы"

       (str-rep 'a 3)
       ; ↳ "aaa"

       (str-rep 1 5)
       ; ↳ "11111"»
  :doc-group string
  (cond ((<= k 0) "")
        ((odd? k) (str term (str-rep term (- k 1))))
        (else     (str-rep (str term term) (div0 k 2)))))

(def (str-lpad s n (c #\space))
  (str (str-rep c (- n (str-width s))) s))

(def (str-rpad s n (c #\space))
  (str s (str-rep c (- n (str-width s)))))

(def (print-to-str . args) ; FIXME replace with with-output-to-str
  (let ((b (buffer)))
    (with-output-to b
      (apply print args))
    (io->str b)))

(def (str-join strlist sep)
  «Return concatenated elements of `strlist`, separated between each
   other with `sep`, as a single string.

   The separator can be of any type suitable for `io-write` - a rune,
   string, array of C primitives.

   Examples:

       (str-join '("" "n" "9" "heh")
                 *directory-separator*)
       ; ↳ "/n/9/heh"

       (str-join '("a" "b" "c") #\.)
       ; ↳ "a.b.c"»
  :doc-group string
  :doc-see str-split
  (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 NIL)))
    (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)
                          (sym 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* {[fld (nth slots-car i)]
                               [fun (if access (sym access fld) fld)]
                               [iv (if isvec (+ (* 2 i) 1) i)]}
                          `(def (,fun s)
                             ,(when is?
                                `(unless (,is? s)
                                   (type-error ',type-of-value s)))
                             (aref s ,[+ (if named 1 0) iv]))])
                 num-slots)

      ; setter per slot
      ,@(map-int (λ (i) [let* {[opts (nth slots-opts i)]
                               [fld (nth slots-car i)]
                               [fun (sym (or access "") fld #\!)]
                               [iv (if isvec (+ (* 2 i) 1) i)]}
                          (unless (assv :read-only opts)
                            `(def (,fun s v)
                               ,(when is?
                                  `(unless (,is? s)
                                     (type-error ',type-of-value s)))
                               (aset! s ,[+ (if named 1 0) iv] v)))])
                 num-slots)
      #.(void))))

;;; toplevel

(defmacro (quote x)
  (list '$quote x))

(def (macrocall? e)
  "Return the macro application function if `e` refers to a macro call,
   `NIL` otherwise.

   Examples:

       (macrocall? '(car NIL))
       ; ↳ NIL

       (macrocall? '(let ((x 1)) 2))
       ; ↳ #fn(...)"
  :doc-group syntax
  :doc-see macroexpand-1
  :doc-see macroexpand
  (and (cons? e) (get-syntax (car e))))

(def (macroexpand-1 e)
  «Return a macro-expanded expression.

   If the expression is not a macro call, it is returned unchanged.
   Only a single level of expansion is performed.

   Examples:

       (let ((a 3) (b 4) (c 5))
         (macroexpand-1 `(let* {[x ,a] [y ,b]} (+ x y ,c))))
       ; ↳ ((λ (x) ; note how the inner let* expression isn't expanded
              (let* ((y 4)) (+ x y 5)))
            3)»
  :doc-group syntax
  :doc-see macroexpand
  (if (atom? e)
      e
      (let ((f (macrocall? e)))
        (if f
            (apply f (cdr e))
            e))))

(def (macroexpand e)
  «Return a fully macro-expanded expression.

   Expansion will continue until no more macro calls are left.

   Examples:

       (let ((a 3) (b 4) (c 5))
         (macroexpand `(let* {[x ,a] [y ,b]} (+ x y ,c))))
       ; ↳ ((λ (x)
              ((λ (y)
                 (+ x y 5))
               4))
            3)»
  :doc-group syntax
  :doc-see macroexpand-1
  ; 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 (eq? *expanded* (caar body))
                      (set-car! body (cdar body))
                      (set-car! body (expand-in (car body) env)))
                  (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    (last-cdr 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-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 ((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))
                (else               (default))))))
  (expand-in e NIL))

(def (eval x)
  "Evaluate expression.

   Examples:

       (eval '(begin (set! x 1 y 2) (+ x y)))
       ; ↳ 3
       x
       ; ↳ 1
       y
       ; ↳ 2"
  :doc-group vm
  :doc-see load
  ((compile-thunk (macroexpand x))))

(def (load path/io)
  «Read and evaluate expression from the file or IO object.

   If the argument is an IO object it is _not_ closed after the load
   finishes.

   Examples:

       (load "stuff.sl")»
  :doc-group vm
  :doc-see eval
  (let* {[isio? (io? path/io)]
         [F (if isio? path/io (file path/io :read))]}
    (trycatch
      (let next (prev E v)
        (if (not (io-eof? F))
            (next (read F)
                  prev
                  (void (eval E)))
            (void (unless isio?
                    (io-close F)) ; evaluate last form in almost-tail position
                  (eval E))))
      (λ (e)
        (unless isio?
          (io-close F))
        (raise `(load-error ,e))))))

(def that
  «The result of the last expression evaluated in the REPL.

   Examples:

       (map rune-upcase "hello, world!")
       ; ↳ "HELLO, WORLD!"
       (str-sub that 0 5)
       ; ↳ "HELLO"
       (map rune-downcase that)
       ; ↳ "hello"»
  :doc-group vm
  :doc-see repl
  NIL)

(def (repl)
  "Run interactive prompt in a loop, reading and evaluating the
   expressions entered by the user and printing the results.

   This function is executed automatically if StreetLISP is started in
   interactive mode."
  :doc-group vm
  :doc-see that
  :doc-see *interactive*
  :doc-see *prompt*
  (set! that #.(void))
  (*prompt*)
  (io-flush *io-out*)
  (def (prompt)
    (let ((v (trycatch (read *io-in* :whitespace T)
                       (λ (e) (io-discard-buffer *io-in*)
                              (raise e)))))
      (and (not (io-eof? *io-in*))
           (let ((V (eval v)))
             (if (void? V)
                 (when (void? v)
                   (*prompt*)
                   (io-flush *io-out*))
                 (print V)
                 (set! that V)
                 (newline))
             #.(void)))))
  (def (reploop)
    (when (trycatch (prompt)
                    (λ (e)
                      (top-level-exception-handler e)
                      T))
      (reploop)))
  (reploop)
  (newline))

(doc-group error
  "Errors and exception handling.")

(def (top-level-exception-handler e)
  "Print the exception `e` and the stack trace to `*stderr*`.

   This is the top level exception handler that is used by `load` and
   `repl` functions to handle exceptions that weren't handled at the
   lower level."
  :doc-group error
  (with-output-to *stderr*
    (print-exception e)
    (print-stack-trace (stacktrace))))

(def (print-stack-trace st)
  "Print the stacktrace."
  :doc-group error
  :doc-see stacktrace
  (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 (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 (length f)
         (λ (i) (princ " ")
                (print (aref f i))))
       (princ ")" *linefeed*)
       (when (= n 0)
         (fn-disasm (aref f 1) :ip (aref f 0)))
       (set! n (+ n 1)))
     (reverse! st))))

(def (print-exception e)
  "Print the exception in a human-readable form.

   Exceptions are lists containing various information about the error.
   They may optionally, as the first element, contain the error location
   of the form `(io row column)`.

   Examples:

       (def e (list (list *stdin* 3 10) 'type-error 'str 123))
       (print-exception e)
       ; ‼ *stdin*:3:10: type error: expected str, got fixnum: 123"
  :doc-group error
  :doc-see *exception-print-level*
  :doc-see *exception-print-length*
  (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 (cons? 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: ")
           (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")
           (when (get-syntax (car a))
             (princ " (defined as a macro)")))

          ((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 'arity-error)
           (princ "arity error: expected " (car a) ", got " (cadr a))
           (when (cddr a)
             (princ ": ")
             (apply print (cddr a))))

          ((eq? k 'key-error)
           (princ "key not found: ")
           (print (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 print a))

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

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

(def (make-system-image filename)
  «Build and store a "system image" of the runtime environment to a file.»
  :doc-group vm
  (def (save? s)
    (let {[includes '(*syntax-environment* *properties* *builtins*)]
          [excludes '(ptr)]}
      (or (memq s includes)
          (and (bound? s)
          (not (const? s))
          (or (not (builtin? (top-level-value s)))
              (not (equal? (str s) ; alias of a builtin
                           (str (top-level-value s)))))
          (not (memq s excludes))
          (not (or (<= '*a s '*z) (<= '+a s '+z)))
          (not (io? (top-level-value s)))))))
  (let* {[f (file filename :write :create :truncate)]
         [syms (filter save? (sort (environment) <))]
         [data (apply nconc (map list syms (map top-level-value syms)))]}
    (with-bindings ((*print-pretty* T)
                    (*print-readably* T)
                    (*print-circle* T)
                    (that NIL))
      (write data f)
      (io-write f *linefeed*)
      (io-close f))))

(def (__init_globals)
  "Initialize globals that need to be set at load time."
  :doc-group vm
  (set! *exception-print-level* 3
        *exception-print-length* 64
        *linefeed* "\n"
        *exit-hooks* NIL
        *io-out* *stdout*
        *io-in* *stdin*
        *io-err* *stderr*
        *prompt* (if (equal? +os-name+ "macos")
                     (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
                     (λ () (princ "#;> ")))
        *directory-separator* (if (equal? +os-name+ "dos")
                                  "\\"
                                  "/")))

(def (__script path)
  "Execute a single file at `path`.

   An unhandled exception will result in it being printed to `*io-err*`
   and the process exiting with a non-zero (non-empty in case OS is Plan
   9) status signaling an error to its parent."
  :doc-group vm
  :doc-see __rcscript
  (trycatch (load path)
            (λ (e) (top-level-exception-handler e)
                   (exit (str e)))))

(def (__rcscript)
  «Execute, if exists, the user's "run commands" file.

   The file path is predefined and depends on the OS:

    * `$home/lib/slrc` on Plan 9
    * `$HOME/.slrc` on other operating systems

   It is automatically loaded by StreetLISP when running in interactive
   mode.  The user may wish to use this file to change the look of the
   prompt, load additional functionality they want to use without having
   to do the process manually each time, and so on.»
  :doc-group vm
  :doc-see *prompt*
  :doc-see *interactive*
  (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")))
         (path (and home (str home *directory-separator* rcpath))))
    (and path (path-exists? path) (load path))))

(def (__start argv interactive)
  "The system boot image entry.

   This is the first function executed by the VM after initialization."
  :doc-group vm
  :doc-see __finish
  (__init_globals)
  (set! *argv* argv *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 fn)
  "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.

   The hook added last will be called first."
  :doc-group vm
  :doc-see *exit-hooks*
  (set! *exit-hooks* (cons fn *exit-hooks*))
  (void))

(defdoc *exit-hooks*
  "Internal variable, a list containing functions to call right before VM
   process exits."
  :doc-group vm
  :doc-see add-exit-hook)

(def (__finish status)
  "A function called right before exit by the VM.

   The exit `status` is either `NIL` or a string referring to an error
   condition."
  :doc-group vm
  :doc-see __start
  (when (bound? '*exit-hooks*)
    (for-each (λ (f) (f status)) *exit-hooks*)))