ref: dc4a648a71627db05ba1c24557c0ab7f80d348ed
dir: /src/system.lsp/
; StreetLISP standard library
; by Jeff Bezanson (C) 2009
; Distributed under the BSD License
;;; void
(def (void . rest)
"Return the constant `#<void>` while ignoring any arguments.
`#<void>` is mainly used when a function has side effects but does not
produce any meaningful value to return, so even though `T` or `NIL` could
be returned instead, in case of `#<void>` alone, REPL will not print
it."
#.(void))
(def (void? x)
"Return `T` if `x` is `#<void>`, `NIL` otherwise."
(eq? x #.(void)))
;;; syntax environment
(unless (bound? '*syntax-environment*)
(def *syntax-environment* (table)))
(def (set-syntax! s v)
(put! *syntax-environment* s v))
(def (get-syntax s)
(get *syntax-environment* s nil))
(defmacro (defmacro form . body)
(let ((doc (value-get-doc body)))
(when doc
(sym-set-doc (car form) doc (cdr form))
(set! body (cdr body)))
`(void (set-syntax! ',(car form)
(λ ,(cdr form) ,@body)))))
(defmacro (letrec binds . body)
`((λ ,(map car binds)
,.(map (λ (b) `(set! ,@b)) binds)
,@body)
,.(map void binds)))
(defmacro (let binds . body)
(let ((lname nil))
(when (sym? binds)
(set! lname binds)
(set! binds (car body))
(set! body (cdr body)))
(let ((thelambda
`(λ ,(map (λ (c) (if (cons? c) (car c) c))
binds)
,@body))
(theargs
(map (λ (c) (if (cons? c) (cadr c) (void)))
binds)))
(cons (if lname
`(letrec ((,lname ,thelambda)) ,lname)
thelambda)
theargs))))
(defmacro (cond . clauses)
(def (cond-clauses->if lst)
(if (atom? lst)
nil
(let ((clause (car lst)))
(if (or (eq? (car clause) 'else)
(eq? (car clause) t))
(if (not (cdr clause))
(car clause)
(cons 'begin (cdr clause)))
(if (not (cdr clause))
; test by itself
(list 'or
(car clause)
(cond-clauses->if (cdr lst)))
; test => expression
(if (eq? (cadr clause) '=>)
(if (1arg-lambda? (caddr clause))
; test => (λ (x) ...)
(let ((var (caadr (caddr clause))))
`(let ((,var ,(car clause)))
(if ,var
,(cons 'begin (cddr (caddr clause)))
,(cond-clauses->if (cdr lst)))))
; test => proc
`(let ((b# ,(car clause)))
(if b#
(,(caddr clause) b#)
,(cond-clauses->if (cdr lst)))))
(list 'if
(car clause)
(cons 'begin (cdr clause))
(cond-clauses->if (cdr lst)))))))))
(cond-clauses->if clauses))
;;; props
;; This is implemented in a slightly different fashion as expected:
;;
;; *properties* : key → { symbol → value }
;;
;; The assumption here is that keys will most likely be the same across multiple symbols
;; so it makes more sense to reduce the number of subtables for the *properties* table.
(unless (bound? '*properties*)
(def *properties* (table)))
(def (putprop symbol key val)
"Associate a property value with a symbol."
(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))
"Get a property value associated with a symbol or `def` if missing."
(let ((kt (get *properties* key nil)))
(or (and kt (get kt symbol def)) def)))
(def (remprop symbol key)
"Remove a property value associated with a symbol."
(let ((kt (get *properties* key nil)))
(and kt (has? kt symbol) (del! kt symbol))))
;;; documentation
(def (sym-set-doc symbol doc . funvars)
(when (and (bound? 'str-join) doc)
(let* {[lines (str-split doc "\n")]
[hd (car lines)]
[tl (cdr lines)]
[snd (any (λ (s) (and (> (length s) 0)
(= (aref s 0) #\space)
s))
tl)]
[indent (and snd
(- (length snd)
(length (str-trim snd " " ""))))]
[trimmed (and snd
(map (λ (s) (if (<= indent (length s))
(str-sub s indent)
s))
tl))]
[final (str-join (cons hd trimmed) "\n")]}
(putprop symbol '*doc* final)))
(when (cons? funvars)
(let* {[existing (getprop symbol '*funvars* nil)]
; filter out duplicates
[to-add (filter (λ (funvar) (not (member funvar existing)))
funvars)]}
(putprop symbol '*funvars* (append existing to-add))))
(void))
;; chicken and egg - properties defined before sym-set-doc
(sym-set-doc
'*properties*
"All properties of symbols recorded with `putprop` are recorded in this table.")
(def (help-print-header term sigs)
"Format and print term's signature(s) for `(help term)` output."
(if sigs
(for-each (λ (sig) (print (cons term sig))
(newline))
sigs)
(begin (print term)
(newline)))
(newline))
(defmacro (help term (:print-header help-print-header))
"Display documentation for the specified term, if available."
(let* {[doc (getprop term '*doc*)]
[sigs (getprop term '*funvars* nil)]}
(if (or doc sigs)
`(begin (,print-header ',term ',sigs)
(when ,doc
(princ ,doc)
(newline))
(void))
(begin (princ "no help for " term)
(when (and (sym? term)
(not (bound? term)))
(princ " (undefined)"))
(newline))
(void))))
(def (value-get-doc body)
(let ((first (car body))
(rest (cdr body)))
(and (str? first) (cons? rest) first)))
;;; standard procedures
(def (member item lst)
(cond ((equal? (car lst) item) lst)
(lst (member item (cdr lst)))))
(def (memv item lst)
(cond ((eqv? (car lst) item) lst)
(lst (memv item (cdr lst)))))
(def (assoc item lst)
(cond ((equal? (caar lst) item) (car lst))
(lst (assoc item (cdr lst)))))
(def (assv item lst)
(cond ((eqv? (caar lst) item) (car lst))
(lst (assv item (cdr lst)))))
(def (> a . rest)
"Return `T` if the arguments are in strictly decreasing order (previous
one is greater than the next one)."
(let loop ((a a) (rest rest))
(or (not rest)
(and (< (car rest) a)
(loop (car rest) (cdr rest))))))
(defmacro (> a . rest)
`(< ,@(reverse! rest) ,a))
(def (<= a . rest)
"Return `T` if the arguments are in non-decreasing order (previous
one is less than or equal to the next one)."
(let loop ((a a) (rest rest))
(or (not rest)
(unless (or (< (car rest) a)
(nan? a))
(loop (car rest) (cdr rest))))))
(def (>= a . rest)
"Return `T` if the arguments are in non-increasing order (previous
one is greater than or equal to the next one)."
(let loop ((a a) (rest rest))
(or (not rest)
(unless (or (< a (car rest))
(nan? a))
(loop (car rest) (cdr rest))))))
(defmacro (/= a . rest)
"Return `T` if not all arguments are equal. Shorthand for `(not (= …))`."
`(not (= ,a ,@rest)))
(def (negative? x)
"Return `T` if `x` is negative."
(< x 0))
(def (zero? x)
"Return `T` if `x` is zero."
(= x 0))
(def (positive? x)
"Return `T` if `x` is greater than zero."
(> x 0))
(def (even? x)
(= (logand x 1) 0))
(def (odd? x)
(not (even? x)))
(def (identity x)
"Return `x`."
x)
(def (1+ n)
"Equivalent to `(+ n 1)`."
(+ n 1))
(def (1- n)
"Equivalent to `(- n 1)`."
(- n 1))
(def (div x y)
(+ (div0 x y)
(or (and (< x 0)
(or (and (< y 0) 1)
-1))
0)))
(def (mod0 x y)
(- x (* (div0 x y) y)))
(def (mod x y)
(- x (* (div x y) y)))
(def (random n)
(if (int? n)
(mod (rand) n)
(* (rand-double) n)))
(def (abs x)
(if (< x 0)
(- x)
x))
(def (max x0 . xs)
(if xs
(foldl (λ (a b) (if (< a b) b a))
x0
xs)
x0))
(def (min x0 . xs)
(if xs
(foldl (λ (a b) (if (< a b) a b))
x0
xs)
x0))
(def (rune? x)
(eq? (typeof x) 'rune))
(def (arr? x)
(or (vec? x)
(let ((tx (typeof x)))
(and (cons? tx) (eq? (car tx) 'arr)))))
(def (closure? x)
(and (fn? x)
(not (builtin? x))))
(def (caar x) (car (car x)))
(def (cdar x) (cdr (car x)))
(def (cddr x) (cdr (cdr x)))
(def (caaar x) (car (car (car x))))
(def (caadr x) (car (car (cdr x))))
(def (cadar x) (car (cdr (car x))))
(def (caddr x) (car (cdr (cdr x))))
(def (cdaar x) (cdr (car (car x))))
(def (cdadr x) (cdr (car (cdr x))))
(def (cddar x) (cdr (cdr (car x))))
(def (cdddr x) (cdr (cdr (cdr x))))
(def (caaaar x) (car (car (car (car x)))))
(def (caaadr x) (car (car (car (cdr x)))))
(def (caadar x) (car (car (cdr (car x)))))
(def (caaddr x) (car (car (cdr (cdr x)))))
(def (cadaar x) (car (cdr (car (car x)))))
(def (cadadr x) (car (cdr (car (cdr x)))))
(def (caddar x) (car (cdr (cdr (car x)))))
(def (cadddr x) (car (cdr (cdr (cdr x)))))
(def (cdaaar x) (cdr (car (car (car x)))))
(def (cdaadr x) (cdr (car (car (cdr x)))))
(def (cdadar x) (cdr (car (cdr (car x)))))
(def (cdaddr x) (cdr (car (cdr (cdr x)))))
(def (cddaar x) (cdr (cdr (car (car x)))))
(def (cddadr x) (cdr (cdr (car (cdr x)))))
(def (cdddar x) (cdr (cdr (cdr (car x)))))
(def (cddddr x) (cdr (cdr (cdr (cdr x)))))
(let ((*values* (list '*values*)))
(set! values
(λ vs
(if (and (cons? vs) (not (cdr vs)))
(car vs)
(cons *values* vs))))
(set! call-with-values
(λ (producer consumer)
(let ((res (producer)))
(if (and (cons? res) (eq? *values* (car res)))
(apply consumer (cdr res))
(consumer res))))))
;;; list utilities
(def (every pred lst)
(or (atom? lst)
(and (pred (car lst))
(every pred (cdr lst)))))
(def (any pred lst)
(and (cons? lst)
(or (pred (car lst))
(any pred (cdr lst)))))
(def (list? a)
(or (not a) (and (cons? a) (list? (cdr a)))))
(def (list-tail lst n)
(if (<= n 0)
lst
(list-tail (cdr lst) (- n 1))))
(def (list-head lst n)
(if (<= n 0)
()
(cons (car lst)
(list-head (cdr lst) (- n 1)))))
(def (list-ref lst n)
(car (list-tail lst n)))
(def (length= lst n)
"Perform a bounded length test.
Use this instead of `(= (length lst) n)`, since it avoids unnecessary
work and always terminates."
(cond ((< n 0) nil)
((= n 0) (atom? lst))
((atom? lst) (= n 0))
(else (length= (cdr lst) (- n 1)))))
(def (length> lst n)
(cond ((< n 0) lst)
((= n 0) (and (cons? lst) lst))
((atom? lst) (< n 0))
(else (length> (cdr lst) (- n 1)))))
(def (last-pair l)
(if (atom? (cdr l))
l
(last-pair (cdr l))))
(def (lastcdr l)
(if (atom? l)
l
(cdr (last-pair l))))
(def (to-proper l)
(cond ((not l) l)
((atom? l) (list l))
(else (cons (car l) (to-proper (cdr l))))))
(def (map! f lst)
(prog1 lst
(while (cons? lst)
(set-car! lst (f (car lst)))
(set! lst (cdr lst)))))
(def (filter pred lst)
(def (filter- f lst acc)
(cdr
(prog1 acc
(while (cons? lst)
(when (pred (car lst))
(set! acc
(cdr (set-cdr! acc (cons (car lst) ())))))
(set! lst (cdr lst))))))
(filter- pred lst (list ())))
(def (partition pred lst)
(def (partition- pred lst yes no)
(let ((vals
(prog1
(cons yes no)
(while (cons? lst)
(if (pred (car lst))
(set! yes (cdr (set-cdr! yes (cons (car lst) ()))))
(set! no (cdr (set-cdr! no (cons (car lst) ())))))
(set! lst (cdr lst))))))
(values (cdr (car vals)) (cdr (cdr vals)))))
(partition- pred lst (list ()) (list ())))
(def (count f l)
(def (count- f l n)
(if (not l)
n
(count- f (cdr l) (if (f (car l))
(+ n 1)
n))))
(count- f l 0))
(def (nestlist f zero n)
(if (<= n 0)
()
(cons zero (nestlist f (f zero) (- n 1)))))
(def (foldr f zero lst)
(if (not lst)
zero
(f (car lst) (foldr f zero (cdr lst)))))
(def (foldl f zero lst)
(if (not lst)
zero
(foldl f (f (car lst) zero) (cdr lst))))
(def (reverse- zero lst)
(if (not lst)
zero
(reverse- (cons (car lst) zero) (cdr lst))))
(def (reverse lst)
(reverse- () lst))
(def (reverse!- prev l)
(while (cons? l)
(set! l (prog1 (cdr l)
(set-cdr! l (prog1 prev
(set! prev l))))))
prev)
(def (reverse! l)
(reverse!- () l))
(def (copy-tree l)
(if (atom? l)
l
(cons (copy-tree (car l))
(copy-tree (cdr l)))))
(def (delete-duplicates lst)
(if (length> lst 20)
(let ((ta (table)))
(let loop ((l lst) (acc '()))
(if (atom? l)
(reverse! acc)
(if (has? ta (car l))
(loop (cdr l) acc)
(begin
(put! ta (car l) t)
(loop (cdr l) (cons (car l) acc)))))))
(if (atom? lst)
lst
(let ((elt (car lst))
(tail (cdr lst)))
(if (member elt tail)
(delete-duplicates tail)
(cons elt
(delete-duplicates tail)))))))
; you are not expected to understand this -- spew
(def (zip-with f . lst)
(apply map f lst))
(def (zip . lst)
(apply map list lst))
;;; backquote
(def (revappend l1 l2)
(reverse- l2 l1))
(def (nreconc l1 l2)
(reverse!- l2 l1))
(def (self-evaluating? x)
(and (not (gensym? x))
(or (and (atom? x)
(not (sym? x)))
(and (const? x)
(sym? x)
(eq? x (top-level-value x))))))
(defmacro (quasiquote x) (bq-process x 0))
(def (splice-form? x)
(or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
(eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote)
(length> x 2))))
(eq? x 'unquote)))
;; bracket without splicing
(def (bq-bracket1 x d)
(if (and (cons? x) (eq? (car x) 'unquote))
(if (= d 0)
(cadr x)
(list cons ''unquote
(bq-process (cdr x) (- d 1))))
(bq-process x d)))
(def (bq-bracket x d)
(cond ((atom? x) (list list (bq-process x d)))
((eq? (car x) 'unquote)
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process (cdr x) (- d 1))))))
((eq? (car x) 'unquote-splicing)
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process (cadr x) (- d 1))))))
((eq? (car x) 'unquote-nsplicing)
(if (= d 0)
(cadr x)
(list list (list list ''unquote-nsplicing
(bq-process (cadr x) (- d 1))))))
(else (list list (bq-process x d)))))
(def (bq-process x d)
(cond ((sym? x) (list 'quote x))
((vec? x)
(let ((body (bq-process (vec->list x) d)))
(if (eq? (car body) list)
(cons vec (cdr body))
(list apply vec body))))
((atom? x) x)
((eq? (car x) 'quasiquote)
(list list ''quasiquote (bq-process (cadr x) (+ d 1))))
((eq? (car x) 'unquote)
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process (cdr x) (- d 1)))))
((not (any splice-form? x))
(let ((lc (lastcdr x))
(forms (map (λ (x) (bq-bracket1 x d)) x)))
(if (not lc)
(cons list forms)
(if (not (cdr forms))
(list cons (car forms) (bq-process lc d))
(nconc (cons list* forms) (list (bq-process lc d)))))))
(else
(let loop ((p x) (q ()))
(cond ((not p) ;; proper list
(cons 'nconc (reverse! q)))
((cons? p)
(cond ((eq? (car p) 'unquote)
;; (... . ,x)
(cons 'nconc
(nreconc q
(if (= d 0)
(cdr p)
(list (list list ''unquote)
(bq-process (cdr p)
(- d 1)))))))
(else
(loop (cdr p) (cons (bq-bracket (car p) d) q)))))
(else
;; (... . x)
(cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
;;; standard macros
(def (quote-value v)
(if (self-evaluating? v)
v
(list 'quote v)))
(defmacro (let* binds . body)
(if (atom? binds)
`((λ () ,@body))
`((λ (,(caar binds))
,@(if (cons? (cdr binds))
`((let* ,(cdr binds) ,@body))
body))
,(cadar binds))))
(defmacro (when c . body)
(list 'if c (cons 'begin body) nil))
(defmacro (unless c . body)
(list 'if c nil (cons 'begin body)))
(defmacro (case key . clauses)
(def (vals->cond key v)
(cond ((eq? v 'else) 'else)
((not v) nil)
((sym? v) `(eq? ,key ,(quote-value v)))
((atom? v) `(eqv? ,key ,(quote-value v)))
((not (cdr v)) `(eqv? ,key ,(quote-value (car v))))
((every sym? v)
`(memq ,key ',v))
(else `(memv ,key ',v))))
(let ((g (gensym)))
`(let ((,g ,key))
(cond ,.(map (λ (clause)
(cons (vals->cond g (car clause))
(cdr clause)))
clauses)))))
(defmacro (do vars test-spec . commands)
(let ((test-expr (car test-spec))
(vars (map car vars))
(inits (map cadr vars))
(steps (map (λ (x)
(if (cons? (cddr x))
(caddr x)
(car x)))
vars)))
`(letrec ((loop# (λ ,vars
(if ,test-expr
(begin
,@(cdr test-spec))
(begin
,@commands
(loop# ,.steps))))))
(loop# ,.inits))))
; SRFI 8
(defmacro (receive formals expr . body)
`(call-with-values (λ () ,expr)
(λ ,formals ,@body)))
(defmacro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
(λ (,v) ,@body))))
(def (map-int f n)
(if (<= n 0)
nil
(let ((first (cons (f 0) ()))
(acc ()))
(set! acc first)
(for 1 (1- n)
(λ (i) (set-cdr! acc (cons (f i) ()))
(set! acc (cdr acc))))
first)))
(def (iota n)
(map-int identity n))
(defmacro (with-bindings binds . body)
(let ((vars (map car binds))
(vals (map cadr binds))
(olds (map (λ (x) (gensym)) binds)))
`(let ,(map list olds vars)
,@(map (λ (v val) `(set! ,v ,val)) vars vals)
(unwind-protect
(begin ,@body)
(begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
;;; exceptions
(def (error . args)
(raise (cons 'error args)))
(defmacro (throw tag value)
`(raise (list 'thrown-value ,tag ,value)))
(defmacro (catch tag expr)
`(trycatch ,expr
(λ (e#) (if (and (cons? e#)
(eq? (car e#) 'thrown-value)
(eq? (cadr e#) ,tag))
(caddr e#)
(raise e#)))))
(defmacro (unwind-protect expr finally)
`(let ((thk# (λ () ,finally)))
(prog1 (trycatch ,expr
(λ (e#) (thk#) (raise e#)))
(thk#))))
;;; debugging utilities
(defmacro (assert expr)
`(if ,expr t (raise '(assert-failed ,expr))))
(def traced?
(let ((sample-traced-lambda (λ args (write (cons 'x args))
(newline)
(apply #.apply args))))
(λ (f)
(and (closure? f)
(equal? (fn-code f)
(fn-code sample-traced-lambda))))))
(def (trace symbol)
(let ((func (top-level-value symbol)))
(when (not (traced? func))
(set-top-level-value! symbol
(eval
`(λ args#
(write (cons ',symbol args#))
(newline)
(apply ',func args#))))))
(void))
(def (untrace symbol)
(let ((func (top-level-value symbol)))
(when (traced? func)
(set-top-level-value! symbol
(aref (fn-vals func) 3))))
(void))
(defmacro (time expr)
`(let ((t0# (time-now)))
(prog1
,expr
(princ "Elapsed time: " (- (time-now) t0#) " seconds" *linefeed*))))
;;; text I/O
(def (print . args)
(for-each write args))
(def (princ . args)
(with-bindings ((*print-readably* nil))
(for-each write args)))
(def (newline (io *io-out*))
(io-write io *linefeed*)
(void))
(def (io-readline s) (io-readuntil s #\linefeed))
; call f on an io until the io runs out of data
(def (read-all-of f s)
(let loop ((lines ())
(curr (f s)))
(if (io-eof? s)
(reverse! lines)
(loop (cons curr lines) (f s)))))
(def (io-readlines s)
(read-all-of io-readline s))
(def (read-all s)
(read-all-of read s))
(def (io-readall s)
(let ((b (buffer)))
(io-copy b s)
(io->str b)))
(defmacro (with-output-to io . body)
`(with-bindings ((*io-out* ,io))
,@body))
(defmacro (with-input-from io . body)
`(with-bindings ((*io-in* ,io))
,@body))
;;; vector functions
(def (list->vec l)
(apply vec l))
(def (vec->list v)
(let ((n (length v))
(l ()))
(for 1 n
(λ (i)
(set! l (cons (aref v (- n i)) l))))
l))
(def (vec-map f v)
(let* ((n (length v))
(nv (vec-alloc n)))
(for 0 (- n 1)
(λ (i)
(aset! nv i (f (aref v i)))))
nv))
;;; table functions
(def (table-pairs ta)
(table-foldl (λ (k v z) (cons (cons k v) z))
nil ta))
(def (table-keys ta)
(table-foldl (λ (k v z) (cons k z))
nil ta))
(def (table-values ta)
(table-foldl (λ (k v z) (cons v z))
nil ta))
(def (table-clone ta)
(let ((nt (table)))
(table-foldl (λ (k v z) (put! nt k v))
nil ta)
nt))
(def (table-invert ta)
(let ((nt (table)))
(table-foldl (λ (k v z) (put! nt v k))
nil ta)
nt))
;;; string functions
(def (str-tail s n)
(str-sub s n))
(def (str-trim s at-start at-end)
(def (trim-start s runes i L)
(if (and (< i L) (str-find runes (str-rune s i)))
(trim-start s runes (1+ i) L)
i))
(def (trim-end s runes i)
(if (and (> i 0) (str-find runes (str-rune s (1- i))))
(trim-end s runes (1- i))
i))
(let ((L (str-length s)))
(str-sub s
(trim-start s at-start 0 L)
(trim-end s at-end L))))
(def (str-map f s)
(let ((b (buffer))
(n (str-length s)))
(let ((i 0))
(while (< i n)
(io-putc b (f (str-rune s i)))
(set! i (1+ i))))
(io->str b)))
(def (str-rep s k)
(cond ((< k 4)
(cond ((<= k 0) "")
((= k 1) (str s))
((= k 2) (str s s))
(else (str s s s))))
((odd? k) (str s (str-rep s (- k 1))))
(else (str-rep (str s s) (/ k 2)))))
(def (str-lpad s n c)
(str (str-rep c (- n (str-length s))) s))
(def (str-rpad s n c)
(str s (str-rep c (- n (str-length s)))))
(def (print-to-str . args)
(let ((b (buffer)))
(for-each (λ (a) (write a b)) args)
(io->str b)))
(def (str-join strlist sep)
(if (not strlist)
""
(let ((b (buffer)))
(io-write b (car strlist))
(for-each (λ (s) (io-write b sep)
(io-write b s))
(cdr strlist))
(io->str b))))
;;; structs
(defmacro (defstruct name (:type vec)
(:named T)
(:constructor T)
(:conc-name NIL)
(:predicate NIL)
. slots)
"Defines a structure type with a specific name and slots.
The default underlying type is a \"named\" vector (`:type vec`),
where the first element is the name of the structure's type, the
rest are the slot values. If the name as the first element isn't
required, `:named NIL` should be used. A list can be used instead
of a vector by adding `:type list` option.
An example of a default constructor signature, based on structure
definition:
(defstruct blah a b c) →
(make-blah (:a NIL) (:b NIL) (:c NIL))
It can be customized in several ways. For example:
; disable the constructor altogether
(defstruct blah :constructor NIL a b c)
; only change its name
(defstruct blah :constructor blargh a b c)
; rename AND avoid using keywords
(defstruct blah :constructor (blah a b c) a b c)
The option `:conc-name` specifies the slot accessor prefix, which
defaults to `name-`.
Default predicate name (`name?`) can be changed:
; use \"blargh?\" instead of \"blah?\"
(defstruct blah :predicate blargh? a b c)"
(def (slot-opts slot)
; check whether slot options, if any, are valid
(let ((opts (cddr slot)))
(for-each (λ (opt) (unless (member opt '(:read-only))
(error (str "invalid option in slot " (car slot)
" of struct " name
": " opt))))
opts)
opts))
(def (tokw slots)
; transform args list to keyworded variant.
; eg: (a (b 1) (c :read-only)) → ((:a NIL) (:b 1) (:c NIL :read-only))
(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 (keyword? (car tail))
(cons nil tail)
tail))))
slots))
(let* {; first element in slots may be the doc string
[doc (and (str? (car slots))
(car slots))]
; if it is, rid of it
[slots (or (and doc (cdr slots))
slots)]
[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)]
; struct's underlying type's predicate (either vec? or list?)
[type? (sym type #\?)]
; struct's predicate name
[is? (or predicate
(sym name #\?))]
; constructor name and arguments
[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
; should the struct name appear as the first element?
[named (and named (list name))]
; accessor prefix
[access (or conc-name
(str name "-"))]}
`(begin
; predicate
(def (,is? s)
(and [,type? s]
[or (not ',named) (eq? (aref s 0) ',name)]
[= (length s) ,(+ (length named) num-slots)]))
; documentation string
(when ,doc
(sym-set-doc ',name ,doc))
; constructor
,(when constructor `(def ,constructor
(,type ',@named ,@slots-car)))
; accessor per slot
,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))]
[fld (list-ref slots-car i)]
[fun (sym access fld)]}
`(def (,fun s (v #.(void)))
(assert (,is? s))
(if (void? v)
(aref s ,[+ (length named) i])
,(if (member :read-only opts)
`(error (str "slot "
',fld
" in struct "
',name
" is :read-only"))
`(aset! s ,[+ (length named) i] v))))])
num-slots))))
(doc-for (defstruct name
doc
options…
(slot-1 DEFAULT)
slot-2
(slot-3 :read-only)))
;;; toplevel
(def (macrocall? e)
(and (sym? (car e))
(get-syntax (car e))))
(def (macroexpand-1 e)
(if (atom? e)
e
(let ((f (macrocall? e)))
(if f
(apply f (cdr e))
e))))
(def (macroexpand e)
; symbol resolves to toplevel; i.e. has no shadowing definition
(def (top? s env) (not (or (bound? s) (assq s env))))
(def (splice-begin body)
(cond ((atom? body) body)
((equal? body '((begin)))
body)
((and (cons? (car body))
(eq? (caar body) 'begin))
(append (splice-begin (cdar body)) (splice-begin (cdr body))))
(else
(cons (car body) (splice-begin (cdr body))))))
(def *expanded* (list '*expanded*))
(def (expand-body body env)
(if (atom? body)
body
(let* ((body (if (top? 'begin env)
(splice-begin body)
body))
(def? (top? 'def env))
(dvars (if def? (get-defined-vars body) ()))
(env (nconc (map list dvars) env)))
(if (not def?)
(map (λ (x) (expand-in x env)) body)
(let* ((ex-nondefs ; expand non-definitions
(let loop ((body body))
(cond ((atom? body) body)
((and (cons? (car body))
(eq? 'def (caar body)))
(cons (car body) (loop (cdr body))))
(else
(let ((form (expand-in (car body) env)))
(set! env (nconc
(map list (get-defined-vars form))
env))
(cons
(cons *expanded* form)
(loop (cdr body))))))))
(body ex-nondefs))
(while (cons? body) ; now expand deferred definitions
(if (not (eq? *expanded* (caar body)))
(set-car! body (expand-in (car body) env))
(set-car! body (cdar body)))
(set! body (cdr body)))
ex-nondefs)))))
(def (expand-lambda-list l env)
(if (atom? l)
l
(cons (if (and (cons? (car l)) (cons? (cdr (car l))))
(list (caar l) (expand-in (cadar l) env))
(car l))
(expand-lambda-list (cdr l) env))))
(def (l-vars l)
(cond ((atom? l) (list l))
((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
(else (cons (car l) (l-vars (cdr l))))))
(def (expand-lambda e env)
(let ((formals (cadr e))
(name (lastcdr e))
(body (cddr e))
(vars (l-vars (cadr e))))
(let ((env (nconc (map list vars) env)))
`(λ ,(expand-lambda-list formals env)
,.(expand-body body env)
. ,name))))
(def (expand-define e env)
(if (or (not (cdr e)) (atom? (cadr e)))
(if (not (cddr e))
e
(let ((name (cadr e))
(doc (value-get-doc (cddr e))))
(when doc
(set! e (cdr e))
(sym-set-doc name doc))
`(def ,name ,(expand-in (caddr e) env))))
(let* ((formals (cdadr e))
(name (caadr e))
(body (cddr e))
(doc (value-get-doc body))
(vars (l-vars formals))
(menv (nconc (map list vars) env)))
(when doc
(set! body (cdr body))
(sym-set-doc name doc formals))
`(def ,(cons name (expand-lambda-list formals menv))
,.(expand-body body menv)))))
(def (expand-let-syntax e env)
(let ((binds (cadr e)))
(cons 'begin
(expand-body (cddr e)
(nconc
(map (λ (bind)
(list (car bind)
((compile-thunk
(expand-in (cadr bind) env)))
env))
binds)
env)))))
; given let-syntax definition environment (menv) and environment
; at the point of the macro use (lenv), return the environment to
; expand the macro use in. TODO
(def (local-expansion-env menv lenv) menv)
(def (expand-in e env)
(if (atom? e)
e
(let* ((head (car e))
(bnd (assq head env))
(default (λ ()
(let loop ((e e))
(if (atom? e)
e
(cons (if (atom? (car e))
(car e)
(expand-in (car e) env))
(loop (cdr e))))))))
(cond ((and bnd (cons? (cdr bnd))) ; local macro
(expand-in (apply (cadr bnd) (cdr e))
(local-expansion-env (caddr bnd) env)))
((macrocall? e) => (λ (f)
(expand-in (apply f (cdr e)) env)))
((or bnd ; bound lexical or toplevel var
(not (sym? head))
(bound? head))
(default))
((eq? head 'quote) e)
((eq? head 'λ) (expand-lambda e env))
((eq? head 'lambda) (expand-lambda e env))
((eq? head 'def) (expand-define e env))
((eq? head 'let-syntax) (expand-let-syntax e env))
(else (default))))))
(expand-in e ()))
(def (eval x)
((compile-thunk (macroexpand x))))
(def (load-process x)
(eval x))
(def (load filename)
(let ((F (file filename :read)))
(trycatch
(let next (prev E v)
(if (not (io-eof? F))
(next (read F)
prev
(begin (load-process E) (void)))
(begin (io-close F)
; evaluate last form in almost-tail position
(void (load-process E)))))
(λ (e)
(io-close F)
(raise `(load-error ,filename ,e))))))
(def (repl)
(def (prompt)
(*prompt*)
(io-flush *io-out*)
(let ((v (trycatch (read)
(λ (e) (io-discardbuffer *io-in*)
(raise e)))))
(and (not (io-eof? *io-in*))
(let ((V (load-process v)))
(unless (void? V) (print V) (newline))
(void (set! that V))))))
(def (reploop)
(when (trycatch (prompt)
(λ (e)
(top-level-exception-handler e)
t))
(reploop)))
(reploop)
(newline))
(def (top-level-exception-handler e)
(with-output-to *stderr*
(print-exception e)
(print-stack-trace (stacktrace))))
(def (print-stack-trace st)
(def (find-in-f f tgt path)
(let ((path (cons (fn-name f) path)))
(if (eq? (fn-code f) (fn-code tgt))
(throw 'ffound path)
(let ((v (fn-vals f)))
(for 0 (1- (length v))
(λ (i) (when (closure? (aref v i))
(find-in-f (aref v i) tgt path))))))))
(def (fname f e)
(let ((p (catch 'ffound
(begin
(for-each (λ (topfun)
(find-in-f topfun f ()))
e)
nil))))
(if p
(str-join (map str (reverse! p)) "/")
"λ")))
(let ((st (reverse! (if (length> st 3)
(list-tail st (if *interactive* 5 4))
st)))
(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-each (λ (p) (princ " ") (print p))
(cdr (cdr (vec->list f))))
(princ ")" *linefeed*)
(when (= n 0)
(fn-disasm (aref f 1) (aref f 0)))
(set! n (+ n 1)))
st)))
(def (print-exception e)
(cond ((and (cons? e)
(eq? (car e) 'type-error)
(length= e 3))
(princ "type error: expected " (cadr e) ", got " (typeof (caddr e)) ": ")
(print (caddr e)))
((and (cons? e)
(eq? (car e) 'bounds-error)
(length= e 3))
(princ "index " (caddr e) " out of bounds for ")
(print (cadr e)))
((and (cons? e)
(eq? (car e) 'unbound-error)
(length= e 2))
(princ "eval: variable " (cadr e) " has no value"))
((and (cons? e)
(eq? (car e) 'error))
(princ "error: ")
(apply princ (cdr e)))
((and (cons? e)
(eq? (car e) 'load-error))
(print-exception (caddr e))
(princ "in file " (cadr e)))
((and (list? e)
(length= e 2))
(print (car e))
(princ ": ")
(let ((msg (cadr e)))
((if (or (str? msg) (sym? msg))
princ
print)
msg)))
(else (princ "*** Unhandled exception: ")
(print e)))
(princ *linefeed*))
(def (make-system-image fname)
(def (sort l)
(if (or (not l) (not (cdr l)))
l
(let ((piv (car l)))
(receive (less grtr)
(partition (λ (x) (< x piv)) (cdr l))
(nconc (sort less)
(list piv)
(sort grtr))))))
(let ((f (file fname :write :create :truncate))
(excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
*print-pretty* *print-width* *print-readably*
*print-level* *print-length* *os-name* *interactive*
*prompt* *os-version*)))
(with-bindings ((*print-pretty* t)
(*print-readably* t))
(let* ((syms
(filter (λ (s)
(and (bound? s)
(not (const? s))
(or (not (builtin? (top-level-value s)))
(not (equal? (str s) ; alias of builtin
(str (top-level-value s)))))
(not (memq s excludes))
(not (io? (top-level-value s)))))
(sort (environment))))
(data (apply nconc (map list syms (map top-level-value syms)))))
(write data f)
(io-write f *linefeed*))
(io-close f))))
; initialize globals that need to be set at load time
(def (__init_globals)
(let ((defprompt (if (equal? *os-name* "macos")
(λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
(λ () (princ "#;> ")))))
(set! *prompt*
"Function called by REPL to signal the user input is required.
Default function prints `#;> `."
defprompt))
(set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
(set! *linefeed* "\n")
(set! *exit-hooks* nil)
(set! *io-out* *stdout*)
(set! *io-in* *stdin*)
(set! *io-err* *stderr*))
(def (__script fname)
(trycatch (load fname)
(λ (e) (top-level-exception-handler e)
(exit (str e)))))
(def (__rcscript)
(let* ((homevar (case *os-name*
(("unknown") nil)
(("plan9") "home")
(("macos") (princ "\x1b]0;StreetLISP v0.999\007") nil)
(else "HOME")))
(home (and homevar (os-getenv homevar)))
(rcpath (case *os-name*
(("plan9") "lib/slrc")
(else ".slrc")))
(fname (and home (str home *directory-separator* rcpath))))
(and fname (path-exists? fname) (load fname))))
(def (__start argv interactive)
(__init_globals)
(set! *argv* argv)
(set! *interactive* interactive)
(if (cons? (cdr argv))
(begin (set! *argv* (cdr argv))
(__script (cadr argv)))
(set! *interactive* t))
(when *interactive*
(__rcscript)
(repl))
(exit))
(def (add-exit-hook fun)
"Puts an one-argument function on top of the list of exit hooks.
On shutdown each exit hook is called with the exit status as a single
argument, which is (usually) `NIL` on success and a string describing
an error otherwise."
(set! *exit-hooks* (cons fun *exit-hooks*))
(void))
(def (__finish status)
"A function called right before exit by the VM."
(for-each (λ (f) (f status)) *exit-hooks*))