ref: a70379d7e4b822f532fb0a8ccdd1624a90b64a68
dir: /src/system.sl/
;;;; standard library
;;; void
(def (void . rest)
"Return the constant `#<void>` while ignoring any arguments.
`#<void>` is mainly used when a function has side effects but does not
produce any meaningful value to return, so even though `T` or `NIL` could
be returned instead, in case of `#<void>` alone, REPL will not print
it."
#.(void))
(def (void? x)
"Return `T` if `x` is `#<void>`, `NIL` otherwise."
(eq? x #.(void)))
;;; syntax environment
(unless (bound? '*syntax-environment*)
(def *syntax-environment* (table)))
(def (set-syntax! s v)
(put! *syntax-environment* s v))
(def (get-syntax s)
(get *syntax-environment* s NIL))
(defmacro (defmacro form . body)
(let* {[doc+body (separate-doc-from-body body)]
[doc (car doc+body)]
[body (cdr doc+body)]}
(when doc
(sym-set-doc (car form) doc (cdr form)))
`(void (set-syntax! ',(car form)
(λ ,(cdr form) ,@body)))))
(defmacro (letrec binds . body)
`((λ ,(map car binds)
,.(map (λ (b) `(set! ,@b)) binds)
,@body)
,.(map void binds)))
(defmacro (let binds . body)
(let ((lname NIL))
(when (sym? binds)
(set! lname binds)
(set! binds (car body))
(set! body (cdr body)))
(let ((thelambda
`(λ ,(map (λ (c) (if (cons? c) (car c) c))
binds)
,@body))
(theargs
(map (λ (c) (if (cons? c) (cadr c) (void)))
binds)))
(cons (if lname
`(letrec ((,lname ,thelambda)) ,lname)
thelambda)
theargs))))
(defmacro (cond . clauses)
(def (cond-clauses->if lst)
(if (atom? lst)
NIL
(let ((clause (car lst)))
(if (or (eq? (car clause) 'else)
(eq? (car clause) T))
(if (not (cdr clause))
(car clause)
(cons 'begin (cdr clause)))
(if (not (cdr clause))
; test by itself
(list 'or
(car clause)
(cond-clauses->if (cdr lst)))
; test => expression
(if (eq? (cadr clause) '=>)
(if (1arg-lambda? (caddr clause))
; test => (λ (x) ...)
(let ((var (caadr (caddr clause))))
`(let ((,var ,(car clause)))
(if ,var
,(cons 'begin (cddr (caddr clause)))
,(cond-clauses->if (cdr lst)))))
; test => proc
`(let ((b# ,(car clause)))
(if b#
(,(caddr clause) b#)
,(cond-clauses->if (cdr lst)))))
(list 'if
(car clause)
(cons 'begin (cdr clause))
(cond-clauses->if (cdr lst)))))))))
(cond-clauses->if clauses))
;;; props
;; This is implemented in a slightly different fashion as expected:
;;
;; *properties* : key → { symbol → value }
;;
;; The assumption here is that keys will most likely be the same across multiple symbols
;; so it makes more sense to reduce the number of subtables for the *properties* table.
(unless (bound? '*properties*)
(def *properties* (table)))
(def (putprop symbol key val)
"Associate a property value with the symbol."
:doc-group prop
:doc-see getprop
(let ((kt (get *properties* key NIL)))
(unless kt
(let ((ta (table)))
(put! *properties* key ta)
(set! kt ta)))
(put! kt symbol val)
val))
(def (getprop symbol key (def NIL))
"Return a property value associated with the symbol or `def` if
missing."
:doc-group prop
:doc-see putprop
(let ((kt (get *properties* key NIL)))
(or (and kt (get kt symbol def)) def)))
(def (remprop symbol key)
"Remove a property value associated with the symbol."
:doc-group prop
(let ((kt (get *properties* key NIL)))
(and kt (has? kt symbol) (del! kt symbol))))
;;; documentation
(def (separate-doc-from-body body (doc NIL))
"Take a list of terms and return a pair `(doc . body)`, where the first
element contains a list of documentation-related terms, and the second
contains the rest of the terms."
:doc-group doc
(def (doc? kw)
(and (> (length kw) 5)
(= (aref kw 1) #\d)
(= (aref kw 2) #\o)
(= (aref kw 3) #\c)
(= (aref kw 4) #\-)))
(let {[hd (car body)]
[tl (cdr body)]}
(cond [(and (str? hd) (not doc) tl)
(separate-doc-from-body tl (cons hd doc))]
[(and doc (keyword? hd) (doc? (str hd)))
(separate-doc-from-body (cdr tl) (cons (cons hd (car tl)) doc))]
[else (cons (reverse doc) body)])))
(def (sym-set-doc symbol doc-seq . formals-list)
"Set the documentation for the symbol."
:doc-group doc
(let* {[doc-only (str? doc-seq)]
[doc (if doc-only doc-seq (car doc-seq))]
[extra (if doc-only NIL (cdr doc-seq))]}
(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 extra (putprop symbol '*doc-extra* extra))))
(when (cons? formals-list)
(let* {[existing (getprop symbol '*formals-list*)]
; filter out duplicates
[to-add (filter (λ (formals) (not (member formals existing)))
formals-list)]}
(putprop symbol '*formals-list* (append existing to-add))))
(void)))
;; 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."
:doc-group prop))
(def (help-print-header term sigs (:kind NIL) (:lpad ""))
"Format and print signature(s) of the term for `(help term)` output."
:doc-group doc
(if sigs
(for-each (λ (sig) (princ lpad)
(print (cons term sig))
(newline))
sigs)
(begin
(princ lpad)
(if kind
(princ (caddr term) " (group)")
(print term))
(newline)))
(newline))
(defmacro (help term (kind NIL) (:print-header help-print-header))
"Display documentation the specified term, if available.
The optional parameter `kind` can be set to `group` to show
documentation for the specified group instead of a single term.
All available documentation groups can be displayed with `(help
groups)`."
:doc-group doc
(let* {[doc-extra-term (and kind (cons (sym ":doc-" kind) term))]
[docterm (if kind (list 'doc kind term) term)]
[doc (getprop docterm '*doc*)]
[formals-list (getprop docterm '*formals-list*)]}
(def (print-sig term sigs lpad)
(if sigs
(for-each (λ (sig) (newline)
(princ lpad)
(print (cons term sig)))
sigs)
(begin (newline)
(princ lpad)
(print term))))
(def (first-line s)
(let* {[nl (str-find s "\n")]}
(if nl (str-sub s 0 nl) s)))
(def (doc-group? k)
(and (cons? k)
(eq? (car k) 'doc)
(eq? (cadr k) 'group)))
(def (doc-extra-term? k)
(and (atom? k)
(member doc-extra-term (getprop k '*doc-extra*))))
(def (table-keys-filter-sort tbl pred)
(sort (table-foldl (λ (k _ z) (if (pred k) (cons k z) z)) NIL tbl) <))
(if (eq? term 'groups)
(for-each (λ (k) (princ (caddr k) ": " (first-line (getprop k '*doc*)))
(newline))
(table-keys-filter-sort (get *properties* '*doc*)
doc-group?))
(if (or doc formals-list)
(begin (print-header docterm formals-list :kind kind)
(let* {[extra (getprop docterm '*doc-extra*)]
[fmt (filter (λ (v) (eq? (car v) :doc-fmt)) extra)]
[see (filter (λ (v) (eq? (car v) :doc-see)) extra)]}
(when doc
(princ (foldl (λ (fmt doc) ((cdr fmt) doc)) doc fmt))
(newline))
(when see
(newline)
(princ "See also:")
(newline)
(for-each (λ (v) (print-sig (cdr v)
(getprop (cdr v) '*formals-list*)
" "))
see)
(newline)))
(when kind
(newline)
(princ "Members:")
(newline)
(for-each (λ (k) (print-sig k
(getprop k '*formals-list*)
" "))
(table-keys-filter-sort (get *properties* '*doc*)
doc-extra-term?))
(newline))
(void))
(begin (princ "no help for " (if kind (str kind " ") "") term)
(when (and (not kind)
(sym? term)
(not (bound? term)))
(princ " (undefined)"))
(newline))))
(void)))
;;; standard procedures
(def (member item lst)
(cond ((equal? (car lst) item) lst)
(lst (member item (cdr lst)))))
(def (memv item lst)
(cond ((eqv? (car lst) item) lst)
(lst (memv item (cdr lst)))))
(def (assoc item lst)
(cond ((equal? (caar lst) item) (car lst))
(lst (assoc item (cdr lst)))))
(def (assv item lst)
(cond ((eqv? (caar lst) item) (car lst))
(lst (assv item (cdr lst)))))
(doc-group compare
"Comparison operators.")
(def (> a . rest)
"Return `T` if the arguments are in strictly decreasing order (previous
one is greater than the next one)."
:doc-group compare
(let loop ((a a) (rest rest))
(or (not rest)
(and (< (car rest) a)
(loop (car rest) (cdr rest))))))
(defmacro (> a . rest)
`(< ,.(reverse rest) ,a))
(def (<= a . rest)
"Return `T` if the arguments are in non-decreasing order (previous
one is less than or equal to the next one)."
:doc-group compare
(let loop ((a a) (rest rest))
(or (not rest)
(unless (or (< (car rest) a)
(nan? a))
(loop (car rest) (cdr rest))))))
(def (>= a . rest)
"Return `T` if the arguments are in non-increasing order (previous
one is greater than or equal to the next one)."
:doc-group compare
(let loop ((a a) (rest rest))
(or (not rest)
(unless (or (< a (car rest))
(nan? a))
(loop (car rest) (cdr rest))))))
(def (negative? x)
"Return `T` if `x` is negative."
:doc-group compare
(< x 0))
(def (zero? x)
"Return `T` if `x` is zero."
:doc-group compare
(= x 0))
(def (positive? x)
"Return `T` if `x` is greater than zero."
:doc-group compare
(> x 0))
(def (even? x)
(= (logand x 1) 0))
(def (odd? x)
(not (even? x)))
(def (identity x)
"Return `x`."
x)
(def (1+ n)
"Equivalent to `(+ n 1)`."
(+ n 1))
(def (1- n)
"Equivalent to `(- n 1)`."
(- n 1))
(def (div x y)
(+ (div0 x y)
(or (and (< x 0)
(or (and (< y 0) 1)
-1))
0)))
(def (mod0 x y)
(- x (* (div0 x y) y)))
(def (mod x y)
(- x (* (div x y) y)))
(def (random n)
(if (int? n)
(mod (rand) n)
(* (rand-double) n)))
(def (abs x)
(if (< x 0)
(- x)
x))
(def (max x0 . xs)
(if xs
(foldl (λ (a b) (if (< a b) b a))
x0
xs)
x0))
(def (min x0 . xs)
(if xs
(foldl (λ (a b) (if (< a b) a b))
x0
xs)
x0))
(def (rune? x)
(eq? (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)
(and (> n 0)
(cons (car lst)
(list-head (cdr lst) (- n 1)))))
(def (list-ref lst n)
(car (list-tail lst n)))
(doc-group list
"Working with lists.")
(def (length= lst n)
"Perform a bounded length test.
Use this instead of `(= (length lst) n)`, since it avoids unnecessary
work and always terminates."
:doc-group list
(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) NIL)))))
(set! lst (cdr lst))))))
(filter- pred lst (list NIL)))
(def (partition pred lst)
(def (partition- pred lst yes no)
(let ((vals
(prog1
(cons yes no)
(while (cons? lst)
(if (pred (car lst))
(set! yes (cdr (set-cdr! yes (cons (car lst) NIL))))
(set! no (cdr (set-cdr! no (cons (car lst) NIL)))))
(set! lst (cdr lst))))))
(values (cdr (car vals)) (cdr (cdr vals)))))
(partition- pred lst (list NIL) (list NIL)))
(def (count f l)
(def (count- f l n)
(if (not l)
n
(count- f (cdr l) (if (f (car l))
(+ n 1)
n))))
(count- f l 0))
(def (nestlist f zero n)
(and (> n 0)
(cons zero (nestlist f (f zero) (- n 1)))))
(def (foldr f zero lst)
(if (not lst)
zero
(f (car lst) (foldr f zero (cdr lst)))))
(def (foldl f zero lst)
(if (not lst)
zero
(foldl f (f (car lst) zero) (cdr lst))))
(def (reverse- zero lst)
(if (not lst)
zero
(reverse- (cons (car lst) zero) (cdr lst))))
(def (reverse lst)
(reverse- NIL lst))
(def (reverse!- prev l)
(while (cons? l)
(set! l (prog1 (cdr l)
(set-cdr! l (prog1 prev
(set! prev l))))))
prev)
(def (reverse! l)
(reverse!- NIL l))
(def (copy-tree l)
(if (atom? l)
l
(cons (copy-tree (car l))
(copy-tree (cdr l)))))
(def (delete-duplicates lst)
(if (length> lst 20)
(let ((ta (table)))
(let loop ((l lst) (acc NIL))
(if (atom? l)
(reverse! acc)
(if (has? ta (car l))
(loop (cdr l) acc)
(begin
(put! ta (car l) T)
(loop (cdr l) (cons (car l) acc)))))))
(if (atom? lst)
lst
(let ((elt (car lst))
(tail (cdr lst)))
(if (member elt tail)
(delete-duplicates tail)
(cons elt
(delete-duplicates tail)))))))
(def (find-if p lst (:key identity)
(:start 0)
(:end NIL)
(:from-end NIL))
(def (find-if- lst)
(if (or (not lst) (p (key (car lst))))
(car lst)
(find-if- (cdr lst))))
(set! lst (list-tail lst start))
(when end (set! lst (list-head lst (- end start))))
(when from-end (set! lst (reverse! lst)))
(find-if- lst))
(def (find e lst (:key identity)
(:test equal?)
(:start 0)
(:end NIL)
(:from-end NIL))
(find-if (λ (x) (test e x))
lst
:key key
:start start
:end end
:from-end from-end))
; you are not expected to understand this -- spew
(def (zip-with f . lst)
(apply map f lst))
(def (zip . lst)
(apply map list lst))
;;; backquote
(def (revappend l1 l2)
(reverse- l2 l1))
(def (nreconc l1 l2)
(reverse!- l2 l1))
(def (self-evaluating? x)
(and (not (gensym? x))
(or (and (atom? x)
(not (sym? x)))
(and (const? x)
(sym? x)
(eq? x (top-level-value x))))))
(defmacro (quasiquote x) (bq-process x 0))
(def (splice-form? x)
(or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
(eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote)
(length> x 2))))
(eq? x 'unquote)))
;; bracket without splicing
(def (bq-bracket1 x d)
(if (and (cons? x) (eq? (car x) 'unquote))
(if (= d 0)
(cadr x)
(list cons ''unquote
(bq-process (cdr x) (- d 1))))
(bq-process x d)))
(def (bq-bracket x d)
(cond ((atom? x) (list list (bq-process x d)))
((eq? (car x) 'unquote)
(if (= d 0)
(cons list (cdr x))
(list list (list cons ''unquote
(bq-process (cdr x) (- d 1))))))
((eq? (car x) 'unquote-splicing)
(if (= d 0)
(list 'copy-list (cadr x))
(list list (list list ''unquote-splicing
(bq-process (cadr x) (- d 1))))))
((eq? (car x) 'unquote-nsplicing)
(if (= d 0)
(cadr x)
(list list (list list ''unquote-nsplicing
(bq-process (cadr x) (- d 1))))))
(else (list list (bq-process x d)))))
(def (bq-process x d)
(cond ((sym? x) (list 'quote x))
((vec? x)
(let ((body (bq-process (vec->list x) d)))
(if (eq? (car body) list)
(cons vec (cdr body))
(list apply vec body))))
((atom? x) x)
((eq? (car x) 'quasiquote)
(list list ''quasiquote (bq-process (cadr x) (+ d 1))))
((eq? (car x) 'unquote)
(if (and (= d 0) (length= x 2))
(cadr x)
(list cons ''unquote (bq-process (cdr x) (- d 1)))))
((not (any splice-form? x))
(let ((lc (lastcdr x))
(forms (map (λ (x) (bq-bracket1 x d)) x)))
(if (not lc)
(cons list forms)
(if (not (cdr forms))
(list cons (car forms) (bq-process lc d))
(nconc (cons list* forms) (list (bq-process lc d)))))))
(else
(let loop ((p x) (q NIL))
(cond ((not p) ;; proper list
(cons 'nconc (reverse! q)))
((cons? p)
(cond ((eq? (car p) 'unquote)
;; (... . ,x)
(cons 'nconc
(nreconc q
(if (= d 0)
(cdr p)
(list (list list ''unquote)
(bq-process (cdr p)
(- d 1)))))))
(else
(loop (cdr p) (cons (bq-bracket (car p) d) q)))))
(else
;; (... . x)
(cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
;;; standard macros
(def (quote-value v)
(if (self-evaluating? v)
v
(list 'quote v)))
(defmacro (let* binds . body)
(if (atom? binds)
`((λ () ,@body))
`((λ (,(caar binds))
,@(if (cons? (cdr binds))
`((let* ,(cdr binds) ,@body))
body))
,(cadar binds))))
(defmacro (when c . body)
(list 'if c (cons 'begin body) NIL))
(defmacro (unless c . body)
(list 'if c NIL (cons 'begin body)))
(defmacro (case key . clauses)
(def (vals->cond key v)
(cond ((eq? v 'else) 'else)
((not v) NIL)
((sym? v) `(eq? ,key ,(quote-value v)))
((atom? v) `(eqv? ,key ,(quote-value v)))
((not (cdr v)) `(eqv? ,key ,(quote-value (car v))))
((every sym? v)
`(memq ,key ',v))
(else `(memv ,key ',v))))
(let ((g (gensym)))
`(let ((,g ,key))
(cond ,.(map (λ (clause)
(cons (vals->cond g (car clause))
(cdr clause)))
clauses)))))
(defmacro (do vars test-spec . commands)
(let ((test-expr (car test-spec))
(vars (map car vars))
(inits (map cadr vars))
(steps (map (λ (x)
(if (cons? (cddr x))
(caddr x)
(car x)))
vars)))
`(letrec ((loop# (λ ,vars
(if ,test-expr
(begin
,@(cdr test-spec))
(begin
,@commands
(loop# ,.steps))))))
(loop# ,.inits))))
; SRFI 8
(defmacro (receive formals expr . body)
`(call-with-values (λ () ,expr)
(λ ,formals ,@body)))
(defmacro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
(λ (,v) ,@body))))
(def (map-int f n)
(and (> n 0)
(let ((first (cons (f 0) NIL))
(acc NIL))
(set! acc first)
(for 1 (1- n)
(λ (i) (set-cdr! acc (cons (f i) NIL))
(set! acc (cdr acc))))
first)))
(def (iota n)
(map-int identity n))
(defmacro (with-bindings binds . body)
(let ((vars (map car binds))
(vals (map cadr binds))
(olds (map (λ (x) (gensym)) binds)))
`(let ,(map list olds vars)
,@(map (λ (v val) `(set! ,v ,val)) vars vals)
(unwind-protect
(begin ,@body)
(begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
;;; exceptions
(def (error . args)
(raise (cons 'error args)))
(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 NIL)
(curr (f s)))
(if (io-eof? s)
(reverse! lines)
(loop (cons curr lines) (f s)))))
(def (io-readlines s)
(read-all-of io-readline s))
(def (read-all s)
(read-all-of read s))
(def (io-readall s)
(let ((b (buffer)))
(io-copy b s)
(io->str b)))
(defmacro (with-output-to io . body)
`(with-bindings ((*io-out* ,io))
,@body))
(defmacro (with-input-from io . body)
`(with-bindings ((*io-in* ,io))
,@body))
;;; vector functions
(def (list->vec l)
(apply vec l))
(def (vec->list v)
(let ((n (length v))
(l NIL))
(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-putrune b (f (str-rune s i)))
(set! i (1+ i))))
(io->str b)))
(def (str-rep s k)
(cond ((< k 4)
(cond ((<= k 0) "")
((= k 1) (str s))
((= k 2) (str s s))
(else (str s s s))))
((odd? k) (str s (str-rep s (- k 1))))
(else (str-rep (str s s) (/ k 2)))))
(def (str-lpad s n c)
(str (str-rep c (- n (str-length s))) s))
(def (str-rpad s n c)
(str s (str-rep c (- n (str-length s)))))
(def (print-to-str . args)
(let ((b (buffer)))
(for-each (λ (a) (write a b)) args)
(io->str b)))
(def (str-join strlist sep)
(if (not strlist)
""
(let ((b (buffer)))
(io-write b (car strlist))
(for-each (λ (s) (io-write b sep)
(io-write b s))
(cdr strlist))
(io->str b))))
;;; structs
(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 "Return stuff." :doc-group stuff 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
[docs+slots (separate-doc-from-body slots)]
[docs (car docs+slots)]
[slots (cdr docs+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 "-"))]}
(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) "")]}
(str hd
"\n\n "
(append (list 'defstruct)
(unless (eq? type vec) (list :type type))
(unless named (list :named named))
(unless constructor (list :constructor constructor))
(if conc-name (list :conc-name conc-name))
(if predicate (list :predicate predicate))
(cons name slots))
tl)))
(when docs
(sym-set-doc name (append docs (list (cons :doc-fmt fmt)))))
`(begin
; predicate
(def (,is? s)
(and [,type? s]
[or (not ',named) (eq? (aref s 0) ',name)]
[= (length s) ,(+ (length named) num-slots)]))
; 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 (and def? (get-defined-vars body)))
(env (nconc (map list dvars) env)))
(if (not def?)
(map (λ (x) (expand-in x env)) body)
(let* ((ex-nondefs ; expand non-definitions
(let loop ((body body))
(cond ((atom? body) body)
((and (cons? (car body))
(eq? 'def (caar body)))
(cons (car body) (loop (cdr body))))
(else
(let ((form (expand-in (car body) env)))
(set! env (nconc
(map list (get-defined-vars form))
env))
(cons
(cons *expanded* form)
(loop (cdr body))))))))
(body ex-nondefs))
(while (cons? body) ; now expand deferred definitions
(if (not (eq? *expanded* (caar body)))
(set-car! body (expand-in (car body) env))
(set-car! body (cdar body)))
(set! body (cdr body)))
ex-nondefs)))))
(def (expand-lambda-list l env)
(if (atom? l)
l
(cons (if (and (cons? (car l)) (cons? (cdr (car l))))
(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+body (separate-doc-from-body (cddr e)))
(doc (car doc+body))
(body (cdr doc+body)))
(when doc
(sym-set-doc name doc))
`(def ,name ,(expand-in (car body) env))))
(let* ((formals (cdadr e))
(name (caadr e))
(doc+body (separate-doc-from-body (cddr e)))
(doc (car doc+body))
(body (cdr doc+body))
(vars (l-vars formals))
(menv (nconc (map list vars) env)))
(when doc
(sym-set-doc name doc formals))
`(def ,(cons name (expand-lambda-list formals menv))
,.(expand-body body menv)))))
(def (expand-let-syntax e env)
(let ((binds (cadr e)))
(cons 'begin
(expand-body (cddr e)
(nconc
(map (λ (bind)
(list (car bind)
((compile-thunk
(expand-in (cadr bind) env)))
env))
binds)
env)))))
; given let-syntax definition environment (menv) and environment
; at the point of the macro use (lenv), return the environment to
; expand the macro use in. TODO
(def (local-expansion-env menv lenv) menv)
(def (expand-in e env)
(if (atom? e)
e
(let* ((head (car e))
(bnd (assq head env))
(default (λ ()
(let loop ((e e))
(if (atom? e)
e
(cons (if (atom? (car e))
(car e)
(expand-in (car e) env))
(loop (cdr e))))))))
(cond ((and bnd (cons? (cdr bnd))) ; local macro
(expand-in (apply (cadr bnd) (cdr e))
(local-expansion-env (caddr bnd) env)))
((macrocall? e) => (λ (f)
(expand-in (apply f (cdr e)) env)))
((or bnd ; bound lexical or toplevel var
(not (sym? head))
(bound? head))
(default))
((eq? head 'quote) e)
((eq? head 'λ) (expand-lambda e env))
((eq? head 'def) (expand-define e env))
((eq? head 'let-syntax) (expand-let-syntax e env))
(else (default))))))
(expand-in e NIL))
(def (eval x)
((compile-thunk (macroexpand x))))
(def (load-process x)
(eval x))
(def (load filename)
(let ((F (file filename :read)))
(trycatch
(let next (prev E v)
(if (not (io-eof? F))
(next (read F)
prev
(begin (load-process E) (void)))
(begin (io-close F)
; evaluate last form in almost-tail position
(void (load-process E)))))
(λ (e)
(io-close F)
(raise `(load-error ,filename ,e))))))
(def (repl)
(*prompt*)
(io-flush *io-out*)
(def (prompt)
(let ((v (trycatch (read *io-in* :whitespace T)
(λ (e) (io-discardbuffer *io-in*)
(raise e)))))
(and (not (io-eof? *io-in*))
(let ((V (load-process v)))
(if (void? V)
(when (void? v)
(*prompt*)
(io-flush *io-out*))
(begin (print V)
(newline)))
(void (set! that V))))))
(def (reploop)
(when (trycatch (prompt)
(λ (e)
(top-level-exception-handler e)
T))
(reploop)))
(reploop)
(newline))
(def (top-level-exception-handler e)
(with-output-to *stderr*
(print-exception e)
(print-stack-trace (stacktrace))))
(def (print-stack-trace st)
(def (find-in-f f tgt path)
(let ((path (cons (fn-name f) path)))
(if (eq? (fn-code f) (fn-code tgt))
(throw 'ffound path)
(let ((v (fn-vals f)))
(for 0 (1- (length v))
(λ (i) (when (closure? (aref v i))
(find-in-f (aref v i) tgt path))))))))
(def (fname f e)
(let ((p (catch 'ffound
(begin
(for-each (λ (topfun)
(find-in-f topfun f NIL))
e)
NIL))))
(if p
(str-join (map str (reverse! p)) "/")
"λ")))
(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 (sort l cmp (:key identity))
(if (not (cdr l))
l
(let ((piv (car l)))
(receive (less grtr)
(partition (λ (x) (cmp (key x) (key piv))) (cdr l))
(nconc (sort less cmp :key key)
(list piv)
(sort grtr cmp :key key))))))
(def (make-system-image fname)
(let ((f (file fname :write :create :truncate))
(excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
*print-pretty* *print-width* *print-readably*
*print-level* *print-length* *os-name* *interactive*
*prompt* *os-version*)))
(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*))