ref: bdb751c9fa7754d1e2df51773e9dc9e119ed58b8
parent: a4055b3185d796477984c88dbce9e833695ebf4f
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Fri Feb 7 14:33:57 EST 2025
define → def, define-macro → defmacro Less typing.
--- a/README.md
+++ b/README.md
@@ -20,13 +20,14 @@
Some of the changes from the original include:
* aggressive clean up, removal, renaming and refactoring
- * docstrings - `(define (f ...) "Docs here" ...)` and `(help ...)`
- * proper `(void)` and `void?`
- * better error reporting - disassembly at the current instruction, location of syntax errors
* seamless bignums
* `[` and `]`, `{` and `}` are synonyms to `(` and `)`+ * `define` → `def`, `define-macro` → `defmacro`
* `λ` as a shorthand for `lambda`
+ * docstrings - `(def (f ...) "Docs here" ...)` and `(help ...)`
* automatic gensyms for macros (`blah#`) at read time
+ * proper `(void)` and `void?`
+ * better error reporting - disassembly at the current instruction, location of syntax errors
* some of the previously available (but not merged) patches from the community and [Julia](https://github.com/JuliaLang/julia) are applied
* `c***r` of empty list returns empty list
* "boot" image is built into the executable
binary files a/boot/flisp.boot.builtin b/boot/flisp.boot.builtin differ
--- a/src/compiler.lsp
+++ b/src/compiler.lsp
@@ -2,16 +2,16 @@
;; code generation state, constant tables, bytecode encoding
-(define (make-code-emitter) (vector () (table) 0 () 0))
-(define-macro (bcode:code b) `(aref ,b 0))
-(define-macro (bcode:ctable b) `(aref ,b 1))
-(define-macro (bcode:nconst b) `(aref ,b 2))
-(define-macro (bcode:cenv b) `(aref ,b 3))
-(define-macro (bcode:sp b) `(aref ,b 4))
-(define-macro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
+(def (make-code-emitter) (vector () (table) 0 () 0))
+(defmacro (bcode:code b) `(aref ,b 0))
+(defmacro (bcode:ctable b) `(aref ,b 1))
+(defmacro (bcode:nconst b) `(aref ,b 2))
+(defmacro (bcode:cenv b) `(aref ,b 3))
+(defmacro (bcode:sp b) `(aref ,b 4))
+(defmacro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
;; get an index for a referenced value in a bytecode object
-(define (bcode:indexfor b v)
+(def (bcode:indexfor b v)
(let ((const-to-idx (bcode:ctable b))
(nconst (bcode:nconst b)))
(if (has? const-to-idx v)
@@ -20,8 +20,8 @@
(prog1 nconst
(aset! b 2 (+ nconst 1)))))))
-(define (emit e inst . args)
- (define (load? i)
+(def (emit e inst . args)
+ (def (load? i)
(member i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet
(let ((bc (aref e 0)))
(if (null? args)
@@ -78,12 +78,12 @@
(aset! e 0 (nreconc (cons inst args) bc)))))))
e))
-(define-macro (make-label e) `(gensym))
-(define-macro (mark-label e l) `(emit ,e 'label ,l))
+(defmacro (make-label e) `(gensym))
+(defmacro (mark-label e l) `(emit ,e 'label ,l))
;; convert symbolic bytecode representation to a byte array.
;; labels are fixed-up.
-(define (encode-byte-code e)
+(def (encode-byte-code e)
(let* ((cl (reverse! e))
(v (list->vector cl))
(long? (>= (+ (length v) ;; 1 byte for each entry, plus...
@@ -159,7 +159,7 @@
fixup-to-label)
(iostream->string bcode))))
-(define (const-to-idx-vec e)
+(def (const-to-idx-vec e)
(let ((cvec (vector-alloc (bcode:nconst e))))
(for-each (λ (val idx) (aset! cvec idx val))
(bcode:ctable e))
@@ -167,14 +167,14 @@
;; variables
-(define (vinfo sym heap? index) (list sym heap? index))
-(define vinfo:sym car)
-(define vinfo:heap? cadr)
-(define vinfo:index caddr)
+(def (vinfo sym heap? index) (list sym heap? index))
+(def vinfo:sym car)
+(def vinfo:heap? cadr)
+(def vinfo:index caddr)
-(define (quoted? e) (eq? (car e) 'quote))
+(def (quoted? e) (eq? (car e) 'quote))
-(define (capture-var! g sym)
+(def (capture-var! g sym)
(let ((ce (bcode:cenv g)))
(let ((n (index-of sym ce 0)))
(or n
@@ -181,17 +181,17 @@
(prog1 (length ce)
(aset! g 3 (nconc ce (list sym))))))))
-(define (index-of item lst start)
+(def (index-of item lst start)
(cond ((null? lst) #f)
((eq? item (car lst)) start)
(else (index-of item (cdr lst) (+ start 1)))))
-(define (in-env? s env)
+(def (in-env? s env)
(and (cons? env)
(or (assq s (car env))
(in-env? s (cdr env)))))
-(define (lookup-sym s env lev)
+(def (lookup-sym s env lev)
(if (null? env)
'global
(let* ((curr (car env))
@@ -202,11 +202,11 @@
(cdr env)
(+ lev 1))))))
-(define (printable? x) (not (or (iostream? x)
+(def (printable? x) (not (or (iostream? x)
(void? x)
(eof-object? x))))
-(define (compile-sym g env s deref)
+(def (compile-sym g env s deref)
(let ((loc (lookup-sym s env 0)))
(cond ((eq? loc 'global)
(if (and (constant? s)
@@ -224,7 +224,7 @@
(if (and deref (vinfo:heap? (cdr loc)))
(emit g 'car))))))
-(define (compile-aset! g env args)
+(def (compile-aset! g env args)
(let ((nref (- (length args) 2)))
(cond ((= nref 1)
(compile-app g env #f (cons 'aset! args)))
@@ -235,7 +235,7 @@
(emit g 'aset!)))
(else (argc-error 'aset! 3)))))
-(define (compile-set! g env s rhs)
+(def (compile-set! g env s rhs)
(let ((loc (lookup-sym s env 0)))
(if (eq? loc 'global)
(begin (compile-in g env #f rhs)
@@ -256,7 +256,7 @@
(if (not arg?) (error (string "internal error: misallocated var " s)))
(emit g 'seta idx))))))))
-(define (box-vars g env)
+(def (box-vars g env)
(let loop ((e env))
(if (cons? e)
(begin (if (cadr (car e))
@@ -265,7 +265,7 @@
;; control flow
-(define (compile-if g env tail? x)
+(def (compile-if g env tail? x)
(let ((thenl (make-label g))
(elsel (make-label g))
(endl (make-label g))
@@ -290,7 +290,7 @@
(compile-in g env tail? else)
(mark-label g endl)))))
-(define (compile-begin g env tail? forms)
+(def (compile-begin g env tail? forms)
(cond ((atom? forms) (compile-in g env tail? (void)))
((atom? (cdr forms))
(compile-in g env tail? (car forms)))
@@ -299,7 +299,7 @@
(emit g 'pop)
(compile-begin g env tail? (cdr forms)))))
-(define (compile-prog1 g env x)
+(def (compile-prog1 g env x)
(compile-in g env #f (cadr x))
(if (cons? (cddr x))
(begin (bcode:stack g 1)
@@ -307,7 +307,7 @@
(emit g 'pop)
(bcode:stack g -1))))
-(define (compile-while g env cond body)
+(def (compile-while g env cond body)
(let ((top (make-label g))
(end (make-label g)))
(compile-in g env #f (void))
@@ -321,16 +321,16 @@
(emit g 'jmp top)
(mark-label g end)))
-(define (is-lambda? a)
+(def (is-lambda? a)
(or (eq? a 'λ)
(eq? a 'lambda)))
-(define (1arg-lambda? func)
+(def (1arg-lambda? func)
(and (cons? func)
(is-lambda? (car func))
(length= (cadr func) 1)))
-(define (compile-short-circuit g env tail? forms default branch outl)
+(def (compile-short-circuit g env tail? forms default branch outl)
(cond ((atom? forms) (compile-in g env tail? default outl))
((atom? (cdr forms)) (compile-in g env tail? (car forms) outl))
(else
@@ -344,14 +344,14 @@
(compile-short-circuit g env tail? (cdr forms) default branch outl)
(unless outl (mark-label g end))))))
-(define (compile-and g env tail? forms outl)
+(def (compile-and g env tail? forms outl)
(compile-short-circuit g env tail? forms #t 'brf outl))
-(define (compile-or g env tail? forms)
+(def (compile-or g env tail? forms)
(compile-short-circuit g env tail? forms #f 'brt #f))
;; calls
-(define (compile-arglist g env lst)
+(def (compile-arglist g env lst)
(for-each (λ (a)
(compile-in g env #f a)
(bcode:stack g 1))
@@ -358,13 +358,13 @@
lst)
(length lst))
-(define (argc-error head count)
+(def (argc-error head count)
(error "compile error: " head " expects " count
(if (= count 1)
" argument."
" arguments.")))
-(define builtin->instruction
+(def builtin->instruction
(let ((b2i (table number? 'number? cons 'cons
fixnum? 'fixnum? equal? 'equal?
eq? 'eq? symbol? 'symbol?
@@ -381,8 +381,8 @@
(λ (b)
(get b2i b #f))))
-(define (compile-builtin-call g env tail? x head b nargs)
- (define (num-compare)
+(def (compile-builtin-call g env tail? x head b nargs)
+ (def (num-compare)
(if (= nargs 0)
(argc-error b 1)
(emit g b nargs)))
@@ -420,7 +420,7 @@
(else (argc-error b 2))))
(else (emit g b)))))
-(define (inlineable? form)
+(def (inlineable? form)
(let ((lam (car form)))
(and (cons? lam)
(is-lambda? (car lam))
@@ -430,7 +430,7 @@
(length= (cadr lam) (length (cdr form))))))
;; compile call to lambda in head position, inlined
-(define (compile-let g env tail? form)
+(def (compile-let g env tail? form)
(let ((lam (car form))
(args (cdr form))
(sp (bcode:sp g)))
@@ -447,7 +447,7 @@
(if (and (> n 0) (not tail?))
(emit g 'shift n)))))))
-(define (compile-app g env tail? x)
+(def (compile-app g env tail? x)
(let ((head (car x)))
(let ((head
(if (and (symbol? head)
@@ -488,9 +488,9 @@
;; lambda, main compilation loop
-(define (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
+(def (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
-(define (compile-in g env tail? x (outl #f))
+(def (compile-in g env tail? x (outl #f))
(cond ((symbol? x) (compile-sym g env x #t))
((atom? x)
(cond ((eq? x 0) (emit g 'load0))
@@ -546,15 +546,15 @@
;; optional and keyword args
-(define (keyword-arg? x) (and (cons? x) (keyword? (car x))))
-(define (keyword->symbol k)
+(def (keyword-arg? x) (and (cons? x) (keyword? (car x))))
+(def (keyword->symbol k)
(if (keyword? k)
(symbol (let ((s (string k)))
(string-sub s 1 (string-length s))))
k))
-(define (lambda-vars l)
- (define (check-formals l o opt kw)
+(def (lambda-vars l)
+ (def (check-formals l o opt kw)
(cond ((or (null? l) (symbol? l)) #t)
((and (cons? l) (symbol? (car l)))
(if (or opt kw)
@@ -584,7 +584,7 @@
(map (λ (s) (if (cons? s) (keyword->symbol (car s)) s))
(to-proper l)))
-(define (emit-optional-arg-inits g env opta vars i)
+(def (emit-optional-arg-inits g env opta vars i)
; i is the lexical var index of the opt arg to process next
(if (cons? opta)
(let ((nxt (make-label g)))
@@ -598,7 +598,7 @@
;; define
-(define (expand-define x)
+(def (expand-define x)
;; expand a single `define` expression to `set!`
(let* ((form (cadr x))
(body (if (cons? (cddr x))
@@ -611,11 +611,11 @@
`(#.void (set! ,(car form)
(λ ,(cdr form) ,@body . ,(car form)))))))
-(define get-defined-vars
+(def get-defined-vars
(letrec ((get-defined-vars-
(λ (expr)
(cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
+ ((and (eq? (car expr) 'def)
(cons? (cdr expr)))
(or (and (symbol? (cadr expr))
(list (cadr expr)))
@@ -628,9 +628,9 @@
(else ())))))
(λ (expr) (delete-duplicates (get-defined-vars- expr)))))
-(define (lower-define e)
+(def (lower-define e)
;; convert lambda to one body expression and process internal defines
- (define (λ-body e)
+ (def (λ-body e)
(let* ((B (if (cons? (cddr e))
(if (cons? (cdddr e))
(cons 'begin (cddr e))
@@ -644,7 +644,7 @@
(map void V)))))
(cond ((or (atom? e) (quoted? e))
e)
- ((eq? (car e) 'define)
+ ((eq? (car e) 'def)
(lower-define (expand-define e)))
((is-lambda? (car e))
`(λ ,(cadr e) ,(λ-body e) . ,(lastcdr e)))
@@ -653,16 +653,16 @@
;; closure analysis
-(define (lambda:body e) (caddr e))
-(define (lambda:vars e) (lambda-vars (cadr e)))
+(def (lambda:body e) (caddr e))
+(def (lambda:vars e) (lambda-vars (cadr e)))
-(define (diff s1 s2)
+(def (diff s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (diff (cdr s1) s2))
(else (cons (car s1) (diff (cdr s1) s2)))))
;; bindings that are both captured and set!'d
-(define (complex-bindings- e vars head nested capt setd)
+(def (complex-bindings- e vars head nested capt setd)
(cond ((null? vars) #f)
((symbol? e)
(if (and nested (memq e vars))
@@ -685,7 +685,7 @@
(complex-bindings- x vars #f nested capt setd))
(cdr e))))))
-(define (complex-bindings e vars)
+(def (complex-bindings e vars)
(let ((capt (table))
(setd (table)))
(complex-bindings- e vars #f #f capt setd)
@@ -692,28 +692,28 @@
(filter (λ (x) (has? capt x))
(table-keys setd))))
-(define (vars-to-env vars cb offs)
+(def (vars-to-env vars cb offs)
(map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
vars (iota (length vars))))
-(define (extend-env env vars cb)
+(def (extend-env env vars cb)
(cons (vars-to-env vars cb 0)
env))
;; main entry points
-(define (compile f) (compile-f () (lower-define f)))
+(def (compile f) (compile-f () (lower-define f)))
-(define (compile-thunk expr)
+(def (compile-thunk expr)
;; to eval a top-level expression we need to avoid internal define
(compile-f () `(λ () ,(lower-define expr))))
-(define (compile-f env f)
+(def (compile-f env f)
(receive (ff ignore)
(compile-f- env f)
ff))
-(define (compile-f- env f)
+(def (compile-f- env f)
;; compile lambda expression, assuming defines already lowered
(let ((g (make-code-emitter))
(args (cadr f))
@@ -760,20 +760,20 @@
;; disassembler
-(define (ref-int32-LE a i)
+(def (ref-int32-LE a i)
(int32 (+ (ash (aref a (+ i 0)) 0)
(ash (aref a (+ i 1)) 8)
(ash (aref a (+ i 2)) 16)
(ash (aref a (+ i 3)) 24))))
-(define (ref-int16-LE a i)
+(def (ref-int16-LE a i)
(int16 (+ (ash (aref a (+ i 0)) 0)
(ash (aref a (+ i 1)) 8))))
-(define (hex5 n)
+(def (hex5 n)
(string-lpad (number->string n 16) 5 #\0))
-(define (disassemble f (ip #f) . lev?)
+(def (disassemble f (ip #f) . lev?)
(if (null? lev?)
(begin (disassemble f ip 0)
(newline)
@@ -781,12 +781,12 @@
(let ((lev (car lev?))
(code (function:code f))
(vals (function:vals f)))
- (define (print-val v)
+ (def (print-val v)
(if (and (function? v) (not (builtin? v)))
(begin (newline)
(disassemble v #f (+ lev 1)))
(print v)))
- (define (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
+ (def (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
" >"
" ")
(hex5 (- s 5)) ": "
@@ -864,8 +864,8 @@
; X = (* 2 ($hash-keyword K N))
;
; and the associated value is at index X+1.
-(define (make-perfect-hash-table alist)
- (define ($hash-keyword key n) (mod0 (abs (hash key)) n))
+(def (make-perfect-hash-table alist)
+ (def ($hash-keyword key n) (mod0 (abs (hash key)) n))
(let loop1 ((n (length alist)))
(let ((v (vector-alloc (* 2 n) #f)))
(let loop2 ((lst alist))
--- a/src/docs_extra.lsp
+++ b/src/docs_extra.lsp
@@ -1,4 +1,4 @@
-(define-macro (doc-for term (doc #f))
+(defmacro (doc-for term (doc #f))
(let* ((sym (or (and (cons? term) (car term)) term))
(val (top-level-value sym))
(funvars (and (cons? term) (cdr term))))
--- a/src/system.lsp
+++ b/src/system.lsp
@@ -5,7 +5,7 @@
;;; void
-(define (void . rest)
+(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
@@ -13,7 +13,7 @@
it."
#.(void))
-(define (void? x)
+(def (void? x)
"Return #t if x is #<void> and #f otherwise."
(eq? x #.(void)))
@@ -20,12 +20,12 @@
;;; syntax environment
(unless (bound? '*syntax-environment*)
- (define *syntax-environment* (table)))
+ (def *syntax-environment* (table)))
-(define (set-syntax! s v) (put! *syntax-environment* s v))
-(define (symbol-syntax s) (get *syntax-environment* s #f))
+(def (set-syntax! s v) (put! *syntax-environment* s v))
+(def (symbol-syntax s) (get *syntax-environment* s #f))
-(define-macro (define-macro form . body)
+(defmacro (defmacro form . body)
(let ((doc (value-get-doc body)))
(when doc
(symbol-set-doc (car form) doc (cdr form))
@@ -33,13 +33,13 @@
`(void (set-syntax! ',(car form)
(λ ,(cdr form) ,@body)))))
-(define-macro (letrec binds . body)
+(defmacro (letrec binds . body)
`((λ ,(map car binds)
,.(map (λ (b) `(set! ,@b)) binds)
,@body)
,.(map void binds)))
-(define-macro (let binds . body)
+(defmacro (let binds . body)
(let ((lname #f))
(when (symbol? binds)
(set! lname binds)
@@ -56,8 +56,8 @@
thelambda)
theargs))))
-(define-macro (cond . clauses)
- (define (cond-clauses->if lst)
+(defmacro (cond . clauses)
+ (def (cond-clauses->if lst)
(if (atom? lst)
#f
(let ((clause (car lst)))
@@ -99,9 +99,9 @@
;; 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*)
- (define *properties* (table)))
+ (def *properties* (table)))
-(define (putprop sym key val)
+(def (putprop sym key val)
(let ((kt (get *properties* key #f)))
(unless kt
(let ((t (table)))
@@ -110,17 +110,17 @@
(put! kt sym val)
val))
-(define (getprop sym key (def #f))
+(def (getprop sym key (def #f))
(let ((kt (get *properties* key #f)))
(or (and kt (get kt sym def)) def)))
-(define (remprop sym key)
+(def (remprop sym key)
(let ((kt (get *properties* key #f)))
(and kt (has? kt sym) (del! kt sym))))
;;; documentation
-(define (symbol-set-doc sym doc . funvars)
+(def (symbol-set-doc sym doc . funvars)
(when doc
(putprop sym '*doc* doc))
(when (cons? funvars)
@@ -132,7 +132,7 @@
'*properties*
"All properties of symbols recorded with putprop are recorded in this table.")
-(define-macro (help term)
+(defmacro (help term)
"Display documentation for the specified term, if available."
(let* ((doc (getprop term '*doc*)))
(if doc
@@ -147,7 +147,7 @@
(newline)))
(void)))
-(define (value-get-doc body)
+(def (value-get-doc body)
(let ((first (car body))
(rest (cdr body)))
(and (string? first) (cons? rest) first)))
@@ -154,25 +154,25 @@
;;; standard procedures
-(define (member item lst)
+(def (member item lst)
(cond ((null? lst) #f)
((equal? (car lst) item) lst)
(#t (member item (cdr lst)))))
-(define (memv item lst)
+(def (memv item lst)
(cond ((null? lst) #f)
((eqv? (car lst) item) lst)
(#t (memv item (cdr lst)))))
-(define (assoc item lst)
+(def (assoc item lst)
(cond ((null? lst) #f)
((equal? (caar lst) item) (car lst))
(#t (assoc item (cdr lst)))))
-(define (assv item lst)
+(def (assv item lst)
(cond ((null? lst) #f)
((eqv? (caar lst) item) (car lst))
(#t (assv item (cdr lst)))))
-(define (> a . rest)
+(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))
@@ -179,10 +179,10 @@
(or (null? rest)
(and (< (car rest) a)
(loop (car rest) (cdr rest))))))
-(define-macro (> a . rest)
+(defmacro (> a . rest)
`(< ,@(reverse! rest) ,a))
-(define (<= a . rest)
+(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))
@@ -191,7 +191,7 @@
(nan? a))
(loop (car rest) (cdr rest))))))
-(define (>= a . 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))
@@ -200,69 +200,69 @@
(nan? a))
(loop (car rest) (cdr rest))))))
-(define-macro (/= a . rest)
+(defmacro (/= a . rest)
"Return #t if not all arguments are equal. Shorthand for (not (= …))."
`(not (= ,a ,@rest)))
-(define (negative? x) (< x 0))
-(define (zero? x) (= x 0))
-(define (positive? x) (> x 0))
-(define (even? x) (= (logand x 1) 0))
-(define (odd? x) (not (even? x)))
-(define (identity x) x)
-(define (1+ n) (+ n 1))
-(define (1- n) (- n 1))
-(define (mod0 x y) (- x (* (div0 x y) y)))
-(define (div x y) (+ (div0 x y)
+(def (negative? x) (< x 0))
+(def (zero? x) (= x 0))
+(def (positive? x) (> x 0))
+(def (even? x) (= (logand x 1) 0))
+(def (odd? x) (not (even? x)))
+(def (identity x) x)
+(def (1+ n) (+ n 1))
+(def (1- n) (- n 1))
+(def (mod0 x y) (- x (* (div0 x y) y)))
+(def (div x y) (+ (div0 x y)
(or (and (< x 0)
(or (and (< y 0) 1)
-1))
0)))
-(define (mod x y) (- x (* (div x y) y)))
-(define (random n)
+(def (mod x y) (- x (* (div x y) y)))
+(def (random n)
(if (integer? n)
(mod (rand) n)
(* (rand-double) n)))
-(define (abs x) (if (< x 0) (- x) x))
-(define (max x0 . xs)
+(def (abs x) (if (< x 0) (- x) x))
+(def (max x0 . xs)
(if (null? xs) x0
(foldl (λ (a b) (if (< a b) b a)) x0 xs)))
-(define (min x0 . xs)
+(def (min x0 . xs)
(if (null? xs) x0
(foldl (λ (a b) (if (< a b) a b)) x0 xs)))
-(define (char? x) (eq? (typeof x) 'rune))
-(define (array? x) (or (vector? x)
+(def (char? x) (eq? (typeof x) 'rune))
+(def (array? x) (or (vector? x)
(let ((t (typeof x)))
(and (cons? t) (eq? (car t) 'array)))))
-(define (closure? x) (and (function? x) (not (builtin? x))))
+(def (closure? x) (and (function? x) (not (builtin? x))))
-(define (caar x) (car (car x)))
-(define (cdar x) (cdr (car x)))
-(define (cddr x) (cdr (cdr x)))
-(define (caaar x) (car (car (car x))))
-(define (caadr x) (car (car (cdr x))))
-(define (cadar x) (car (cdr (car x))))
-(define (caddr x) (car (cdr (cdr x))))
-(define (cdaar x) (cdr (car (car x))))
-(define (cdadr x) (cdr (car (cdr x))))
-(define (cddar x) (cdr (cdr (car x))))
-(define (cdddr x) (cdr (cdr (cdr x))))
-(define (caaaar x) (car (car (car (car x)))))
-(define (caaadr x) (car (car (car (cdr x)))))
-(define (caadar x) (car (car (cdr (car x)))))
-(define (caaddr x) (car (car (cdr (cdr x)))))
-(define (cadaar x) (car (cdr (car (car x)))))
-(define (cadadr x) (car (cdr (car (cdr x)))))
-(define (caddar x) (car (cdr (cdr (car x)))))
-(define (cadddr x) (car (cdr (cdr (cdr x)))))
-(define (cdaaar x) (cdr (car (car (car x)))))
-(define (cdaadr x) (cdr (car (car (cdr x)))))
-(define (cdadar x) (cdr (car (cdr (car x)))))
-(define (cdaddr x) (cdr (car (cdr (cdr x)))))
-(define (cddaar x) (cdr (cdr (car (car x)))))
-(define (cddadr x) (cdr (cdr (car (cdr x)))))
-(define (cdddar x) (cdr (cdr (cdr (car x)))))
-(define (cddddr x) (cdr (cdr (cdr (cdr 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
@@ -279,31 +279,31 @@
;;; list utilities
-(define (every pred lst)
+(def (every pred lst)
(or (atom? lst)
(and (pred (car lst))
(every pred (cdr lst)))))
-(define (any pred lst)
+(def (any pred lst)
(and (cons? lst)
(or (pred (car lst))
(any pred (cdr lst)))))
-(define (list? a) (or (null? a) (and (cons? a) (list? (cdr a)))))
+(def (list? a) (or (null? a) (and (cons? a) (list? (cdr a)))))
-(define (list-tail lst n)
+(def (list-tail lst n)
(if (<= n 0) lst
(list-tail (cdr lst) (- n 1))))
-(define (list-head lst n)
+(def (list-head lst n)
(if (<= n 0) ()
(cons (car lst)
(list-head (cdr lst) (- n 1)))))
-(define (list-ref lst n)
+(def (list-ref lst n)
(car (list-tail lst n)))
-(define (length= lst n)
+(def (length= lst n)
"Bounded length test.
Use this instead of (= (length lst) n), since it avoids unnecessary
work and always terminates."
@@ -312,35 +312,35 @@
((atom? lst) (= n 0))
(else (length= (cdr lst) (- n 1)))))
-(define (length> lst n)
+(def (length> lst n)
(cond ((< n 0) lst)
((= n 0) (and (cons? lst) lst))
((atom? lst) (< n 0))
(else (length> (cdr lst) (- n 1)))))
-(define (last-pair l)
+(def (last-pair l)
(if (atom? (cdr l))
l
(last-pair (cdr l))))
-(define (lastcdr l)
+(def (lastcdr l)
(if (atom? l)
l
(cdr (last-pair l))))
-(define (to-proper l)
+(def (to-proper l)
(cond ((null? l) l)
((atom? l) (list l))
(else (cons (car l) (to-proper (cdr l))))))
-(define (map! f lst)
+(def (map! f lst)
(prog1 lst
(while (cons? lst)
(set-car! lst (f (car lst)))
(set! lst (cdr lst)))))
-(define (filter pred lst)
- (define (filter- f lst acc)
+(def (filter pred lst)
+ (def (filter- f lst acc)
(cdr
(prog1 acc
(while (cons? lst)
@@ -350,8 +350,8 @@
(set! lst (cdr lst))))))
(filter- pred lst (list ())))
-(define (partition pred lst)
- (define (partition- pred lst yes no)
+(def (partition pred lst)
+ (def (partition- pred lst yes no)
(let ((vals
(prog1
(cons yes no)
@@ -363,8 +363,8 @@
(values (cdr (car vals)) (cdr (cdr vals)))))
(partition- pred lst (list ()) (list ())))
-(define (count f l)
- (define (count- f l n)
+(def (count f l)
+ (def (count- f l n)
(if (null? l)
n
(count- f (cdr l) (if (f (car l))
@@ -372,25 +372,25 @@
n))))
(count- f l 0))
-(define (nestlist f zero n)
+(def (nestlist f zero n)
(if (<= n 0) ()
(cons zero (nestlist f (f zero) (- n 1)))))
-(define (foldr f zero lst)
+(def (foldr f zero lst)
(if (null? lst) zero
(f (car lst) (foldr f zero (cdr lst)))))
-(define (foldl f zero lst)
+(def (foldl f zero lst)
(if (null? lst) zero
(foldl f (f (car lst) zero) (cdr lst))))
-(define (reverse- zero lst)
+(def (reverse- zero lst)
(if (null? lst) zero
(reverse- (cons (car lst) zero) (cdr lst))))
-(define (reverse lst) (reverse- () lst))
+(def (reverse lst) (reverse- () lst))
-(define (reverse!- prev l)
+(def (reverse!- prev l)
(while (cons? l)
(set! l (prog1 (cdr l)
(set-cdr! l (prog1 prev
@@ -397,14 +397,14 @@
(set! prev l))))))
prev)
-(define (reverse! l) (reverse!- () l))
+(def (reverse! l) (reverse!- () l))
-(define (copy-tree l)
+(def (copy-tree l)
(if (atom? l) l
(cons (copy-tree (car l))
(copy-tree (cdr l)))))
-(define (delete-duplicates lst)
+(def (delete-duplicates lst)
(if (length> lst 20)
(let ((t (table)))
(let loop ((l lst) (acc '()))
@@ -426,10 +426,10 @@
;;; backquote
-(define (revappend l1 l2) (reverse- l2 l1))
-(define (nreconc l1 l2) (reverse!- l2 l1))
+(def (revappend l1 l2) (reverse- l2 l1))
+(def (nreconc l1 l2) (reverse!- l2 l1))
-(define (self-evaluating? x)
+(def (self-evaluating? x)
(and (not (gensym? x))
(or (and (atom? x)
(not (symbol? x)))
@@ -437,9 +437,9 @@
(symbol? x)
(eq? x (top-level-value x))))))
-(define-macro (quasiquote x) (bq-process x 0))
+(defmacro (quasiquote x) (bq-process x 0))
-(define (splice-form? x)
+(def (splice-form? x)
(or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
(eq? (car x) 'unquote-nsplicing)
(and (eq? (car x) 'unquote)
@@ -447,7 +447,7 @@
(eq? x 'unquote)))
;; bracket without splicing
-(define (bq-bracket1 x d)
+(def (bq-bracket1 x d)
(if (and (cons? x) (eq? (car x) 'unquote))
(if (= d 0)
(cadr x)
@@ -455,7 +455,7 @@
(bq-process (cdr x) (- d 1))))
(bq-process x d)))
-(define (bq-bracket x d)
+(def (bq-bracket x d)
(cond ((atom? x) (list list (bq-process x d)))
((eq? (car x) 'unquote)
(if (= d 0)
@@ -474,7 +474,7 @@
(bq-process (cadr x) (- d 1))))))
(else (list list (bq-process x d)))))
-(define (bq-process x d)
+(def (bq-process x d)
(cond ((symbol? x) (list 'quote x))
((vector? x)
(let ((body (bq-process (vector->list x) d)))
@@ -518,12 +518,12 @@
;;; standard macros
-(define (quote-value v)
+(def (quote-value v)
(if (self-evaluating? v)
v
(list 'quote v)))
-(define-macro (let* binds . body)
+(defmacro (let* binds . body)
(if (atom? binds) `((λ () ,@body))
`((λ (,(caar binds))
,@(if (cons? (cdr binds))
@@ -531,11 +531,11 @@
body))
,(cadar binds))))
-(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
-(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
+(defmacro (when c . body) (list 'if c (cons 'begin body) #f))
+(defmacro (unless c . body) (list 'if c #f (cons 'begin body)))
-(define-macro (case key . clauses)
- (define (vals->cond key v)
+(defmacro (case key . clauses)
+ (def (vals->cond key v)
(cond ((eq? v 'else) 'else)
((null? v) #f)
((symbol? v) `(eq? ,key ,(quote-value v)))
@@ -551,7 +551,7 @@
(cdr clause)))
clauses)))))
-(define-macro (do vars test-spec . commands)
+(defmacro (do vars test-spec . commands)
(let ((test-expr (car test-spec))
(vars (map car vars))
(inits (map cadr vars))
@@ -570,17 +570,17 @@
(loop# ,.inits))))
; SRFI 8
-(define-macro (receive formals expr . body)
+(defmacro (receive formals expr . body)
`(call-with-values (λ () ,expr)
(λ ,formals ,@body)))
-(define-macro (dotimes var . body)
+(defmacro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
(λ (,v) ,@body))))
-(define (map-int f n)
+(def (map-int f n)
(if (<= n 0)
nil
(let ((first (cons (f 0) ()))
@@ -591,9 +591,9 @@
(set! acc (cdr acc))))
first)))
-(define (iota n) (map-int identity n))
+(def (iota n) (map-int identity n))
-(define-macro (with-bindings binds . body)
+(defmacro (with-bindings binds . body)
(let ((vars (map car binds))
(vals (map cadr binds))
(olds (map (λ (x) (gensym)) binds)))
@@ -605,10 +605,10 @@
;;; exceptions
-(define (error . args) (raise (cons 'error args)))
+(def (error . args) (raise (cons 'error args)))
-(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
-(define-macro (catch tag expr)
+(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)
@@ -616,7 +616,7 @@
(caddr e#)
(raise e#)))))
-(define-macro (unwind-protect expr finally)
+(defmacro (unwind-protect expr finally)
`(let ((thk# (λ () ,finally)))
(prog1 (trycatch ,expr
(λ (e#) (begin (thk#) (raise e#))))
@@ -624,9 +624,9 @@
;;; debugging utilities
-(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
+(defmacro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
-(define traced?
+(def traced?
(letrec ((sample-traced-lambda (λ args (begin (write (cons 'x args))
(newline)
(apply #.apply args)))))
@@ -635,7 +635,7 @@
(equal? (function:code f)
(function:code sample-traced-lambda))))))
-(define (trace sym)
+(def (trace sym)
(let* ((func (top-level-value sym)))
(when (not (traced? func))
(set-top-level-value! sym
@@ -646,7 +646,7 @@
(apply ',func args#)))))))
(void))
-(define (untrace sym)
+(def (untrace sym)
(let ((func (top-level-value sym)))
(when (traced? func)
(set-top-level-value! sym
@@ -653,7 +653,7 @@
(aref (function:vals func) 3))))
(void))
-(define-macro (time expr)
+(defmacro (time expr)
`(let ((t0# (time-now)))
(prog1
,expr
@@ -661,19 +661,19 @@
;;; text I/O
-(define (print . args) (for-each write args))
-(define (princ . args)
+(def (print . args) (for-each write args))
+(def (princ . args)
(with-bindings ((*print-readably* #f))
(for-each write args)))
-(define (newline (port *output-stream*))
+(def (newline (port *output-stream*))
(io-write port *linefeed*)
(void))
-(define (io-readline s) (io-readuntil s #\linefeed))
+(def (io-readline s) (io-readuntil s #\linefeed))
; call f on a stream until the stream runs out of data
-(define (read-all-of f s)
+(def (read-all-of f s)
(let loop ((lines ())
(curr (f s)))
(if (io-eof? s)
@@ -680,25 +680,25 @@
(reverse! lines)
(loop (cons curr lines) (f s)))))
-(define (io-readlines s) (read-all-of io-readline s))
-(define (read-all s) (read-all-of read s))
+(def (io-readlines s) (read-all-of io-readline s))
+(def (read-all s) (read-all-of read s))
-(define (io-readall s)
+(def (io-readall s)
(let ((b (buffer)))
(io-copy b s)
(iostream->string b)))
-(define-macro (with-output-to stream . body)
+(defmacro (with-output-to stream . body)
`(with-bindings ((*output-stream* ,stream))
,@body))
-(define-macro (with-input-from stream . body)
+(defmacro (with-input-from stream . body)
`(with-bindings ((*input-stream* ,stream))
,@body))
;;; vector functions
-(define (list->vector l) (apply vector l))
-(define (vector->list v)
+(def (list->vector l) (apply vector l))
+(def (vector->list v)
(let ((n (length v))
(l ()))
(for 1 n
@@ -706,7 +706,7 @@
(set! l (cons (aref v (- n i)) l))))
l))
-(define (vector-map f v)
+(def (vector-map f v)
(let* ((n (length v))
(nv (vector-alloc n)))
(for 0 (- n 1)
@@ -716,21 +716,21 @@
;;; table functions
-(define (table-pairs t)
+(def (table-pairs t)
(table-foldl (λ (k v z) (cons (cons k v) z))
() t))
-(define (table-keys t)
+(def (table-keys t)
(table-foldl (λ (k v z) (cons k z))
() t))
-(define (table-values t)
+(def (table-values t)
(table-foldl (λ (k v z) (cons v z))
() t))
-(define (table-clone t)
+(def (table-clone t)
(let ((nt (table)))
(table-foldl (λ (k v z) (put! nt k v))
() t)
nt))
-(define (table-invert t)
+(def (table-invert t)
(let ((nt (table)))
(table-foldl (λ (k v z) (put! nt v k))
() t)
@@ -738,14 +738,14 @@
;;; string functions
-(define (string-tail s n) (string-sub s n))
+(def (string-tail s n) (string-sub s n))
-(define (string-trim s at-start at-end)
- (define (trim-start s chars i L)
+(def (string-trim s at-start at-end)
+ (def (trim-start s chars i L)
(if (and (< i L) (string-find chars (string-char s i)))
(trim-start s chars (1+ i) L)
i))
- (define (trim-end s chars i)
+ (def (trim-end s chars i)
(if (and (> i 0) (string-find chars (string-char s (1- i))))
(trim-end s chars (1- i))
i))
@@ -754,7 +754,7 @@
(trim-start s at-start 0 L)
(trim-end s at-end L))))
-(define (string-map f s)
+(def (string-map f s)
(let ((b (buffer))
(n (string-length s)))
(let ((i 0))
@@ -763,7 +763,7 @@
(set! i (1+ i)))))
(iostream->string b)))
-(define (string-rep s k)
+(def (string-rep s k)
(cond ((< k 4)
(cond ((<= k 0) "")
((= k 1) (string s))
@@ -772,15 +772,15 @@
((odd? k) (string s (string-rep s (- k 1))))
(else (string-rep (string s s) (/ k 2)))))
-(define (string-lpad s n c) (string (string-rep c (- n (string-length s))) s))
-(define (string-rpad s n c) (string s (string-rep c (- n (string-length s)))))
+(def (string-lpad s n c) (string (string-rep c (- n (string-length s))) s))
+(def (string-rpad s n c) (string s (string-rep c (- n (string-length s)))))
-(define (print-to-string v)
+(def (print-to-string v)
(let ((b (buffer)))
(write v b)
(iostream->string b)))
-(define (string-join strlist sep)
+(def (string-join strlist sep)
(if (null? strlist) ""
(let ((b (buffer)))
(io-write b (car strlist))
@@ -791,20 +791,20 @@
;;; toplevel
-(define (macrocall? e) (and (symbol? (car e))
+(def (macrocall? e) (and (symbol? (car e))
(symbol-syntax (car e))))
-(define (macroexpand-1 e)
+(def (macroexpand-1 e)
(if (atom? e) e
(let ((f (macrocall? e)))
(if f (apply f (cdr e))
e))))
-(define (expand e)
+(def (expand e)
; symbol resolves to toplevel; i.e. has no shadowing definition
- (define (top? s env) (not (or (bound? s) (assq s env))))
+ (def (top? s env) (not (or (bound? s) (assq s env))))
- (define (splice-begin body)
+ (def (splice-begin body)
(cond ((atom? body) body)
((equal? body '((begin)))
body)
@@ -814,14 +814,14 @@
(else
(cons (car body) (splice-begin (cdr body))))))
- (define *expanded* (list '*expanded*))
+ (def *expanded* (list '*expanded*))
- (define (expand-body body env)
+ (def (expand-body body env)
(if (atom? body) body
(let* ((body (if (top? 'begin env)
(splice-begin body)
body))
- (def? (top? 'define env))
+ (def? (top? 'def env))
(dvars (if def? (get-defined-vars body) ()))
(env (nconc (map list dvars) env)))
(if (not def?)
@@ -830,7 +830,7 @@
(let loop ((body body))
(cond ((atom? body) body)
((and (cons? (car body))
- (eq? 'define (caar body)))
+ (eq? 'def (caar body)))
(cons (car body) (loop (cdr body))))
(else
(let ((form (expand-in (car body) env)))
@@ -848,7 +848,7 @@
(set! body (cdr body)))
ex-nondefs)))))
- (define (expand-lambda-list l env)
+ (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))
@@ -855,12 +855,12 @@
(car l))
(expand-lambda-list (cdr l) env))))
- (define (l-vars l)
+ (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))))))
- (define (expand-lambda e env)
+ (def (expand-lambda e env)
(let ((formals (cadr e))
(name (lastcdr e))
(body (cddr e))
@@ -870,7 +870,7 @@
,.(expand-body body env)
. ,name))))
- (define (expand-define e env)
+ (def (expand-define e env)
(if (or (null? (cdr e)) (atom? (cadr e)))
(if (null? (cddr e))
e
@@ -879,7 +879,7 @@
(when doc
(set! e (cdr e))
(symbol-set-doc name doc))
- `(define ,name ,(expand-in (caddr e) env))))
+ `(def ,name ,(expand-in (caddr e) env))))
(let* ((formals (cdadr e))
(name (caadr e))
(body (cddr e))
@@ -889,10 +889,10 @@
(when doc
(set! body (cdr body))
(symbol-set-doc name doc formals))
- `(define ,(cons name (expand-lambda-list formals menv))
+ `(def ,(cons name (expand-lambda-list formals menv))
,.(expand-body body menv)))))
- (define (expand-let-syntax e env)
+ (def (expand-let-syntax e env)
(let ((binds (cadr e)))
(cons 'begin
(expand-body (cddr e)
@@ -908,9 +908,9 @@
; 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
- (define (local-expansion-env menv lenv) menv)
+ (def (local-expansion-env menv lenv) menv)
- (define (expand-in e env)
+ (def (expand-in e env)
(if (atom? e) e
(let* ((head (car e))
(bnd (assq head env))
@@ -933,16 +933,16 @@
((eq? head 'quote) e)
((eq? head 'λ) (expand-lambda e env))
((eq? head 'lambda) (expand-lambda e env))
- ((eq? head 'define) (expand-define e env))
+ ((eq? head 'def) (expand-define e env))
((eq? head 'let-syntax) (expand-let-syntax e env))
(else (default))))))
(expand-in e ()))
-(define (eval x) ((compile-thunk (expand x))))
+(def (eval x) ((compile-thunk (expand x))))
-(define (load-process x) (eval x))
+(def (load-process x) (eval x))
-(define (load filename)
+(def (load filename)
(let ((F (file filename :read)))
(trycatch
(let next (prev E v)
@@ -957,8 +957,8 @@
(io-close F)
(raise `(load-error ,filename ,e))))))
-(define (repl)
- (define (prompt)
+(def (repl)
+ (def (prompt)
(*prompt*)
(io-flush *output-stream*)
(let ((v (trycatch (read)
@@ -968,7 +968,7 @@
(let ((V (load-process v)))
(unless (void? V) (print V) (newline))
(void (set! that V))))))
- (define (reploop)
+ (def (reploop)
(when (trycatch (prompt)
(λ (e)
(top-level-exception-handler e)
@@ -977,13 +977,13 @@
(reploop)
(newline))
-(define (top-level-exception-handler e)
+(def (top-level-exception-handler e)
(with-output-to *stderr*
(print-exception e)
(print-stack-trace (stacktrace))))
-(define (print-stack-trace st)
- (define (find-in-f f tgt path)
+(def (print-stack-trace st)
+ (def (find-in-f f tgt path)
(let ((path (cons (function:name f) path)))
(if (eq? (function:code f) (function:code tgt))
(throw 'ffound path)
@@ -991,7 +991,7 @@
(for 0 (1- (length v))
(λ (i) (when (closure? (aref v i))
(find-in-f (aref v i) tgt path))))))))
- (define (fn-name f e)
+ (def (fn-name f e)
(let ((p (catch 'ffound
(begin
(for-each (λ (topfun)
@@ -1019,7 +1019,7 @@
(set! n (+ n 1)))
st)))
-(define (print-exception e)
+(def (print-exception e)
(cond ((and (cons? e)
(eq? (car e) 'type-error)
(length= e 3))
@@ -1061,7 +1061,7 @@
(princ *linefeed*))
-(define (simple-sort l)
+(def (simple-sort l)
(if (or (null? l) (null? (cdr l))) l
(let ((piv (car l)))
(receive (less grtr)
@@ -1070,7 +1070,7 @@
(list piv)
(simple-sort grtr))))))
-(define (make-system-image fname)
+(def (make-system-image fname)
(let ((f (file fname :write :create :truncate))
(z (file (string fname ".builtin") :write :create :truncate))
(b (buffer))
@@ -1077,7 +1077,7 @@
(excludes '(*linefeed* *directory-separator* *argv* that
*print-pretty* *print-width* *print-readably*
*print-level* *print-length* *os-name* *interactive*
- *prompt* *os-version*)))
+ *prompt* *os-version* procedure? top-level-bound?)))
(with-bindings ((*print-pretty* #f)
(*print-readably* #t))
(let* ((syms
@@ -1107,7 +1107,7 @@
(io-close z))))
; initialize globals that need to be set at load time
-(define (__init_globals)
+(def (__init_globals)
(let ((defprompt (if (equal? *os-name* "macos")
(λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
(λ () (princ "#;> ")))))
@@ -1120,12 +1120,12 @@
(set! *input-stream* *stdin*)
(set! *error-stream* *stderr*))
-(define (__script fname)
+(def (__script fname)
(trycatch (load fname)
(λ (e) (begin (top-level-exception-handler e)
(exit 1)))))
-(define (__rcscript)
+(def (__rcscript)
(let* ((homevar (case *os-name*
(("unknown") #f) (("plan9") "home")@@ -1135,7 +1135,7 @@
(fname (and home (string home *directory-separator* ".flisprc"))))
(when (and fname (path-exists? fname)) (load fname))))
-(define (__start argv)
+(def (__start argv)
(__init_globals)
(if (cons? (cdr argv))
(begin (set! *argv* (cdr argv))
--- a/test/ast/asttools.lsp
+++ b/test/ast/asttools.lsp
@@ -1,42 +1,42 @@
; -*- scheme -*-
; utilities for AST processing
-(define (symconcat s1 s2)
+(def (symconcat s1 s2)
(symbol (string s1 s2)))
-(define (list-adjoin item lst)
+(def (list-adjoin item lst)
(if (member item lst)
lst
(cons item lst)))
-(define (index-of item lst start)
+(def (index-of item lst start)
(cond ((null? lst) #f)
((eq? item (car lst)) start)
(#t (index-of item (cdr lst) (+ start 1)))))
-(define (each f l)
+(def (each f l)
(if (null? l) l
(begin (f (car l))
(each f (cdr l)))))
-(define (maptree-pre f tr)
+(def (maptree-pre f tr)
(let ((new-t (f tr)))
(if (cons? new-t)
(map (lambda (e) (maptree-pre f e)) new-t)
new-t)))
-(define (maptree-post f tr)
+(def (maptree-post f tr)
(if (not (cons? tr))
(f tr)
(let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
(f new-t))))
-(define (foldtree-pre f t zero)
+(def (foldtree-pre f t zero)
(if (not (cons? t))
(f t zero)
(foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero))))
-(define (foldtree-post f t zero)
+(def (foldtree-post f t zero)
(if (not (cons? t))
(f t zero)
(f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
@@ -48,7 +48,7 @@
; approach.
; (mapper tree state) - should return transformed tree given current state
; (folder tree state) - should return new state
-(define (map&fold t zero mapper folder)
+(def (map&fold t zero mapper folder)
(let ((head (and (cons? t) (car t))))
(cond ((eq? head 'quote)
t)
@@ -68,7 +68,7 @@
new-s))))))
; convert to proper list, i.e. remove "dots", and append
-(define (append.2 l tail)
+(def (append.2 l tail)
(cond ((null? l) tail)
((atom? l) (cons l tail))
(#t (cons (car l) (append.2 (cdr l) tail)))))
@@ -75,7 +75,7 @@
; transform code by calling (f expr env) on each subexpr, where
; env is a list of lexical variables in effect at that point.
-(define (lexical-walk f t)
+(def (lexical-walk f t)
(map&fold t () f
(lambda (tree state)
(if (and (eq? (car t) 'lambda)
@@ -84,7 +84,7 @@
state))))
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
-(define (flatten-left-op op e)
+(def (flatten-left-op op e)
(maptree-post (lambda (node)
(if (and (cons? node)
(eq? (car node) op)
@@ -100,12 +100,12 @@
; where rib is the nesting level and slot is the stack slot#
; name is just there for reference
; this assumes lambda is the only remaining naming form
-(define (lookup-var v env lev)
+(def (lookup-var v env lev)
(if (null? env) v
(let ((i (index-of v (car env) 0)))
(if i (list 'lexref lev i v)
(lookup-var v (cdr env) (+ lev 1))))))
-(define (lvc- e env)
+(def (lvc- e env)
(cond ((symbol? e) (lookup-var e env 0))
((cons? e)
(if (eq? (car e) 'quote)
@@ -119,11 +119,11 @@
(cddr e))))
(map (lambda (se) (lvc- se env)) e)))))
(#t e)))
-(define (lexical-var-conversion e)
+(def (lexical-var-conversion e)
(lvc- e ()))
; convert let to lambda
-(define (let-expand e)
+(def (let-expand e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
@@ -133,7 +133,7 @@
; alpha renaming
; transl is an assoc list ((old-sym-name . new-sym-name) ...)
-(define (alpha-rename e transl)
+(def (alpha-rename e transl)
(map&fold e
()
; mapper: replace symbol if unbound
@@ -153,13 +153,13 @@
env))))
; flatten op with any associativity
-(define-macro (flatten-all-op op e)
+(defmacro (flatten-all-op op e)
`(pattern-expand
(pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
(cons ',op (append l (cdr inner) r)))
,e))
-(define-macro (pattern-lambda pat body)
+(defmacro (pattern-lambda pat body)
(let* ((args (patargs pat))
(expander `(lambda ,args ,body)))
`(lambda (expr)
--- a/test/ast/match.lsp
+++ b/test/ast/match.lsp
@@ -2,7 +2,7 @@
; tree regular expression pattern matching
; by Jeff Bezanson
-(define (unique lst)
+(def (unique lst)
(if (null? lst)
()
(cons (car lst)
@@ -10,7 +10,7 @@
(unique (cdr lst))))))
; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
+(def metasymbols '(_ ...))
; expression tree pattern matching
; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
@@ -38,7 +38,7 @@
; all of these can be wrapped in (-- var ) for capturing purposes
; This is NP-complete. Be careful.
;
-(define (match- p expr state)
+(def (match- p expr state)
(cond ((symbol? p)
(cond ((eq? p '_) state)
(#t
@@ -67,7 +67,7 @@
(and (equal? p expr) state))))
; match an alternation
-(define (match-alt alt prest expr state var L)
+(def (match-alt alt prest expr state var L)
(if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state)))
(or (and subma
@@ -80,7 +80,7 @@
(match-alt (cdr alt) prest expr state var L)))))
; match generalized kleene star (try consuming min to max)
-(define (match-star- p prest expr state var min max L sofar)
+(def (match-star- p prest expr state var min max L sofar)
(cond ; case 0: impossible to match
((> min max) #f)
; case 1: only allowed to match 0 subexpressions
@@ -97,11 +97,11 @@
(#t
(or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar)))))
-(define (match-star p prest expr state var min max L)
+(def (match-star p prest expr state var min max L)
(match-star- p prest expr state var min max L ()))
; match sequences of expressions
-(define (match-seq p expr state L)
+(def (match-seq p expr state L)
(cond ((not state) #f)
((null? p) (if (null? expr) state #f))
(#t
@@ -129,10 +129,10 @@
(match- (car p) (car expr) state)
(- L 1))))))))))
-(define (match p expr) (match- p expr (list (cons '__ expr))))
+(def (match p expr) (match- p expr (list (cons '__ expr))))
; given a pattern p, return the list of capturing variables it uses
-(define (patargs- p)
+(def (patargs- p)
(cond ((and (symbol? p)
(not (member p metasymbols)))
(list p))
@@ -143,12 +143,12 @@
(unique (apply append (map patargs- (cdr p))))))
(#t ())))
-(define (patargs p)
+(def (patargs p)
(cons '__ (patargs- p)))
; try to transform expr using a pattern-lambda from plist
; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
+(def (apply-patterns plist expr)
(if (null? plist) expr
(if (procedure? plist)
(let ((enew (plist expr)))
@@ -169,7 +169,7 @@
; for example
; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
+(def (pattern-expand plist expr)
(if (not (cons? expr))
expr
(let ((enew (apply-patterns plist expr)))
--- a/test/ast/rpasses.lsp
+++ b/test/ast/rpasses.lsp
@@ -2,17 +2,17 @@
(load "match.lsp")
(load "asttools.lsp")
-(define missing-arg-tag '*r-missing*)
+(def missing-arg-tag '*r-missing*)
; tree inspection utils
-(define (assigned-var e)
+(def (assigned-var e)
(and (cons? e)
(or (eq? (car e) '<-) (eq? (car e) 'ref=))
(symbol? (cadr e))
(cadr e)))
-(define (func-argnames f)
+(def (func-argnames f)
(let ((argl (cadr f)))
(if (eq? argl '*r-null*) ()
(map cadr argl))))
@@ -24,7 +24,7 @@
(prog1 (symbol (string "%r:" ctr))
(set! ctr (+ ctr 1))))))
-(define (dollarsign-transform e)
+(def (dollarsign-transform e)
(pattern-expand
(pattern-lambda ($ lhs name)
(let* ((g (if (not (cons? lhs)) lhs (r-gensym)))
@@ -43,7 +43,7 @@
; they need to be handled separately. For example a$b can be lowered
; to an index assignment (by dollarsign-transform), after which
; this transform applies. I don't think there are any others though.
-(define (fancy-assignment-transform e)
+(def (fancy-assignment-transform e)
(pattern-expand
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
(<<- (r-call f lhs ...) rhs))
@@ -58,7 +58,7 @@
; function(x=blah) { ... } gets; if (missing(x)) x = blah
; added to its body
-(define (gen-default-inits arglist)
+(def (gen-default-inits arglist)
(map (lambda (arg)
(let ((name (cadr arg))
(default (caddr arg)))
@@ -67,7 +67,7 @@
(filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist)))
; convert r function expressions to lambda
-(define (normalize-r-functions e)
+(def (normalize-r-functions e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'function))
`(lambda ,(func-argnames n)
@@ -79,7 +79,7 @@
n))
e))
-(define (find-assigned-vars n)
+(def (find-assigned-vars n)
(let ((vars ()))
(maptree-pre (lambda (s)
(if (not (cons? s)) s
@@ -92,7 +92,7 @@
vars))
; introduce let based on assignment statements
-(define (letbind-locals e)
+(def (letbind-locals e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'lambda))
(let ((vars (find-assigned-vars (cddr n))))
@@ -102,7 +102,7 @@
n))
e))
-(define (compile-ish e)
+(def (compile-ish e)
(letbind-locals
(normalize-r-functions
(fancy-assignment-transform
--- a/test/bench.lsp
+++ b/test/bench.lsp
@@ -2,11 +2,11 @@
;; each benchmark is repeated N times to accomodate
;; for the performance increase of current systems
-(define N 100)
+(def N 100)
;; "Performance and Evaluation of Lisp Systems" (1985), Richard P. Gabriel
(princ "tak: ")
-(define (tak x y z)
+(def (tak x y z)
(if (not (< y x))
z
(tak (tak (- x 1) y z)
@@ -19,7 +19,7 @@
;; (- ... 1 → (1-
;; this will show how extra calls (no inlining) make things slow
(princ "tak_: ")
-(define (tak_ x y z)
+(def (tak_ x y z)
(if (>= y x)
z
(tak_ (tak_ (1- x) y z)
@@ -29,7 +29,7 @@
;; q2 - http://lispology.com/show?314T
(princ "q2: ")
-(define (q2 x y)
+(def (q2 x y)
(if (or (< x 1) (< y 1)) 1
(+ (q2 (- x (q2 (- x 1) y)) y)
(q2 x (- y (q2 x (- y 1)))))))
--- a/test/color.lsp
+++ b/test/color.lsp
@@ -1,38 +1,38 @@
; -*- scheme -*-
; dictionaries ----------------------------------------------------------------
-(define (dict-new) ())
+(def (dict-new) ())
-(define (dict-extend dl key value)
+(def (dict-extend dl key value)
(cond ((null? dl) (list (cons key value)))
((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
(else (cons (car dl) (dict-extend (cdr dl) key value)))))
-(define (dict-lookup dl key)
+(def (dict-lookup dl key)
(cond ((null? dl) ())
((equal? key (caar dl)) (cdar dl))
(else (dict-lookup (cdr dl) key))))
-(define (dict-keys dl) (map car dl))
+(def (dict-keys dl) (map car dl))
; graphs ----------------------------------------------------------------------
-(define (graph-empty) (dict-new))
+(def (graph-empty) (dict-new))
-(define (graph-connect g n1 n2)
+(def (graph-connect g n1 n2)
(dict-extend
(dict-extend g n2 (cons n1 (dict-lookup g n2)))
n1
(cons n2 (dict-lookup g n1))))
-(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+(def (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
-(define (graph-neighbors g n) (dict-lookup g n))
+(def (graph-neighbors g n) (dict-lookup g n))
-(define (graph-nodes g) (dict-keys g))
+(def (graph-nodes g) (dict-keys g))
-(define (graph-add-node g n1) (dict-extend g n1 ()))
+(def (graph-add-node g n1) (dict-extend g n1 ()))
-(define (graph-from-edges edge-list)
+(def (graph-from-edges edge-list)
(if (null? edge-list)
(graph-empty)
(graph-connect (graph-from-edges (cdr edge-list))
@@ -40,7 +40,7 @@
(cdar edge-list))))
; graph coloring --------------------------------------------------------------
-(define (node-colorable? g coloring node-to-color color-of-node)
+(def (node-colorable? g coloring node-to-color color-of-node)
(not (member
color-of-node
(map
@@ -49,12 +49,12 @@
(if (cons? color-pair) (cdr color-pair) ())))
(graph-neighbors g node-to-color)))))
-(define (try-each f lst)
+(def (try-each f lst)
(if (null? lst) #f
(let ((ret (f (car lst))))
(if ret ret (try-each f (cdr lst))))))
-(define (color-node g coloring colors uncolored-nodes color)
+(def (color-node g coloring colors uncolored-nodes color)
(cond
((null? uncolored-nodes) coloring)
((node-colorable? g coloring (car uncolored-nodes) color)
@@ -64,16 +64,16 @@
(color-node g new-coloring colors (cdr uncolored-nodes) c))
colors)))))
-(define (color-graph g colors)
+(def (color-graph g colors)
(if (null? colors)
(and (null? (graph-nodes g)) ())
(color-node g () colors (graph-nodes g) (car colors))))
-(define (color-pairs pairs colors)
+(def (color-pairs pairs colors)
(color-graph (graph-from-edges pairs) colors))
; queens ----------------------------------------------------------------------
-(define (can-attack x y)
+(def (can-attack x y)
(let ((x1 (mod x 5))
(y1 (truncate (/ x 5)))
(x2 (mod y 5))
@@ -80,7 +80,7 @@
(y2 (truncate (/ y 5))))
(or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
-(define (generate-5x5-pairs)
+(def (generate-5x5-pairs)
(let ((result ()))
(dotimes (x 25)
(dotimes (y 25)
--- a/test/err.lsp
+++ b/test/err.lsp
@@ -1,4 +1,4 @@
-(define (f x) (begin (list-tail '(1) 3) 3))
+(def (f x) (begin (list-tail '(1) 3) 3))
(f 2)
a
(trycatch a (λ (e) (print (stacktrace))))
--- a/test/hashtest.lsp
+++ b/test/hashtest.lsp
@@ -1,12 +1,12 @@
; -*- scheme -*-
-(define (hins1)
+(def (hins1)
(let ((h (table)))
(dotimes (n 200000)
(put! h (mod (rand) 1000) 'apple))
h))
-(define (hread h)
+(def (hread h)
(dotimes (n 200000)
(get h (mod (rand) 10000) nil)))
--- a/test/mp.lsp
+++ b/test/mp.lsp
@@ -1,2 +1,2 @@
-(define x 9999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999)
+(def x 9999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999)
(apply * (map-int (λ (_) x) 1000))
--- a/test/number-boundaries.lsp
+++ b/test/number-boundaries.lsp
@@ -1,25 +1,25 @@
; NUMBER BOUNDARIES ------------------------------------------------------------
-(define-macro (half-max-signed numtype)
+(defmacro (half-max-signed numtype)
`(ash (,numtype 1)
(- (* 8 (sizeof ',numtype)) 2)))
-(define-macro (high-border-signed numtype)
+(defmacro (high-border-signed numtype)
`(+ (- (half-max-signed ,numtype) 1)
(half-max-signed ,numtype)))
-(define-macro (low-border-signed numtype)
+(defmacro (low-border-signed numtype)
`(- -1 (high-border-signed ,numtype)))
-(define-macro (low-border numtype)
+(defmacro (low-border numtype)
`(if (< (,numtype -1) 1)
(low-border-signed ,numtype)
(,numtype 0)))
-(define-macro (high-border numtype)
+(defmacro (high-border numtype)
`(lognot (low-border ,numtype)))
;`(numtype (lognot (low-border ,numtype))))
-(define-macro (number-borders numtype)
+(defmacro (number-borders numtype)
`(cons (low-border ,numtype)
(high-border ,numtype)))
@@ -58,7 +58,7 @@
; conversions
-(define-macro (int-conv- smaller bigger)
+(defmacro (int-conv- smaller bigger)
`(let* ((h (high-border ,smaller))
(L (low-border ,bigger))
(l (if (= L 0) 0 (low-border ,smaller))))
@@ -77,7 +77,7 @@
(,smaller l) (,bigger l)
(,smaller (,bigger l)) (,bigger (,smaller l))))))
-(define-macro (int-conv smaller . biggers)
+(defmacro (int-conv smaller . biggers)
`(void ,@(map (λ (bigger) `(int-conv- ,smaller ,bigger)) biggers)))
(int-conv int8 int8 uint8 int16 uint16 int32 uint32 int64 uint64 bignum)
@@ -92,7 +92,7 @@
(int-conv bignum bignum)
-(define-macro (float-conv- type)
+(defmacro (float-conv- type)
`(let ((l (low-border ,type))
(h (high-border ,type)))
(if (member ,type (list int64 uint64))
@@ -105,7 +105,7 @@
(assert (= l (,type (float l))))
(assert (= h (,type (float h))))))))
-(define-macro (float-conv . types)
+(defmacro (float-conv . types)
`(void ,@(map (λ (type) `(float-conv- ,type)) types)))
(float-conv int8 uint8 int16 uint16 int32 uint32 int64 uint64)
--- a/test/perf.lsp
+++ b/test/perf.lsp
@@ -15,7 +15,7 @@
(princ "expand: ")
(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
-(define (my-append . lsts)
+(def (my-append . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
(else (letrec ((append2 (λ (l d)
@@ -31,7 +31,7 @@
(path-cwd "ast")
(princ "p-lambda: ")
(load "rpasses.lsp")
-(define *input* (load "datetimeR.lsp"))
+(def *input* (load "datetimeR.lsp"))
(time (set! *output* (compile-ish *input*)))
(assert (equal? *output* (load "rpasses-out.lsp")))
(path-cwd "..")
--- a/test/tcolor.lsp
+++ b/test/tcolor.lsp
@@ -4,8 +4,8 @@
(load "color.lsp")
; 100x color 5 queens
-(define Q (generate-5x5-pairs))
-(define (ct)
+(def Q (generate-5x5-pairs))
+(def (ct)
(set! C (color-pairs Q '(a b c d e)))
(dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct))
--- a/test/test.lsp
+++ b/test/test.lsp
@@ -4,16 +4,16 @@
;(defmacro labl (name f)
; (list list ''labl (list 'quote name) f))
-(define-macro (labl name f)
+(defmacro (labl name f)
`(let (,name) (set! ,name ,f)))
-;(define (reverse lst)
+;(def (reverse lst)
; ((label rev-help (λ (lst result)
; (if (null? lst) result
; (rev-help (cdr lst) (cons (car lst) result)))))
; lst ()))
-(define (append- . lsts)
+(def (append- . lsts)
((label append-h
(λ (lsts)
(cond ((null? lsts) ())
@@ -27,7 +27,7 @@
;(princ 'Hello '| | 'world! "\n")
;(filter (λ (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;(princ (time (fib 34)) "\n")
;(dotimes (i 20000) (map-int (λ (x) (list 'quote x)) 8))
;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
@@ -36,7 +36,7 @@
;(dotimes (i 200) (rfoldl cons () a))
#|
-(define-macro (dotimes var . body)
+(defmacro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(let ((,v 0))
@@ -45,7 +45,7 @@
,(cons 'begin body)
(set! ,v (+ ,v 1)))))))
-(define (map-int f n)
+(def (map-int f n)
(if (<= n 0)
()
(let ((first (cons (f 0) ())))
@@ -58,23 +58,23 @@
first 1 n))))
|#
-(define-macro (labl name fn)
+(defmacro (labl name fn)
`((λ (,name) (set! ,name ,fn)) ()))
; like eval-when-compile
-(define-macro (literal expr)
+(defmacro (literal expr)
(let ((v (eval expr)))
(if (self-evaluating? v) v (list quote v))))
-(define (cardepth l)
+(def (cardepth l)
(if (atom? l) 0
(+ 1 (cardepth (car l)))))
-(define (nestlist f zero n)
+(def (nestlist f zero n)
(if (<= n 0) ()
(cons zero (nestlist f (f zero) (- n 1)))))
-(define (mapl f . lsts)
+(def (mapl f . lsts)
((label mapl-
(λ (lsts)
(if (null? (car lsts)) ()
@@ -82,19 +82,19 @@
lsts))
; test to see if a symbol begins with :
-(define (keywordp s)
+(def (keywordp s)
(and (>= s '|:|) (<= s '|:~|)))
; swap the cars and cdrs of every cons in a structure
-(define (swapad c)
+(def (swapad c)
(if (atom? c) c
(set-cdr! c (K (swapad (car c))
(set-car! c (swapad (cdr c)))))))
-(define (without x l)
+(def (without x l)
(filter (λ (e) (not (eq e x))) l))
-(define (conscount c)
+(def (conscount c)
(if (cons? c) (+ 1
(conscount (car c))
(conscount (cdr c)))
@@ -109,7 +109,7 @@
;| (/_||||_()|_|_\|)
; |
-(define-macro (while- test . forms)
+(defmacro (while- test . forms)
`((label -loop- (λ ()
(if ,test
(begin ,@forms
@@ -124,7 +124,7 @@
; (catch (TypeError e) . exprs)
; (catch (IOError e) . exprs)
; (finally . exprs))
-(define-macro (try expr . forms)
+(defmacro (try expr . forms)
(let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
(body (foldr
; create a function to check for and handle one exception
@@ -149,7 +149,7 @@
(prog1 (attempt ,expr ,body)
(*_try_finally_thunk_*)))))
-(define Y
+(def Y
(λ (f)
((λ (h)
(f (λ (x) ((h h) x))))
@@ -156,7 +156,7 @@
(λ (h)
(f (λ (x) ((h h) x)))))))
-(define yfib
+(def yfib
(Y (λ (fib)
(λ (n)
(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
@@ -166,7 +166,7 @@
;(tt)
;(tt)
-(define-macro (accumulate-while cnd what . body)
+(defmacro (accumulate-while cnd what . body)
`(let ((acc# (list ())))
(cdr
(prog1 acc#
@@ -175,7 +175,7 @@
(cdr (set-cdr! acc# (cons ,what ()))))
,@body))))))
-(define-macro (accumulate-for var lo hi what . body)
+(defmacro (accumulate-for var lo hi what . body)
`(let ((acc# (list ())))
(cdr
(prog1 acc#
@@ -185,7 +185,7 @@
(cdr (set-cdr! acc# (cons ,what ()))))
,@body)))))))
-(define (map-indexed f lst)
+(def (map-indexed f lst)
(if (atom? lst) lst
(let ((i 0))
(accumulate-while (cons? lst) (f (car lst) i)
@@ -199,19 +199,19 @@
(put! *profiles* s (cons 0 0))
(set-top-level-value! s
(λ args
- (define tt (get *profiles* s))
- (define count (car tt))
- (define time (cdr tt))
- (define t0 (time-now))
- (define v (apply f args))
+ (def tt (get *profiles* s))
+ (def count (car tt))
+ (def time (cdr tt))
+ (def t0 (time-now))
+ (def v (apply f args))
(set-cdr! tt (+ time (- (time-now) t0)))
(set-car! tt (+ count 1))
v)))))
(set! show-profiles
(λ ()
- (define pr (filter (λ (x) (> (cadr x) 0))
+ (def pr (filter (λ (x) (> (cadr x) 0))
(table-pairs *profiles*)))
- (define width (+ 4
+ (def width (+ 4
(apply max
(map (λ (x)
(length (string x)))
@@ -249,8 +249,8 @@
taboreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process))
-(define (filt1 pred lst)
- (define (filt1- pred lst accum)
+(def (filt1 pred lst)
+ (def (filt1- pred lst accum)
(if (null? lst) accum
(if (pred (car lst))
(filt1- pred (cdr lst) (cons (car lst) accum))
@@ -257,7 +257,7 @@
(filt1- pred (cdr lst) accum))))
(filt1- pred lst ()))
-(define (filto pred lst (accum ()))
+(def (filto pred lst (accum ()))
(if (atom? lst) accum
(if (pred (car lst))
(filto pred (cdr lst) (cons (car lst) accum))
@@ -264,7 +264,7 @@
(filto pred (cdr lst) accum))))
; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
-(define (pairwise? pred . args)
+(def (pairwise? pred . args)
(or (null? args)
(let f ((a (car args)) (d (cdr args)))
(or (null? d)
--- a/test/torture.lsp
+++ b/test/torture.lsp
@@ -1,19 +1,19 @@
-(define ones (map (λ (x) 1) (iota 10000000)))
+(def ones (map (λ (x) 1) (iota 10000000)))
(write (apply + ones))
(newline)
-(define (big n)
+(def (big n)
(if (<= n 0)
0
`(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
; https://todo.sr.ht/~ft/femtolisp/2
-;(define nst (big 100000))
+;(def nst (big 100000))
;(write (eval nst))
;(newline)
-(define longg (cons '+ ones))
+(def longg (cons '+ ones))
(write (eval longg))
(newline)
--- a/test/torus.lsp
+++ b/test/torus.lsp
@@ -1,5 +1,5 @@
; -*- scheme -*-
-(define (maplist f l)
+(def (maplist f l)
(if (null? l) ()
(cons (f l) (maplist f (cdr l)))))
@@ -7,7 +7,7 @@
; make m copies of a CDR-circular list of length n, and connect corresponding
; conses in CAR-circular loops
; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
-(define (torus m n)
+(def (torus m n)
(let* ((l (map-int identity n))
(g l)
(prev g))
@@ -24,7 +24,7 @@
(set! b (cdr b))))
l))
-(define (cyl m n)
+(def (cyl m n)
(let* ((l (map-int identity n))
(g l))
(dotimes (i (- m 1))
--- a/test/unittest.lsp
+++ b/test/unittest.lsp
@@ -1,25 +1,25 @@
; -*- scheme -*-
-(define-macro (assert-fail expr . what)
+(defmacro (assert-fail expr . what)
`(assert (trycatch (begin ,expr #f)
(λ (e) ,(if (null? what) #t
`(eq? (car e) ',(car what)))))))
-(define (every-int n)
+(def (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
(int64 n) (uint64 n) (float n) (double n) (bignum n)))
-(define (every-sint n)
+(def (every-sint n)
(list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n) (float n) (double n) (bignum n)))
-(define (each f l)
+(def (each f l)
(if (atom? l) ()
(begin (f (car l))
(each f (cdr l)))))
-(define (each^2 f l m)
+(def (each^2 f l m)
(each (λ (o) (each (λ (p) (f o p)) m)) l))
-(define (test-lt a b)
+(def (test-lt a b)
(each^2 (λ (neg pos)
(begin
(eval `(assert (= -1 (compare ,neg ,pos))))
@@ -29,7 +29,7 @@
a
b))
-(define (test-eq a b)
+(def (test-eq a b)
(each^2 (λ (a b)
(begin
(eval `(assert (= 0 (compare ,a ,b))))))
@@ -41,7 +41,7 @@
(test-eq (every-int 88) (every-int 88))
(test-eq (every-sint -88) (every-sint -88))
-(define (test-square a)
+(def (test-square a)
(each (λ (i) (eval `(assert (>= (* ,i ,i) 0))))
a))
@@ -96,7 +96,7 @@
(assert (< 0x8fffffffffffffff 0x10000000000000000))
(assert (bignum? (ash 2 60)))
-(define (bignum-on-32? x) (if #.(fixnum? 0xffffffff) (not (bignum? x)) (bignum? x)))
+(def (bignum-on-32? x) (if #.(fixnum? 0xffffffff) (not (bignum? x)) (bignum? x)))
(assert (bignum-on-32? (- (ash 2 60) 1)))
(assert (bignum? 1606938044258990275541962092341162602522202993782792835301376))
(assert (bignum? 0xfffffffffffffffff))
@@ -216,34 +216,34 @@
; long argument lists
(assert (= (apply + (iota 100000)) 4999950000))
-(define ones (map (λ (x) 1) (iota 80000)))
+(def ones (map (λ (x) 1) (iota 80000)))
(assert (= (eval `(if (< 2 1)
(+ ,@ones)
(+ ,@(cdr ones))))
79999))
-(define MAX_ARGS 255)
+(def MAX_ARGS 255)
-(define as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 1))))
-(define f (compile `(λ ,as ,(lastcdr as))))
+(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 1))))
+(def f (compile `(λ ,as ,(lastcdr as))))
(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
-(define as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 100))))
-(define ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
+(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 100))))
+(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
,(car (last-pair as)))))
(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
-(define ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
+(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
(λ () ,(car (last-pair as))))))
(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
-(define as (map-int (λ (x) (gensym)) 1000))
-(define f (compile `(λ ,as ,(car (last-pair as)))))
+(def as (map-int (λ (x) (gensym)) 1000))
+(def f (compile `(λ ,as ,(car (last-pair as)))))
(assert (equal? (apply f (iota 1000)) 999))
-(define as (apply list* (map-int (λ (x) (gensym)) 995)))
-(define f (compile `(λ ,as ,(lastcdr as))))
+(def as (apply list* (map-int (λ (x) (gensym)) 995)))
+(def f (compile `(λ ,as ,(lastcdr as))))
(assert (equal? (apply f (iota 994)) '()))
(assert (equal? (apply f (iota 995)) '(994)))
(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
@@ -267,7 +267,7 @@
'(1 0 0 (8 4 5))))
(assert (equal? ((λ (x (a 2) (:b a) . r) (list x a b r)) 0 :b 3 1)
'(0 2 3 (1))))
-(define (keys4 (:a 8) (:b 3) (:c 7) (:d 6)) (list a b c d))
+(def (keys4 (:a 8) (:b 3) (:c 7) (:d 6)) (list a b c d))
(assert (equal? (keys4 :a 10) '(10 3 7 6)))
(assert (equal? (keys4 :b 10) '(8 10 7 6)))
(assert (equal? (keys4 :c 10) '(8 3 10 6)))
@@ -274,13 +274,13 @@
(assert (equal? (keys4 :d 10) '(8 3 7 10)))
(assert-fail (keys4 :e 10)) ; unsupported keyword
(assert-fail (keys4 :a 1 :b)) ; keyword with no argument
-(define (keys1 (:a 8)) (+ a 1))
+(def (keys1 (:a 8)) (+ a 1))
(assert (equal? (keys1 :a 11) 12))
; cvalues and arrays
(assert (equal? (typeof "") '(array byte)))
(assert-fail (aref #(1) 3) bounds-error)
-(define iarr (array 'int64 32 16 8 7 1))
+(def iarr (array 'int64 32 16 8 7 1))
(assert (equal? (aref iarr 0) 32))
(assert (equal? (aref iarr #int8(3)) 7))
@@ -292,7 +292,7 @@
(let ((gs (gensym))) (assert (eq? gs gs)))
; ok, a couple end-to-end tests as well
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))
(load "color.lsp")
@@ -374,7 +374,7 @@
(assert (equal? 1.0 (* 1.0 1))) ; tests that * no longer does inexact->exact
-(define (with-output-to-string nada thunk)
+(def (with-output-to-string nada thunk)
(let ((b (buffer)))
(with-output-to b (thunk))
(iostream->string b)))
@@ -397,13 +397,13 @@
(assert (equal? (append '(1 2) '(3 4)) '(1 2 3 4)))
;; infinite list
-(define a '(1))
+(def a '(1))
(set-cdr! a a)
(assert (equal? (length a) +inf.0))
(eq? (cdr a) a)
;; unbinding
-(define abc 1)
+(def abc 1)
(assert (equal? (bound? 'abc) #t))
(assert (equal? (eval '(+ abc 1)) 2))
(makunbound 'abc)
@@ -419,10 +419,10 @@
(assert (null? (cdddr '())))
;; for-each with multiple lists
-(define q '())
+(def q '())
(for-each (λ (x y) (set! q (cons (+ x y) q))) #(1 2 3) #vu8(4 5 6))
(assert (equal? q '(9 7 5)))
-(define q 0)
+(def q 0)
(for-each (λ (x y) (set! q (+ x y q))) '(1) '(3 9))
(assert (equal? q 4))
(for-each (λ (x y) (set! q (+ x y q))) '(1 2) '(3))
@@ -437,7 +437,7 @@
(assert (equal? (map (λ (x y z) (+ x y z)) '(1 2) '(3) '(4 5)) '(8)))
;; aref with multiple indices
-(define a #(#(0 1 2) #(3 (4 5 6) 7)))
+(def a #(#(0 1 2) #(3 (4 5 6) 7)))
(assert (equal? 0 (aref a 0 0)))
(assert (equal? 0 (apply aref (list a 0 0))))
(assert (equal? 2 (aref a 0 2)))
@@ -451,7 +451,7 @@
(assert-fail (aref #("hello") 1 0));; aset with multiple indices
-(define a #(#(0 1 2) #(3 (4 5 6) 7)))
+(def a #(#(0 1 2) #(3 (4 5 6) 7)))
(assert (equal? 8 (apply aset! (list a 0 0 8))))
(assert (equal? 9 (aset! a 1 1 (1+ 1) 9)))
(assert (equal? "hello" (aset! a (1+ 0) 2 "hello")))
@@ -498,9 +498,9 @@
(newline))
;; macro vs function priority
-(define (!! x y) (- x y))
+(def (!! x y) (- x y))
(assert (eq? 3 (!! 5 2)))
-(define-macro (!! x y z) (+ z (apply !! (list x y))))
+(defmacro (!! x y z) (+ z (apply !! (list x y))))
(assert (eq? 4 (!! 5 2 1)))
;; rune strings
@@ -511,7 +511,7 @@
(assert (equal? es (iostream->string b)))
(io-close b))
-(define s "привет\0пока")
+(def s "привет\0пока")
(assert (equal? s (string-encode (string-decode s))))
(assert (equal? (string s "\0") (string-encode (string-decode s #t))))
@@ -605,7 +605,7 @@
(assert (equal? #\Dž (char-titlecase #\DŽ)))
(assert (char-title-case? #\Dž))
-(define s "hello й goodbye")
+(def s "hello й goodbye")
(assert (= 6 (string-find s #\й)))
(assert (= 6 (string-find s #\й 6)))
(assert-fail (string-find s #\o -1))
@@ -716,7 +716,7 @@
(assert (= (length (table "hello" "goodbye" 123 456)) 2))
(assert-fail (table 1))
(assert-fail (table 1 2 3))
-(define t (table 1 2 "3" 4 'foo 'bar))
+(def t (table 1 2 "3" 4 'foo 'bar))
(let ((b (buffer)))
(write t b)
(assert (equal? (iostream->string b) "#table(1 2 \"3\" 4 foo bar)")))
@@ -743,10 +743,10 @@
(assert-fail (sleep 1 2))
(sleep)
(sleep 0)
-(define t₀ (nanoseconds-monotonic))
+(def t₀ (nanoseconds-monotonic))
(sleep 1)
-(define t₁ (nanoseconds-monotonic))
-(define Δt (- t₁ t₀))
+(def t₁ (nanoseconds-monotonic))
+(def Δt (- t₁ t₀))
(assert (and (< Δt 1010000000 ) (> Δt 999000000)))
(gc)
@@ -766,10 +766,10 @@
;; auto gensym
-(define-macro (f x)
+(defmacro (f x)
`(let ((a# 1)) (list a# ,x)))
-(define-macro (g x)
+(defmacro (g x)
`(let ((a# 2)) (list a# ,x)))
(assert (equal? '(1 (2 3)) (f (g 3))))
--- a/tools/gen.lsp
+++ b/tools/gen.lsp
@@ -1,4 +1,4 @@
-(define opcodes '(
+(def opcodes '(
; C opcode, lisp compiler opcode, arg count, builtin lambda, DOC (NEW)
OP_LOADA0 loada0 #f 0 ()
OP_LOADA1 loada1 #f 0 ()
@@ -103,7 +103,7 @@
OP_EOF_OBJECT dummy_eof #f 0 ()
))
-(define (for-each-n f lst n)
+(def (for-each-n f lst n)
(when (and (> n 0) (cons? lst))
(apply f (list-head lst n))
(for-each-n f (list-tail lst n) n)))
@@ -159,12 +159,12 @@
(io-write c-code "};\n")
(io-close c-code)
- (write `(define Instructions
+ (write `(def Instructions
"VM instructions mapped to their encoded byte representation."
,e)
instructions)
(io-write instructions "\n\n")
- (write `(define arg-counts
+ (write `(def arg-counts
"VM instructions mapped to their expected arguments count."
,ac)
instructions)
@@ -171,7 +171,7 @@
(io-write instructions "\n")
(io-close instructions)
(set! lms (cons vector (reverse! lms)))
- (write `(define *builtins*
+ (write `(def *builtins*
"VM instructions as closures."
,lms)
builtins)
--- a/tools/mkboot0.lsp
+++ b/tools/mkboot0.lsp
@@ -1,6 +1,6 @@
; -*- scheme -*-
-(define update-compiler
+(def update-compiler
(let ((C ()))
(with-bindings
((eval (λ (x) (set! C (cons (compile-thunk (expand x)) C)))))
@@ -11,7 +11,7 @@
(for-each (λ (x) (x)) (reverse! C))
(set! update-compiler (λ () ()))))))
-(define (compile-file inf)
+(def (compile-file inf)
(let ((in (file inf :read)))
(let next ((E (read in)))
(if (not (io-eof? in))
@@ -21,7 +21,7 @@
(next (read in)))))
(io-close in)))
-(define (do-boot0)
+(def (do-boot0)
(for-each (λ (file)
(compile-file file))
(cdr *argv*)))