;;;; 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 defmacro
  :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 in this table.»
    :doc-group prop
    (table)))

(def (putprop symbol key val)
  «Associate a property with the symbol, return the value.»
  :doc-example
  «(def x '(1 2 3))
   (putprop x 'words "one two three")
   ; ↳ "one two three"
   (getprop x 'words)
   ; ↳ "one two three"»
  :doc-group prop
  :doc-see getprop
  :doc-see remprop
  (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,
   exception `key-error` will be thrown.»
  :doc-example
  «(def x '(1 2 3))
   (putprop x 'words "one two three")
   ; ↳ "one two three"
   (getprop x 'words)
   ; ↳ "one two three"
   (getprop x 'huh)
   ; ‼ key not found: huh
   (getprop x 'huh "fallback")
   ; ↳ "fallback"»
  :doc-group prop
  :doc-see putprop
  :doc-see remprop
  (let ((kt (get *properties* key NIL)))
    (if def-supplied?
        (or (and kt (get kt symbol def)) def)
        (if (and kt (has? kt symbol))
            (get kt symbol)
            (raise (list 'key-error key))))))

(def (remprop symbol key)
  «Remove a property associated with the symbol.

   Returns `T` if the property was removed, `NIL` if there was no
   such association defined for the symbol.»
  :doc-example
  «(def x '(1 2 3))
   (putprop x 'words "one two three")
   ; ↳ "one two three"
   (remprop x 'unknown) ; no such association
   ; ↳ NIL
   (getprop x 'words NIL)
   ; ↳ "one two three"
   (remprop x 'words)
   ; ↳ T
   (getprop x 'words NIL)
   ; ↳ NIL»
  :doc-group prop
  :doc-see getprop
  :doc-see putprop
  (let ((kt (get *properties* key NIL)))
    (and kt (has? kt symbol) (del! kt symbol) T)))

;;; 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))
  (def (maybe-lambda t)
    (if (and (cons? t) (eq? (car t) 'λ) (cons? (cadr t)))
        (compile t)
        t))
  (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 (maybe-lambda (car tl)))
                                         doc))]
          [else (cons (reverse doc) body)])))

(def (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)))))
  (def (trim-indent s)
    (unless (and (bound? 'str-trim) (bound? 'str-join))
      (return s))
    (let* {[lines (str-split s "\n")]
           [hd (car lines)]
           [tl (cdr lines)]
           [indent (and tl (apply min (map (λ (s) (and (> (length s) 0)
                                                       (- (length s) (length (str-trim s)))))
                                           tl)))]
           [trimmed (and tl
                         (map (λ (s) (if (<= indent (length s))
                                         (str-sub s indent)
                                         s))
                              tl))]}
      (str-join (cons hd trimmed) "\n")))
  (def (extra-clean e)
    (unless (and (cons? e) (str? (cdr e)))
      (return e))
    (set-cdr! e (trim-indent (cdr e))))
  (let* {[doc-only (str? doc-seq)]
         [doc (if doc-only doc-seq (car doc-seq))]
         [extra (if doc-only NIL (map extra-clean (cdr doc-seq)))]
         [formals-list (map formals-clean formals-list)]}
    (when doc
      (putprop symbol '*doc* (trim-indent doc))
      (when extra (putprop symbol '*doc-extra* extra)))
    (when (cons? formals-list)
      (putprop symbol
               '*formals-list*
               (remove-duplicates [append (getprop symbol '*formals-list* NIL)
                                          formals-list])))
    #.(void)))

(def (help-print-header term sigs (:kind NIL) (:lpad ""))
  «Format and print signatures 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")]
           "]"))
  (def (term->str term)
    (with-output (b)
      (with-bindings ((*print-readably* T)
                      (*print-pretty* NIL))
        (write term b))))
  (if sigs
      (for-each (λ (sig)
                  (let* {[sug (term->str (cons term sig))]
                         [b (buffer)]
                         [sig (with-bindings ((*print-syntax-sugar* NIL))
                                (term->str (cons term sig)))]}
                    (princ lpad)
                    (princ sug)
                    (unless (equal? sug sig)
                      (princ " | " sig))
                    (print-type term)
                    (newline)))
                sigs)
      (princ lpad)
      (if kind
          (princ (caddr term) " ;; [doc group]")
          (print term)
          (print-type term))
      (newline))
  (newline))

(defmacro (help (topic NIL topic-supplied) (: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.

   Rune `↳` followed by an object appearing in the documentation describes
   the returned value. Rune `‼` follows by what is being written to the
   output or by an error raised.»
  :doc-example
  «(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 above
   (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* {[topic (if topic-supplied topic 'help)]
         [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) (or (bound? term) (get-syntax term)))]
         [buf-mode (io-buffer-mode *io-out*)]}
    (io-buffer-mode! *io-out* :block)
    (def (deunicode str)
      (if (member +os-name+ '("dos" "macos" "unknown"))
          (str-map (λ (r) (case r
                            (#\↳ "->")
                            (#\… "...")
                            (#\‼ "!!")
                            (#\λ "lambda")
                            (#\₀ #\0)
                            (#\₁ #\1)
                            (#\ₙ #\n)
                            (#\ᵢ #\i)
                            (else r)))
                   str)
          str))
    (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)] ; ends with
             [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)
      (with-bindings ((*print-syntax-sugar* NIL)
                      (*print-pretty* NIL))
        (if sigs
            (for-each (λ (sig) (newline)
                               (princ lpad)
                               (print (cons term sig)))
                      sigs)
            (newline)
            (princ lpad)
            (print term))))
    (def (princ-indent s lpad)
      (for-each (λ (line) (princ lpad line)
                          (newline))
                (str-split s "\n")))
    (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-pad (str (caddr k)) 10 :align :left)
                                (first-line (getprop k '*doc* NIL)))
                         (newline))
                  (table-keys-filter-sort (get *properties* '*doc*)
                                          doc-group?))
        (if (or doc formals-list)
            (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)]
                   [grp (filter (λ (v) (eq? (car v) :doc-group)) extra)]
                   [exa (filter (λ (v) (eq? (car v) :doc-example)) extra)]}
              (and print-header (print-header docterm formals-list :kind kind))
              (when doc
                (princ (deunicode (foldl (λ (fmt doc) ((cdr fmt) doc)) doc fmt)))
                (newline))
              (when exa
                (newline)
                (princ "Examples:")
                (newline)
                (for-each (λ (e) (newline)
                                 (princ-indent (deunicode (cdr e)) "    "))
                          exa))
              (when see
                (newline)
                (princ "See also:")
                (newline)
                (for-each (λ (v) (print-sig (cdr v)
                                            (getprop (cdr v) '*formals-list* NIL)
                                            "    "))
                          see)
                (newline))
              (when grp
                (newline)
                (princ "Groups:")
                (newline)
                (for-each (λ (g) (newline) (princ "    (help group " (cdr g) ")")) grp)
                (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))))
  (io-buffer-mode! *io-out* buf-mode)
  (io-flush *io-out*)
  (void)))

;; chicken & egg problem - need doc logic to define a doc group
(doc-group prop
  «Dealing with properties of symbols.»)

;;; 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?`.»
  :doc-example
  «(member 1 '(3 2 1 0))
   ; ↳ (1 0)»
  :doc-example
  «(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.»
  :doc-example
  «(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?`.»
  :doc-example
  «(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))))))

(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`.»
  :doc-example
  «(div 10 3)
   ; ↳ 3»
  :doc-example
  «(div -10 3)
   ; ↳ -4»
  :doc-example
  «(div -10 -3)
   ; ↳ 4»
  :doc-example
  «(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`.»
  :doc-example
  «(mod  10 3)
   ; ↳ 1»
  :doc-example
  «(mod -10 3)
   ; ↳ 2»
  :doc-example
  «(mod -10 -3)
   ; ↳ 2»
  :doc-example
  «(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`.»
  :doc-example
  «(mod0 10 3)
   ; ↳ 1»
  :doc-example
  «(mod0 -10 3)
   ; ↳ -1»
  :doc-example
  «(mod0 -10 -3)
   ; ↳ -1»
  :doc-example
  «(mod0 10 -3)
   ; ↳  1»
  :doc-group number
  :doc-see div0
  :doc-see mod
  (- a (* (div0 a n) n)))

(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.»
  :doc-example
  «(max 3 1 9 4)
   ; ↳ 9»
  :doc-example
  «(max 'c 'h 'z 'a)
   ; ↳ z»
  :doc-example
  «(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.»
  :doc-example
  «(min 3 1 9 4)
   ; ↳ 1»
  :doc-example
  «(min 'c 'h 'z 'a)
   ; ↳ a»
  :doc-example
  «(min "t" "g" "a")
   ; ↳ "a"»
  :doc-group compare
  :doc-see max
  (if rest
      (foldl (λ (a b) (if (< a b) a b))
             v
             rest)
      v))

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

(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.»
  :doc-example
  «(closure? closure?)
   ; ↳ T»
  :doc-example
  «(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`.»
  :doc-example
  «(defc*r caaaaaaaaddr)
   (caaaaaaaaddr '(0 1 (((((((2 3 4)))))))))
   ; ↳ 2»
  :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

(def (every pred lst)
  «Return `T` if the predicate is true for _every_ element of the list,
   `NIL` otherwise.»
  :doc-example
  «(every odd? '(1 3 5 7)) ; every number odd?
   ; ↳ T»
  :doc-example
  «(every (λ (s) (length> s 1)) ; every string longer than one rune?
     '("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.»
  :doc-example
  «(any even? '(1 3 5 7)) ; any even number?
   ; ↳ NIL»
  :doc-example
  «(any (λ (s) (length> s 1)) ; any string longer than one rune?
     '("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.»
  :doc-example
  «(proper-list? NIL) ; empty list
   ; ↳ T»
  :doc-example
  «(proper-list? '(1)) ; a list with one element
   ; ↳ T»
  :doc-example
  «(proper-list? '(1 . 2)) ; a pair, cdr of the cell is 2
   ; ↳ NIL»
  :doc-example
  «(proper-list? '#0=(1 . #0#)) ; on a circular list
   ; ↳ 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.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(append '(1) '(2 3) '(4))
   ; ↳ (1 2 3 4)»
  :doc-example
  «(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`.»
  :doc-example
  «(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.»
  :doc-example
  «(subseq "hello" 1 2)
   ; ↳ "e"»
  :doc-example
  «(subseq '(1 2 3) 0 2)
   ; ↳ (1 2)»
  :doc-example
  «(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.»
  :doc-example
  «(last-pair '(1 2 3))
   ; ↳ (3)»
  :doc-example
  «(last-pair '(1 2 . 3))
   ; ↳ (2 . 3)»
  :doc-group list
  :doc-see last-cdr
  (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.»
  :doc-example
  «(last-cdr '(1 2 3))
   ; ↳ NIL»
  :doc-example
  «(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.»
  :doc-example
  «(to-proper '(1 2))
   ; ↳ (1 2)»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «; 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
  :doc-see receive
  (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.»
  :doc-example
  «(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))) …]»
  :doc-example
  «(iterate 1+ 5 3)
   ; ↳ (5 6 7)»
  :doc-example
  «(iterate (λ (x) (* x x)) 2 5)
   ; ↳ (2 4 16 256 65536)»
  :doc-example
  «(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 . seqs)
  «Reduce the sequences to a single value by repeatedly applying the
   function right-associatively.

   The function should be of the form `(fn e₀ e₁ … eₙ acc)`. For each
   iteration each `eᵢ` will be set to successive values of the `i`-th
   sequence. The value `acc` will initially be set to `zero` and
   subsequently to the previous value of the function application.

   The iteration will terminate once the shortest sequence is exhausted.

   For example, for two sequences `(e₀ e₁ … eₙ)` and `(d₀ d₁ … dₙ)`, the
   result will be:

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

   Note that `foldr` is NOT tail call recursive.»
  :doc-example
  «(foldr cons NIL (iota 5))
   ; ↳ (0 1 2 3 4)»
  :doc-example
  «(foldr + 0 (iota 5))
   ; ↳ 10»
  :doc-example
  «(foldr (λ (x y a) (+ (* x y) a)) 0 (iota 5) (iota 5))
   ; ↳ 30»
  :doc-example
  «(foldr (λ (x y a) (cons x (cons y a))) NIL (iota 5) (vec 'a 'b 'c))
   ; ↳ (0 a 1 b 2 c)»
  :doc-group list
  :doc-see foldl
  :doc-see foldr1
  (let* {[argc (length seqs)]
         [argv (vec-alloc (1+ argc))]}
    (def (foldr- iter zero seqs)
      (def (copy-args idx seqs)
        (and seqs
          (let {[seq (car seqs)]}
            (aset! argv
                   idx
                   (cond ((or (vec? seq) (arr? seq))
                          (aref seq iter))
                         ((str? seq)
                          (str-rune seq iter))
                         (else (car seq))))
            (copy-args (1+ idx) (cdr seqs)))))
      (if (not (every (λ (seq)
                        (if (list? seq) seq (< iter (length seq))))
                      seqs))
          zero
          (aset! argv
                 argc
                 (foldr- (1+ iter)
                         zero
                         (map (λ (seq) (if (list? seq) (cdr seq) seq)) seqs)))
          (copy-args 0 seqs)
          (apply fn argv)))
    (foldr- 0 zero seqs)))

(def (foldl fn zero . seqs)
  «Reduce the sequences to a single value by repeatedly applying the
   function left-associatively.

   The function should be of the form `(fn e₀ e₁ … eₙ acc)`. For each
   iteration each `eᵢ` will be set to successive values of the `i`-th
   sequence. The value `acc` will initially be set to `zero` and
   subsequently to the previous value of the function application.

   The iteration will terminate once the shortest sequence is exhausted.

   For example, for two sequences `(e₀ e₁ … eₙ)` and `(d₀ d₁ … dₙ)`, the
   result will be:

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

   Note that `foldl` is tail call recursive.»
  :doc-example
  «(foldl cons NIL (iota 5))
   ; ↳ (4 3 2 1 0)»
  :doc-example
  «(foldl + 0 (iota 5))
   ; ↳ 10»
  :doc-example
  «(foldl (λ (x y a) (+ (* x y) a)) 0 (iota 5) (iota 5))
   ; ↳ 30»
  :doc-example
  «(foldl (λ (x y a) (cons x (cons y a))) NIL (iota 5) (vec 'a 'b 'c))
   ; ↳ (2 c 1 b 0 a)»
  :doc-group list
  :doc-see foldr
  :doc-see foldl1
  (let* {[argc (length seqs)]
         [argv (vec-alloc (1+ argc))]}
    (def (foldl- iter zero seqs)
      (def (copy-args idx seqs)
        (and seqs
          (let {[seq (car seqs)]}
            (aset! argv
                   idx
                   (cond ((or (vec? seq) (arr? seq))
                          (aref seq iter))
                         ((str? seq)
                          (str-rune seq iter))
                         (else (car seq))))
            (copy-args (1+ idx) (cdr seqs)))))
      (if (not (every (λ (seq)
                        (if (list? seq) seq (< iter (length seq))))
                      seqs))
          zero
          (aset! argv argc zero)
          (copy-args 0 seqs)
          (foldl- (1+ iter)
                  (apply fn argv)
                  (map (λ (seq) (if (list? seq) (cdr seq) seq)) seqs))))
    (foldl- 0 zero seqs)))

(def (foldl1 fn seq)
  «Same as `foldl` but using the first element of the sequence as the
   initial accumulator.»
  :doc-example
  «(foldl1 * (iota 6 1))
   ; ↳ 720»
  :doc-group list
  :doc-see foldl
  :doc-see foldr1
  (cond ((or (vec? seq) (arr? seq))
         (foldl fn (aref seq 0) (subseq seq 1)))
        ((str? seq)
         (foldl fn (str-rune seq 0) (subseq seq 1)))
        (else
         (foldl fn (car seq) (cdr seq)))))

(def (foldr1 fn seq)
  «Same as `foldr` but using the first element of the sequence as the
   initial accumulator.»
  :doc-example
  «(foldr1 + (iota 10))
   ; ↳ 45»
  :doc-group list
  :doc-see foldr
  :doc-see foldl1
  (cond ((or (vec? seq) (arr? seq))
         (foldr fn (aref seq 0) (subseq seq 1)))
        ((str? seq)
         (foldr fn (str-rune seq 0) (subseq seq 1)))
        (else
         (foldr fn (car seq) (cdr seq)))))

(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.»
  :doc-example
  «(def a '(1 2 3))
   (reverse a)
   ; ↳ (3 2 1)
   a
   ; ↳ (1 2 3) ; original list preserved»
  :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.»
  :doc-example
  «(def a '(1 2 3))
   (reverse! a)
   ; ↳ (3 2 1)
   a
   ; ↳ (1) ; original list modified»
  :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.»
  :doc-example
  «(def a '(4 5 6))
   (revappend a '(3 2 1))
   ; ↳ (6 5 4 3 2 1)
   a
   ; ↳ (4 5 6) ; original list preserved»
  :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.»
  :doc-example
  «(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 sub-elements of the list
   recursively.»
  :doc-example
  «(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 (remove-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.»
  :doc-example
  «(remove-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))

(def (zip-with fn . lst)
  «Return a list where each nth element is the result of the supplied
   function applied to the corresponding elements from the parameter lists.

   The resulting list is as long as the shortest of the arguments.»
  :doc-example
  «(zip-with + '(1 2 3))
   ; ↳ (1 2 3)»
  :doc-example
  «(zip-with + '(1 2 3 4) '(5 6 7) '(8 9 10 11))
   ; ↳ (14 17 20)»
  :doc-group list
  :doc-see zip
  (apply map fn lst))

(def (zip . lst)
  «Return a list where each nth element is a list of the corresponding
   elements from the parameter lists.

   The resulting list is as long as the shortest of the arguments.»
  :doc-example
  «(zip '(1 2 3))
   ; ↳ ((1) (2) (3))»
  :doc-example
  «(zip '(1 2 3 4) '(5 6 7) '(8 9 10 11))
   ; ↳ ((1 5 8) (2 6 9) (3 7 10))»
  :doc-group list
  :doc-see zip-with
  (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`.»
  :doc-example
  «(map-int even? 5)
   ; ↳ (T NIL T NIL T)»
  :doc-example
  «(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)»
  :doc-example
  «(iota 4)
   ; ↳ (0 1 2 3)»
  :doc-example
  «(iota 4 6)
   ; ↳ (6 7 8 9)»
  :doc-example
  «(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.»
  :doc-example
  «; simple sort (note: symbols > numbers)
   (sort '(1a 1 0 2b e 3) <)
   ; ↳ (0 1 3 1a 2b e)»
  :doc-example
  «; sort in lexicographical order (as strings)
   (sort '(1a 1 0 2b e 3) < :key str)
   ; ↳ (0 1 1a 2b 3 e)»
  :doc-example
  «; 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.»
  :doc-example
  «'(0 1 (+ 2 3))
   ; ↳ (0 1 (+ 2 3))»
  :doc-group syntax
  :doc-see quasiquote
  :doc-see unquote)

(defmacro (quasiquote expr)
  «Same as `'expr` but allows evaluating ("unquoting") parts of
   the expression.»
  :doc-example
  «`(0 1 (+ 2 3))
   ; ↳ (0 1 (+ 2 3))»
  :doc-group syntax
  :doc-see quote
  :doc-see unquote
  (bq-process expr 0))

(defmacro (unquote expr)
  «Evaluate the expression, which is a part of a quasi-quoted expression
   itself, and insert it at the location.»
  :doc-example
  «`(0 1 ,(+ 2 3))
   ; ↳ (0 1 5)»
  :doc-group syntax
  :doc-see quasiquote expr
  :doc-see unquote-splicing
  :doc-see unquote-nsplicing
  (cons 'unquote expr))

(defmacro (unquote-splicing expr)
  «Evaluate the expression, which is a part of a quasi-quoted expression
   itself, and "splice" it at the location.»
  :doc-example
  «(def x '(1 2 3))
   `(0 1 ,.(map 1+ x))
   ; ↳ (0 1 2 3 4)»
  :doc-group syntax
  :doc-see unquote
  :doc-see unquote-nsplicing
  (cons 'unquote-splicing expr))

(defmacro (unquote-nsplicing expr)
  «Evaluate the expression, which is a part of a quasi-quoted expression
   itself, and "splice" it at the location.

   Unlike `unquote-splicing`, this macro may operate destructively
   on the list produced.»
  :doc-example
  «(def x '(1 2 3))
   `(0 1 ,.(map 1+ x))
   ; ↳ (0 1 2 3 4)»
  :doc-group syntax
  :doc-see unquote
  :doc-see unquote-splicing
  (cons 'unquote-nsplicing 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.»
  :doc-example
  «; write a string "hello, world!" and a newline to a file
   (with-output-to (file "/tmp/1.txt" :create :truncate :write)
     (print "hello, world!")
     (newline))»
  :doc-group io
  :doc-see with-input-from
  :doc-see with-output
  `(with-bindings ((*io-out* ,io))
                  ,.body))

(defdoc (with-output (var) . body))
(defdoc (with-output (var io) . body)
  «Evaluate expressions in `body` with `var` bound to `io` during the
   evaluation.

   If expression `io` was not specified (first form), `var` will point
   to a new in-memory buffer and the resulting contents will be returned
   as a string.

   With the second form the result of the last expression in the `body`
   will be returned instead.»
  :doc-example
  «(with-output (s) (write "hello" s))
   ; ↳ "\"hello\""»
  :doc-example
  «(def b (buffer))
   (with-output (s b) (io-write s "hello"))
   ; ↳ 5
   (length b)
   ; ↳ 5»
  :doc-group io
  :doc-see with-output-to)

(defmacro (with-output var+io . body)
  (let {[var (car var+io)]
        [io (cadr var+io)]}
    (if io
        `(let {[,var ,io]}
           ,.body)
        `(let {[,var (buffer)]}
           (unwind-protect (begin ,.body
                                  (io->str ,var))
                           (io-close ,var))))))

(defmacro (with-input args . body)
  `(let {[,(car args) (buffer ,.(cdr args))]}
     (unwind-protect (begin ,.body)
                     (io-close ,(car args)))))

(defdoc (with-input (var expr (:start NIL) (:end NIL)) . body)
  «Evaluate expressions in `body` with `var` bound to a readable buffer
   containing the result of the expression during the evaluation.

   Optionally, the range of the data (measured in bytes) available
   when accessing the buffer may be limited by using `:start` and/or
   `:end` keyworded arguments.

   The result returned will be that of the last expression in the `body`.»
  :doc-example
  «(with-input (s «x"blah"x\» :start 1 :end 7)
     (read s))
   ; ↳ "blah"»
  :doc-group io
  :doc-see with-output-to
  :doc-see buffer)

(defmacro (with-input-from io . body)
  «Evaluate expressions in `body` with `*io-in*` set to `io` during the
   evaluation.»
  :doc-example
  «; read a single expression from a file and print it
   (with-input-from (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.»
  :doc-example
  «(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
      (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.»
  :doc-example
  «(and)
   ; ↳ T»
  :doc-example
  «(and 1 2 (print 'yes) 3)
   ; ‼ yes
   ; ↳ 3»
  :doc-example
  «(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.»
  :doc-example
  «(or)
   ; ↳ NIL»
  :doc-example
  «(or 1 2 (print 'first) (print 'second) 3)
   ; ↳ 1»
  :doc-example
  «(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`.»
  :doc-example
  «(for 0 2 (λ (i) (print i)))
   ; ‼ 01»
  :doc-group syntax
  :doc-see dotimes
  :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` macro (see `(help defdoc)`).

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

   If the name of the definition starts and ends with a plus sign (`+a-symbol+`),
   the binding becomes constant. Trying to modify it will raise an error unless
   the new value is equivalent and is of the same type. Note, non-leaf types such
   tables, strings, arrays, and vectors assigned to the name can still be modified
   themselves - the value is not constant itself, only the binding.»
  :doc-example
  «; a function with documentation (first form)
   (def (f x)
     «Return the square of doubled `x`.\»
     :doc-example
     «(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»
  :doc-example
  «; a variable (second form)
   (def x (length "hello"))
   x
   ; ↳ 5»
  :doc-group syntax
  :doc-see defdoc
  :doc-see set!
  :doc-see let)

(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.»
  :doc-example
  «(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!
  :doc-see let
  (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.»
  :doc-example
  «(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 code style.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(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
   expression.»
  :doc-example
  «(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`.»
  :doc-example
  «(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`.»
  :doc-example
  «(trycatch (+ 1 2) (λ (e) e))
   ; ↳ 3»
  :doc-example
  «(trycatch (+ 1 NIL) (λ (e) e))
   ; ↳ (type-error num NIL)»
  :doc-group syntax
  :doc-see catch
  :doc-see unwind-protect
  (list '$trycatch try catch))

(letrec {[bind-name (λ (bind)
                      (if (cons? bind)
                          (car bind)
                          bind))]
         [any-duplicates (λ (binds)
                           (let {[k (car binds)]
                                 [rest (cdr binds)]}
                             (when rest
                               (or (any (λ (next) (and (eq? (bind-name k)
                                                            (bind-name next)) k))
                                        rest)
                                   (any-duplicates rest)))))]
         [bind-value (λ (b) (let {[name (bind-name b)]}
                       (unless (and (sym? name) (not (keyword? name)))
                         (compile-error "invalid identifier: " name))
                       (unless (or (sym? b) (length= b 2))
                         (compile-error "invalid binding: " b))
                       (if (sym? b)
                           #.(void)
                           (cadr b))))]}
  (defmacro (letrec binds . body)
    «Same as the first form of `let` but each of the binding
     expressions may reference any of the variables bound, before
     or after.

     If a binding consists of a variable name alone, its value is
     set to `#<void>`.»
    :doc-example
    «(letrec ((a (λ () 1))
              (b (λ () (+ (c) 1)))
              (c (λ () (+ (a) 1)))
              d)
       (list (a) (b) (c) (void? d)))
     ; ↳ (1 3 2 T)»
    :doc-group syntax
    :doc-see let
    :doc-see let*
    (unless (cons? body)
      (arg-error "missing body"))
    (let {[dup (any-duplicates binds)]}
      (when dup (compile-error "duplicate identifier: " (bind-name dup))))
    `((λ ,(map bind-name binds)
        ,.(map (λ (b) `(set! ,(bind-name b) ,(bind-value b))) binds)
        ,.body)
      ,.(map void binds)))

  (defmacro (let* binds . body)
    «Same as the first form of `let` but each of the binding
     expressions may reference any of the variables bound previously.

     If a binding consists of a variable name alone, its value is
     set to `#<void>`.»
    :doc-example
    «(let* ((a 1)
            (b (+ a 1))
            (c (+ b 1))
            d)
       (cons c (void? d)))
     ; ↳ (3 . T)»
    :doc-group syntax
    :doc-see let
    :doc-see letrec
    (unless (cons? body)
      (arg-error "missing body"))
    (let {[first (car binds)]
          [rest (cdr binds)]}
      `((λ (,(bind-name first))
          ,.(if (cons? rest)
                `((let* ,rest ,.body))
                body))
        ,(bind-value first))))

  (defmacro (let binds . body)
    (let ((lname NIL))
      (when (sym? binds)
        (set! lname binds
              binds (car body)
              body (cdr body)))
    (unless (cons? body)
      (arg-error "missing body"))
      (let* {[thelambda
              `(λ ,(map (λ (c) (if (cons? c) (car c) c))
                        binds)
                 ,.body)]
             [dup (any-duplicates binds)]
             [theargs (map bind-value binds)]}
        (when dup
          (compile-error "duplicate identifier: " (bind-name dup)))
        (cons (if lname
                  `(letrec ((,lname ,thelambda)) ,lname)
                  thelambda)
              theargs)))))

(defdoc (let binds . body)
  «Bind variables and execute a series of expression that use
   these bindings, return the result of the last expression.

   If a binding in the first form consists of a variable name alone,
   its value is set to `#<void>`.

   The second form `(let id ((… ) …) …)`, which is called
   "named let", allows referencing the resulting lambda within
   the expressions following the bindings to aid with recursive
   calls.»
  :doc-example
  «(let ((a 123) (b 456) c)   ; first form
     (cons (+ a b) (void? c)))
   ; ↳ (579 . T)»
  :doc-example
  «(let loop ((a (iota 3 1))) ; second form
     (when a
       (princ (car a))
       (loop (cdr a))))
   ; ‼ 123
   ; ↳ NIL»
  :doc-group syntax
  :doc-see let*
  :doc-see letrec)

(defdoc (let id binds . body))

(defmacro (cond . clauses)
  «Select one of the clauses by evaluating the condition, evaluate the
   accompanied expressions for the matching clause and return the result.

   Different clause form variants are available. The most common is
   `(test then…)`, which gives the result of `then…` if `test` did not
   evaluate to `NIL`. Second form, `(test)`, which gives the result
   of `test` unless it's `NIL`. Third form, `(test => fn)`, calls `fn`
   with a single argument which is the non-`NIL` result of evaluating
   `test`.

   The special `else` clause condition, if specified, is used as a fallback
   if none of the other conditions were satisfied. If none were satisfied
   _and_ `else` was not provided, `NIL` is returned.»
  :doc-example
  «(def x 8)
   (cond ((sym? x) "symbol")
         ((str? x) "string")
         ((+ x 1) => sqrt))
   ; ↳ 3.0»
  :doc-example
  «(def x "hello")
   (cond ((sym? x) 0)
         ((length x)))
   ; ↳ 5»
  :doc-example
  «(def x 0)
   (case ((positive? x) 10)
         ((negative? x) -10)
         (else 'oops))
   ; ↳ oops»
  :doc-group syntax
  :doc-see case
  (def (1arg-lambda? func)
    (and (cons? func)
         (eq? (car func) 'λ)
         (cons? (cadr func))
         (length= (cadr func) 1)))
  (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 expr . clauses)
  «Evaluate an expression, select one of the clauses by matching
   the result with `eqv?`, and return the result of the clause.

   The special `else` clause matching expression, if specified, is
   used as a fallback if none of the clauses matched the result.
   If no `else` was specified and no matches occurred, `NIL` is
   returned.»
  :doc-example
  «(case 'c ; match present
     (a 0)
     ((b c d) 1))
   ; ↳ b»
  :doc-example
  «(case (+ 1 2) ; no matches, with else
     (a 0)
     (b 1)
     (else (print 'yay)
           (newline))
   ; ‼ yay»
  :doc-example
  «(case "c" ; no matches, without else
     ("a" 0)
     ("b" 1))
   ; ↳ NIL»
  :doc-group syntax
  :doc-see cond
  (def (quote-value v)
    (if (self-evaluating? v)
        v
        (list '$quote v)))
  (def (vals->cond expr v)
    (cond ((eq? v 'else)  'else)
          ((not v)        NIL)
          ((sym? v)       `(eq?  ,expr ,(quote-value v)))
          ((atom? v)      `(eqv? ,expr ,(quote-value v)))
          ((not (cdr v))  `(eqv? ,expr ,(quote-value (car v))))
          ((every sym? v) `(memq ,expr ',v))
          (else           `(memv ,expr ',v))))
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (cond ,.(map (λ (clause)
                      (cons (vals->cond g (car clause))
                            (cdr clause)))
                    clauses)))))

(defmacro (do vars test-spec . commands)
  «Run `commands` sequentially in a loop until the test condition
   evaluates to `NIL`.

   Each variable in `vars` consists of the variable's name, its
   initial value and (optionally) a single "step" expression:

       (var-name init-value step-expr)

   Loop test condition and (optionally) the result expression are
   contained within `test-spec`:

       (test-cond result-exprs)

   Loop runs as long as `test-cond` evaluates to `NIL`. If `test-cond`
   is satisfied (result is not `NIL`), loop is terminated and either
   the result of `result-exprs` is returned or, if `result-exprs` isn't
   supplied, `#<void>` is used instead.

   After each loop run, every variable containing a step expression
   gets updated to the result of that expression, which may reference
   the variable by its name.»
  :doc-example
  «(do ((x 0 (+ x 1))) ; x=0 at first, x=x+1 after each step
     ((> (sin x) 0.95) ; loop until sin(x) > 0.95
      (newline)        ; print a linefeed when loop terminates
      x)               ; return final value of x
     (princ x))        ; print x on each step
   ; ‼ 01234567
   ; ↳ 8»
  :doc-group syntax
  :doc-see for
  :doc-see while
  (let ((test-expr (car test-spec))
        (vars  (map car  vars))
        (inits (map cadr vars))
        (steps (map (λ (x)
                      (if (cons? (cddr x))
                          (if (cdddr x)
                              (compile-error "invalid step-expr: " (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)
  «Capture multiple-return values into the given identifiers and
   evaluate the body.»
  :doc-example
  «(receive (a b c) (values 1 2 3) b)
   ; ↳ 2»
  :doc-example
  «(receive (odd even) (partition odd? '(0 1 2 3 4 5))
     (map cons odd even))
   ; ↳ ((1 . 0) (3 . 2) (5 . 4))»
  :doc-example
  «(receive (lst) '(1 2 3) (cadr lst))
   ; ↳ 2»
  :doc-group syntax
  :doc-see values
  :doc-see call-with-values
  `(call-with-values (λ () ,expr)
     (λ ,formals ,.body)))

(defdoc (values . v)
  «Return the supplied values as multiple-return values.»
  :doc-group syntax
  :doc-see call-with-values
  :doc-see receive)

(defdoc (call-with-values producer receiver)
  «Call `producer` and pass the values produced as arguments to
   `receiver`.»
  :doc-example
  «(call-with-values (λ () (values 1 2 3))
                     (λ (a b c) b))
   ; ↳ 2»
  :doc-example
  «(call-with-values (λ () (list 1 2 3))
                     (λ (lst) (cadr lst)))
   ; ↳ 2»
  :doc-group syntax
  :doc-see receive
  :doc-see values)

(defmacro (dotimes var . body)
  «Execute expressions in a loop the specified number of times.

   The argument `var` defines the loop variable name, the iteration
   count and (optionally) the resulting expression to evaluate and
   return the value of:

       (var-name count (result-expr #<void>))

   If `result-expr` is not specified, `#<void>` is used instead.

   The variable is incremented by `1` after each iteration, with its
   initial value set to `0`, and may be referenced in expressions of
   the `body`.»
  :doc-example
  «(dotimes (x 3 "heh")
     (print x)
     (newline))
   ; ‼ 0
   ; ‼ 1
   ; ‼ 2
   ; ↳ "heh"»
  :doc-group syntax
  :doc-see for
  :doc-see while
  (let* {[v   (car var)]
         [cnt (aref var 1)]
         [nv  (length var)]
         [res (if (= nv 3) (aref var 2) #.(void))]}
    (unless (<= nv 3)
      (compile-error "invalid var expression: " var))
    `(begin (for 0 ,cnt (λ (,v) ,.body))
            ,res)))

(defmacro (with-bindings binds . body)
  «Evaluate expressions with the values of the specified variables
   overridden for the duration of the evaluation.»
  :doc-example
  «(def (s) (str *print-base* #\. *print-radix* #\. 123))
   (s)
   ; ↳ "10.NIL.123"
   (with-bindings ((*print-base* 16)
                   (*print-radix* T))
     (s))
   ; ↳ "#x10.T.#x7B"
   (s)
   ; ↳ "10.NIL.123"»
  :doc-group syntax
  :doc-see def
  :doc-see let
  :doc-see set!
  (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))))))

;;; reader macros

(def (get-reader-macro s (rt *read-table*))
  (when (rune? s)
    (set! s (str s)))
  (let {[t (foldl (λ (r t) (and t (get t r NIL)))
                  rt
                  s)]}
    (and (table? t) (cdr (get t NIL NIL)))))

(def (set-reader-macro! s fn (rt *read-table*))
  (when (rune? s)
    (set! s (str s)))
  (put! (foldl (λ (r this) (let {[next (get this r (table))]}
                             (put! this r next)
                             next))
               rt
               s)
        NIL
        (and fn (cons s fn)))
  #.(void))

;;; exceptions

(def (error . msg)
  «Raise an error.»
  :doc-example
  «(error "oops: " 123)
   ; ‼ error: oops: 123»
  :doc-example
  «(trycatch (error 0 "oops" 'extra) identity)
   ; ↳ (error "oops" 0 extra)»
  :doc-group error
  (raise (cons 'error msg)))

(def (arg-error . msg)
  «Raise an argument error exception.»
  :doc-example
  «(arg-error "stuff" "?")
   ; ‼ arguments error: stuff?»
  :doc-example
  «(trycatch (arg-error "stuff: " "blah") identity)
   ; ↳ (arg-error "stuff: " "blah")»
  :doc-group error
  (raise (cons 'arg-error msg)))

(def (type-error expected-type got-value . msg)
  «Raise a type error exception.»
  :doc-example
  «(type-error 'num "hello")
   ; ‼ type error: expected num, got str: "hello"»
  :doc-example
  «(type-error 'num "hello" "more" "text")
   ; ‼ type error: more: text: expected num, got str: "hello"»
  :doc-example
  «(trycatch (type-error 'num "hello" "extra") identity)
   ; ↳ (type-error num "hello" "extra")»
  :doc-group error
  (raise (list* 'type-error expected-type got-value msg)))

(def (bounds-error seq index . msg)
  «Raise a bounds error exception.»
  :doc-example
  «(bounds-error '(1) 1 "oops")
   ; ‼ out of bounds: oops: index 1 for (1)»
  :doc-example
  «(trycatch (bounds-error NIL 0 "oops") identity)
   ; ↳ (bounds-error NIL 0 "oops")»
  :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 handled directly with `catch`,
   see `(help catch)`.»
  :doc-example
  «(throw 'blah "oops")
   ; ‼ *** unhandled exception: (thrown-value blah "oops")»
  :doc-example
  «(trycatch (throw 'blah "oops") identity)
   ; ↳ (thrown-value blah "oops")»
  :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-example
  «(catch 'some (/ 1 1))
   ; ↳ 1»
  :doc-example
  «(catch 'some (throw 'some "oops"))
   ; ↳ "oops"»
  :doc-example
  «(catch 'some (throw 'other "oops"))
   ; ‼ *** unhandled exception: (thrown-value other 0)»
  :doc-group error
  :doc-see trycatch
  :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.»
  :doc-example
  «(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

(defmacro (assert expr)
  «Throw an exception if `expr` evaluates to `NIL`.  Return `T` in any
   other case.»
  :doc-example
  «(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.»
  :doc-example
  «(def s "abc")
   (assert-fail (= (length s) 3))
   ; ‼ assertion failed: ...
   (assert-fail (= s 1) type-error)
   ; ↳ T»
  :doc-group debug
  :doc-see assert
  (def (type e)
    (let* {[loc (and (list? e)
                     (list? (car e))
                     (io? (caar e))
                     (car e))]
           [e (if loc (cdr e) e)]}
      (and e (cons? e) (sym? (car e)) (car e))))
  `(assert (trycatch (begin ,expr NIL)
                     (λ (e) ,(if what
                                 `(eq? (,type e) ',(car what))
                                 T)))))

(def (traced? fn)
  «Return `T` if the tracing is enabled for the function, `NIL`
   otherwise.»
  :doc-example
  «(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*`.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(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#) 1000000000) "s" *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`.»
  :doc-example
  «(print 1 2 "abc")
   ; ‼ 1 2 "abc"»
  :doc-group io
  :doc-see princ
  (when args
    (let {[a (car args)]
          [d (cdr args)]}
      (with-bindings ((*print-readably* T))
        (write a)
        (for-each (λ (e) (princ " ") (write e))
                  d))))
  #.(void))

(def (princ . args)
  «Print the arguments to `*io-out*` with `*print-readably*` set to `NIL`.»
  :doc-example
  «(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 linefeed 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 linefeed character is included in the returned value unless EOF
   has been reached beforehand.

   EOF (`#<eof>`) is returned if the IO object had no data.»
  :doc-example
  «; read one line from the kernel messages file
   (io-read-line (file "/dev/kmesg"))
   ; ↳ "127 holes free\n"»
  :doc-example
  «; /dev/null has no data - EOF is returned
   (eof? (io-read-line (file "/dev/null")))
   ; ↳ T»
  :doc-group io
  :doc-see eof?
  :doc-see io-read-lines
  (io-read-until io #\linefeed)) ; FIXME read until *linefeed* instead?

(def (read-all-of fn io)
  «Return the list containing the values returned by call `(fn io)` repeated
   until the IO object runs out of data.»
  :doc-group io
  :doc-see read-all
  :doc-see io-read-lines
  (let loop ((lines NIL)
             (curr (fn io)))
    (if (eof? 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.»
  :doc-example
  «; 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 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.»
  :doc-example
  «; 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
  (with-output (b)
    (io-copy b io)))

(def (read-all io)
  «Return a list of terms read from the IO object until it ran out of
   data.»
  :doc-example
  «; 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.»
  :doc-example
  «(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.»
  :doc-example
  «(vec->list #(1 2 a))
   ; ↳ (1 2 a)»
  :doc-group list
  :doc-see list->vec
  (apply list vc))

;;; table functions

(def (table->assoc-list ta)
  «Return the table converted to an association list (pairs of each
   key and value).»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «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.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(num->str 65535 :base 16)
   ; ↳ "FFFF»
  :doc-example
  «(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]}
    (with-output (b)
      (write n 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.»
  :doc-example
  «(str-trim " \nhello\t\v")
   ; ↳ "hello"»
  :doc-example
  «(str-trim " \nhello\t\v"
             (λ (r) (str-find " \v" r)))
   ; ↳ "\nhello\t"»
  :doc-example
  «(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.»
  :doc-example
  «(str-map rune-upcase
            "hello, world!")
   ; ↳ "HELLO, WORLD!"»
  :doc-example
  «(str-map (λ (r) (str r r))
            "hello")
   ; ↳ "hheelllloo"»
  :doc-example
  «(str-map (λ (r) (and (not (rune-whitespace? r)) r))
            "! this is great !")
   ; ↳ "!thisisgreat!"»
  :doc-group string
  (with-output (b)
    (let {[n (length s)]
          [i 0]}
      (while (< i n)
        (let {[r (fn (str-rune s i))]}
          (when r
            (io-write b r)))
        (set! i (1+ i))))))

(def (str-rep term k)
  «Return the concatenation of the `term` formatted as a string, repeated
   `k` times.»
  :doc-example
  «(str-rep "oi" 3)
   ; ↳ "oioioi"»
  :doc-example
  «(str-rep #\ы 5)
   ; ↳ "ыыыыы"»
  :doc-example
  «(str-rep 'a 3)
   ; ↳ "aaa"»
  :doc-example
  «(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-pad s n (:align :left) (:fill #\space))
  «Return the string padded until the given length.

   By default the string is padded with spaces on the right.»
  :doc-example
  «(str-pad "abc" 7)
   ↳ "abc    "»
  :doc-example
  «(str-pad "abc" 7 :align :center :fill #\.)
   ↳ "..abc.."»
  :doc-group string
  (let* {[w (str-width s)]
         [p (div0 (- n w) (str-width fill))]}
    (if (<= p 0)
        s
        (case align
          (:left (str s (str-rep fill p)))
          (:right (str (str-rep fill p) s))
          (:center (let* {[l (div0 p 2)]
                          [r (- p l)]}
                     (str (str-rep fill l) s (str-rep fill r))))
          (else (arg-error "invalid alignment: " align))))))

(def (print-to-str . args)
  «Same as `(print …)` but the result is returned as a string instead.»
  :doc-example
  «(print-to-str 1 2 3)
   ↳ "1 2 3"»
  :doc-group io
  :doc-see princ-to-str
  (with-output (s)
    (with-output-to s
      (apply print args))))

(def (princ-to-str . args)
  «Same as `(princ …)` but the result is returned as a string instead.»
  :doc-example
  «(princ-to-str 1 2 3)
   ↳ "123"»
  :doc-group io
  :doc-see print-to-str
  (with-output (s)
    (with-output-to s
      (apply princ args))))

(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.»
  :doc-example
  «(str-join '("" "n" "9" "heh")
             *directory-separator*)
   ; ↳ "/n/9/heh"»
  :doc-example
  «(str-join '("a" "b" "c") #\.)
   ; ↳ "a.b.c"»
  :doc-group string
  :doc-see str-split
  (if (not strlist)
      ""
      (with-output (b)
        (io-write b (car strlist))
        (for-each (λ (s) (io-write b sep)
                         (io-write b s))
                  (cdr strlist)))))

;;; 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
    (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.»
  :doc-example
  «(macrocall? '(car NIL))
   ; ↳ NIL»
  :doc-example
  «(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.»
  :doc-example
  «(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.»
  :doc-example
  «(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
                (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
            (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.»
  :doc-example
  «(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 (eval eval))
  «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.»
  :doc-example
  «(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.»
  :doc-example
  «(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.»)

(defmacro (with-exception-bindings . body)
  «Bind `*print-…` variables to their `*exception-print-…` counterparts
   evaluate the body.»
  :doc-group error
  :doc-see *exception-print-level*
  :doc-see *exception-print-length*
  `(with-bindings ((*print-level* *exception-print-level*)
                   (*print-length* *exception-print-length*))
     ,.body))

(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) "λ"))))
  (with-exception-bindings
    (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)`.»
  :doc-example
  «(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-exception-bindings
      (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 "out of bounds: ")
           (for-each (λ (s) (princ s ": ")) (cddr a))
           (princ "index " (cadr a) " 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 ")
           (let {[n (car a)]
                 [c (cadr a)]
                 [r (caddr a)]}
             (case r
                   [:min (princ n " or more")]
                   [:max (princ n " or less")]
                   [:extra (princ " no extra")]
                   [else (princ n)])
             (princ ", got " (if (zero? c) "none" c)))
           (when (cdddr a)
             (princ ": ")
             (apply print-value (cdddr a))))

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

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

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

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

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

          (else (princ "*** unhandled exception: ")
                (print-value 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 (<= '*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-close f))))

(def (__init_globals)
  «Initialize globals that need to be set at load time.»
  :doc-group vm
  (set! *exception-print-level* 8
        *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 (member +os-name+ '("dos" "windows"))
                                  "\\"
                                  "/")))

(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 (with-exception-bindings (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 a 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 `NIL` on success or a string describing the 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 the error
   condition.»
  :doc-group vm
  :doc-see __start
  (when (bound? '*exit-hooks*)
    (for-each (λ (f) (f status)) *exit-hooks*)))