From 17d81eb4e67c178a93e7fcb3c55e81b05029820a Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sun, 1 Feb 2009 01:53:58 +0000 Subject: [PATCH] adding #b, #o, #d, #x numeric literals accepting r6rs IEEE literals +-nan.0 and +-inf.0 printing distinguished -0.0, indicating float with .0f instead of #float, double with .0 instead of #double more renaming (? on predicates, ! on mutating operators) changing T to #t :( all those #s are so ugly --- femtolisp/ast/asttools.lsp | 42 +++--- femtolisp/ast/match.lsp | 113 ++++++++-------- femtolisp/ast/rpasses.lsp | 24 ++-- femtolisp/{ => attic}/dict.lsp | 0 femtolisp/color.lsp | 30 ++--- femtolisp/cps.lsp | 64 ++++----- femtolisp/cvalues.c | 2 +- femtolisp/flisp.c | 10 +- femtolisp/print.c | 14 +- femtolisp/read.c | 92 ++++++++----- femtolisp/system.lsp | 230 ++++++++++++++++----------------- femtolisp/table.c | 18 +-- femtolisp/test.lsp | 40 +++--- femtolisp/torus.lsp | 2 +- femtolisp/unittest.lsp | 8 +- 15 files changed, 356 insertions(+), 333 deletions(-) rename femtolisp/{ => attic}/dict.lsp (100%) diff --git a/femtolisp/ast/asttools.lsp b/femtolisp/ast/asttools.lsp index 3e73a54..83aace2 100644 --- a/femtolisp/ast/asttools.lsp +++ b/femtolisp/ast/asttools.lsp @@ -10,23 +10,23 @@ (cons item lst))) (define (index-of item lst start) - (cond ((null lst) #f) + (cond ((null? lst) #f) ((eq item (car lst)) start) - (T (index-of item (cdr lst) (+ start 1))))) + (#t (index-of item (cdr lst) (+ start 1))))) (define (each f l) - (if (null l) l + (if (null? l) l (begin (f (car l)) (each f (cdr l))))) (define (maptree-pre f tr) (let ((new-t (f tr))) - (if (consp new-t) + (if (pair? new-t) (map (lambda (e) (maptree-pre f e)) new-t) new-t))) (define (maptree-post f tr) - (if (not (consp tr)) + (if (not (pair? tr)) (f tr) (let ((new-t (map (lambda (e) (maptree-post f e)) tr))) (f new-t)))) @@ -70,10 +70,10 @@ ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) (define (flatten-left-op op e) (maptree-post (lambda (node) - (if (and (consp node) + (if (and (pair? node) (eq (car node) op) - (consp (cdr node)) - (consp (cadr node)) + (pair? (cdr node)) + (pair? (cadr node)) (eq (caadr node) op)) (cons op (append (cdadr node) (cddr node))) @@ -85,31 +85,31 @@ ; name is just there for reference ; this assumes lambda is the only remaining naming form (define (lookup-var v env lev) - (if (null env) v + (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) - (cond ((symbolp e) (lookup-var e env 0)) - ((consp e) + (cond ((symbol? e) (lookup-var e env 0)) + ((pair? e) (if (eq (car e) 'quote) e - (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) - (newenv (if newvs (cons newvs env) env))) - (if newvs - (cons 'lambda - (cons (cadr e) - (map (lambda (se) (lvc- se newenv)) - (cddr e)))) - (map (lambda (se) (lvc- se env)) e))))) - (T e))) + (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) + (newenv (if newvs (cons newvs env) env))) + (if newvs + (cons 'lambda + (cons (cadr e) + (map (lambda (se) (lvc- se newenv)) + (cddr e)))) + (map (lambda (se) (lvc- se env)) e))))) + (#t e))) (define (lexical-var-conversion e) (lvc- e ())) ; convert let to lambda (define (let-expand e) (maptree-post (lambda (n) - (if (and (consp n) (eq (car n) 'let)) + (if (and (pair? n) (eq (car n) 'let)) `((lambda ,(map car (cadr n)) ,@(cddr n)) ,@(map cadr (cadr n))) n)) diff --git a/femtolisp/ast/match.lsp b/femtolisp/ast/match.lsp index 8091905..c242ccd 100644 --- a/femtolisp/ast/match.lsp +++ b/femtolisp/ast/match.lsp @@ -3,11 +3,11 @@ ; by Jeff Bezanson (define (unique lst) - (if (null lst) + (if (null? lst) () - (cons (car lst) - (filter (lambda (x) (not (eq x (car lst)))) - (unique (cdr lst)))))) + (cons (car lst) + (filter (lambda (x) (not (eq x (car lst)))) + (unique (cdr lst)))))) ; list of special pattern symbols that cannot be variable names (define metasymbols '(_ ...)) @@ -39,18 +39,18 @@ ; This is NP-complete. Be careful. ; (define (match- p expr state) - (cond ((symbolp p) + (cond ((symbol? p) (cond ((eq p '_) state) - (T + (#t (let ((capt (assq p state))) (if capt (and (equal expr (cdr capt)) state) - (cons (cons p expr) state)))))) + (cons (cons p expr) state)))))) - ((function? p) + ((procedure? p) (and (p expr) state)) - ((consp p) + ((pair? p) (cond ((eq (car p) '-/) (and (equal (cadr p) expr) state)) ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) ((eq (car p) '--) @@ -58,43 +58,43 @@ (cons (cons (cadr p) expr) state))) ((eq (car p) '-$) ; greedy alternation for toplevel pattern (match-alt (cdr p) () (list expr) state #f 1)) - (T - (and (consp expr) + (#t + (and (pair? expr) (equal (car p) (car expr)) (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) - (T + (#t (and (equal p expr) state)))) ; match an alternation (define (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 - (match-seq prest (cdr expr) - (if var - (cons (cons var (car expr)) - subma) - subma) - (- L 1))) - (match-alt (cdr alt) prest expr state var L))))) + (if (null? alt) #f ; no alternatives left + (let ((subma (match- (car alt) (car expr) state))) + (or (and subma + (match-seq prest (cdr expr) + (if var + (cons (cons var (car expr)) + subma) + subma) + (- L 1))) + (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) (cond ; case 0: impossible to match ((> min max) #f) - ; case 1: only allowed to match 0 subexpressions + ; case 1: only allowed to match 0 subexpressions ((= max 0) (match-seq prest expr (if var (cons (cons var (reverse sofar)) state) - state) + state) L)) - ; case 2: must match at least 1 + ; case 2: must match at least 1 ((> min 0) (and (match- p (car expr) state) (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) (cons (car expr) sofar)))) - ; otherwise, must match either 0 or between 1 and max subexpressions - (T + ; otherwise, must match either 0 or between 1 and max subexpressions + (#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) @@ -103,16 +103,16 @@ ; match sequences of expressions (define (match-seq p expr state L) (cond ((not state) #f) - ((null p) (if (null expr) state #f)) - (T + ((null? p) (if (null? expr) state #f)) + (#t (let ((subp (car p)) (var #f)) - (if (and (consp subp) + (if (and (pair? subp) (eq (car subp) '--)) (begin (set! var (cadr subp)) (set! subp (caddr subp))) - #f) - (let ((head (if (consp subp) (car subp) ()))) + #f) + (let ((head (if (pair? subp) (car subp) ()))) (cond ((eq subp '...) (match-star '_ (cdr p) expr state var 0 L L)) ((eq head '-*) @@ -123,8 +123,8 @@ (match-star (cadr subp) (cdr p) expr state var 0 1 L)) ((eq head '-$) (match-alt (cdr subp) (cdr p) expr state var L)) - (T - (and (consp expr) + (#t + (and (pair? expr) (match-seq (cdr p) (cdr expr) (match- (car p) (car expr) state) (- L 1)))))))))) @@ -133,32 +133,32 @@ ; given a pattern p, return the list of capturing variables it uses (define (patargs- p) - (cond ((and (symbolp p) + (cond ((and (symbol? p) (not (member p metasymbols))) (list p)) - ((consp p) + ((pair? p) (if (eq (car p) '-/) () - (unique (apply append (map patargs- (cdr p)))))) + (unique (apply append (map patargs- (cdr p)))))) - (T ()))) + (#t ()))) (define (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) - (if (null plist) expr - (if (function? plist) - (let ((enew (plist expr))) - (if (not enew) - expr - enew)) - (let ((enew ((car plist) expr))) - (if (not enew) - (apply-patterns (cdr plist) expr) - enew))))) + (if (null? plist) expr + (if (procedure? plist) + (let ((enew (plist expr))) + (if (not enew) + expr + enew)) + (let ((enew ((car plist) expr))) + (if (not enew) + (apply-patterns (cdr plist) expr) + enew))))) ; top-down fixed-point macroexpansion. this is a typical algorithm, ; but it may leave some structure that matches a pattern unexpanded. @@ -170,13 +170,12 @@ ; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3)) ; TODO: ignore quoted expressions (define (pattern-expand plist expr) - (if (not (consp expr)) + (if (not (pair? expr)) expr - (let ((enew (apply-patterns plist expr))) - (if (eq enew expr) - ; expr didn't change; move to subexpressions - (cons (car expr) - (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) - ; expr changed; iterate - - (pattern-expand plist enew))))) + (let ((enew (apply-patterns plist expr))) + (if (eq enew expr) + ; expr didn't change; move to subexpressions + (cons (car expr) + (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) + ; expr changed; iterate + (pattern-expand plist enew))))) diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp index ae46993..2f1dbb4 100644 --- a/femtolisp/ast/rpasses.lsp +++ b/femtolisp/ast/rpasses.lsp @@ -7,9 +7,9 @@ ; tree inspection utils (define (assigned-var e) - (and (consp e) + (and (pair? e) (or (eq (car e) '<-) (eq (car e) 'ref=)) - (symbolp (cadr e)) + (symbol? (cadr e)) (cadr e))) (define (func-argnames f) @@ -26,13 +26,13 @@ (define (dollarsign-transform e) (pattern-expand (pattern-lambda ($ lhs name) - (let* ((g (if (not (consp lhs)) lhs (r-gensym))) - (n (if (symbolp name) + (let* ((g (if (not (pair? lhs)) lhs (r-gensym))) + (n (if (symbol? name) name ;(symbol->string name) name)) (expr `(r-call r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) - (if (not (consp lhs)) + (if (not (pair? lhs)) expr `(r-block (ref= ,g ,lhs) ,expr)))) e)) @@ -46,9 +46,9 @@ (pattern-expand (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) (<<- (r-call f lhs ...) rhs)) - (let ((g (if (consp rhs) (r-gensym) rhs)) + (let ((g (if (pair? rhs) (r-gensym) rhs)) (op (car __))) - `(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ()) + `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) ,g))) e)) @@ -68,10 +68,10 @@ ; convert r function expressions to lambda (define (normalize-r-functions e) (maptree-post (lambda (n) - (if (and (consp n) (eq (car n) 'function)) + (if (and (pair? n) (eq (car n) 'function)) `(lambda ,(func-argnames n) (r-block ,@(gen-default-inits (cadr n)) - ,@(if (and (consp (caddr n)) + ,@(if (and (pair? (caddr n)) (eq (car (caddr n)) 'r-block)) (cdr (caddr n)) (list (caddr n))))) @@ -81,19 +81,19 @@ (define (find-assigned-vars n) (let ((vars ())) (maptree-pre (lambda (s) - (if (not (consp s)) s + (if (not (pair? s)) s (cond ((eq (car s) 'lambda) ()) ((eq (car s) '<-) (set! vars (list-adjoin (cadr s) vars)) (cddr s)) - (T s)))) + (#t s)))) n) vars)) ; introduce let based on assignment statements (define (letbind-locals e) (maptree-post (lambda (n) - (if (and (consp n) (eq (car n) 'lambda)) + (if (and (pair? n) (eq (car n) 'lambda)) (let ((vars (find-assigned-vars (cddr n)))) `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ())) vars) diff --git a/femtolisp/dict.lsp b/femtolisp/attic/dict.lsp similarity index 100% rename from femtolisp/dict.lsp rename to femtolisp/attic/dict.lsp diff --git a/femtolisp/color.lsp b/femtolisp/color.lsp index f1b9a50..0d79728 100644 --- a/femtolisp/color.lsp +++ b/femtolisp/color.lsp @@ -1,23 +1,17 @@ ; -*- scheme -*- -; uncomment for compatibility with CL -;(defun mapp (f l) (mapcar f l)) -;(defmacro define (name &rest body) -; (if (symbolp name) -; (list 'setq name (car body)) -; (list 'defun (car name) (cdr name) (cons 'progn body)))) ; dictionaries ---------------------------------------------------------------- (define (dict-new) ()) (define (dict-extend dl key value) - (cond ((null dl) (list (cons key value))) - ((equal key (caar dl)) (cons (cons key value) (cdr dl))) - (T (cons (car dl) (dict-extend (cdr 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) - (cond ((null dl) ()) - ((equal key (caar dl)) (cdar dl)) - (T (dict-lookup (cdr dl) key)))) + (cond ((null? dl) ()) + ((equal? key (caar dl)) (cdar dl)) + (else (dict-lookup (cdr dl) key)))) (define (dict-keys dl) (map car dl)) @@ -39,7 +33,7 @@ (define (graph-add-node g n1) (dict-extend g n1 ())) (define (graph-from-edges edge-list) - (if (null edge-list) + (if (null? edge-list) (graph-empty) (graph-connect (graph-from-edges (cdr edge-list)) (caar edge-list) @@ -52,17 +46,17 @@ (map (lambda (n) (let ((color-pair (assq n coloring))) - (if (consp color-pair) (cdr color-pair) ()))) + (if (pair? color-pair) (cdr color-pair) ()))) (graph-neighbors g node-to-color))))) (define (try-each f lst) - (if (null lst) #f + (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) (cond - ((null uncolored-nodes) coloring) + ((null? uncolored-nodes) coloring) ((node-colorable? g coloring (car uncolored-nodes) color) (let ((new-coloring (cons (cons (car uncolored-nodes) color) coloring))) @@ -71,8 +65,8 @@ colors))))) (define (color-graph g colors) - (if (null colors) - (and (null (graph-nodes g)) ()) + (if (null? colors) + (and (null? (graph-nodes g)) ()) (color-node g () colors (graph-nodes g) (car colors)))) (define (color-pairs pairs colors) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index fb015e2..cd0873d 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -2,7 +2,7 @@ (define (cond->if form) (cond-clauses->if (cdr form))) (define (cond-clauses->if lst) - (if (atom lst) + (if (atom? lst) lst (let ((clause (car lst))) `(if ,(car clause) @@ -10,11 +10,11 @@ ,(cond-clauses->if (cdr lst)))))) (define (begin->cps forms k) - (cond ((atom forms) `(,k ,forms)) - ((null (cdr forms)) (cps- (car forms) k)) - (T (let ((_ (gensym))) ; var to bind ignored value - (cps- (car forms) `(lambda (,_) - ,(begin->cps (cdr forms) k))))))) + (cond ((atom? forms) `(,k ,forms)) + ((null? (cdr forms)) (cps- (car forms) k)) + (#t (let ((_ (gensym))) ; var to bind ignored value + (cps- (car forms) `(lambda (,_) + ,(begin->cps (cdr forms) k))))))) (define-macro (lambda/cc args body) `(rplaca (lambda ,args ,body) 'lambda/cc)) @@ -44,7 +44,7 @@ (define (rest->cps xformer form k argsyms) (let ((el (car form))) - (if (or (atom el) (constant? el)) + (if (or (atom? el) (constant? el)) (xformer (cdr form) k (cons el argsyms)) (let ((g (gensym))) (cps- el `(lambda (,g) @@ -58,17 +58,17 @@ ; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X))))) (define (app->cps form k argsyms) - (cond ((atom form) + (cond ((atom? form) (let ((r (reverse argsyms))) (make-funcall/cc (car r) k (cdr r)))) - (T (rest->cps app->cps form k argsyms)))) + (#t (rest->cps app->cps form k argsyms)))) ; (+ x) => (cps- x `(lambda (X) (,k (+ X)))) (define (builtincall->cps form k) (prim->cps (cdr form) k (list (car form)))) (define (prim->cps form k argsyms) - (cond ((atom form) `(,k ,(reverse argsyms))) - (T (rest->cps prim->cps form k argsyms)))) + (cond ((atom? form) `(,k ,(reverse argsyms))) + (#t (rest->cps prim->cps form k argsyms)))) (define *top-k* (gensym)) (set *top-k* identity) @@ -80,7 +80,7 @@ (cps- (macroexpand form) *top-k*))))) (define (cps- form k) (let ((g (gensym))) - (cond ((or (atom form) (constant? form)) + (cond ((or (atom? form) (constant? form)) `(,k ,form)) ((eq (car form) 'lambda) @@ -96,7 +96,7 @@ (let ((test (cadr form)) (then (caddr form)) (else (cadddr form))) - (if (atom k) + (if (atom? k) (cps- test `(lambda (,g) (if ,g ,(cps- then k) @@ -105,9 +105,9 @@ ,(cps- form g))))) ((eq (car form) 'and) - (cond ((atom (cdr form)) `(,k T)) - ((atom (cddr form)) (cps- (cadr form) k)) - (T + (cond ((atom? (cdr form)) `(,k #t)) + ((atom? (cddr form)) (cps- (cadr form) k)) + (#t (if (atom k) (cps- (cadr form) `(lambda (,g) @@ -117,10 +117,10 @@ ,(cps- form g)))))) ((eq (car form) 'or) - (cond ((atom (cdr form)) `(,k #f)) - ((atom (cddr form)) (cps- (cadr form) k)) - (T - (if (atom k) + (cond ((atom? (cdr form)) `(,k #f)) + ((atom? (cddr form)) (cps- (cadr form) k)) + (#t + (if (atom? k) (cps- (cadr form) `(lambda (,g) (if ,g (,k ,g) @@ -168,23 +168,23 @@ (eq (caar form) 'lambda)) (let ((largs (cadr (car form))) (lbody (caddr (car form)))) - (cond ((null largs) ; ((lambda () body)) + (cond ((null? largs) ; ((lambda () body)) (cps- lbody k)) - ((symbolp largs) ; ((lambda x body) args...) + ((symbol? largs) ; ((lambda x body) args...) (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k)) - (T + (#t (cps- (cadr form) `(lambda (,(car largs)) ,(cps- `((lambda ,(cdr largs) ,lbody) ,@(cddr form)) k))))))) - (T + (#t (app->cps form k ()))))) ; (lambda (args...) (f args...)) => f ; but only for constant, builtin f (define (η-reduce form) - (cond ((or (atom form) (constant? form)) form) + (cond ((or (atom? form) (constant? form)) form) ((and (eq (car form) 'lambda) (let ((body (caddr form)) (args (cadr form))) @@ -192,16 +192,16 @@ (equal (cdr body) args) (constant? (car (caddr form)))))) (car (caddr form))) - (T (map η-reduce form)))) + (#t (map η-reduce form)))) (define (contains x form) (or (eq form x) (any (lambda (p) (contains x p)) form))) (define (β-reduce form) - (if (or (atom form) (constant? form)) + (if (or (atom? form) (constant? form)) form - (β-reduce- (map β-reduce form)))) + (β-reduce- (map β-reduce form)))) (define (β-reduce- form) ; ((lambda (f) (f arg)) X) => (X arg) @@ -215,7 +215,7 @@ (= (length args) 1) (eq (car body) (car args)) (not (eq (cadr body) (car args))) - (symbolp (cadr body))))) + (symbol? (cadr body))))) `(,(cadr form) ,(cadr (caddr (car form))))) @@ -230,7 +230,7 @@ ((and (= (length form) 2) (pair? (car form)) (eq (caar form) 'lambda) - (or (atom (cadr form)) (constant? (cadr form))) + (or (atom? (cadr form)) (constant? (cadr form))) (let ((args (cadr (car form))) (s (cadr form)) (body (caddr (car form)))) @@ -247,7 +247,7 @@ ,s ,@params))))))) - (T form))) + (#t form))) (define-macro (with-delimited-continuations . code) (cps (f-body code))) @@ -287,7 +287,7 @@ (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ()))))))))) '(a 1 b b c))) -T +#t #| todo: diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 803383c..1100853 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -791,7 +791,7 @@ static value_t cvalue_array_aset(value_t *args) { char *data; ulong_t index; fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype; - check_addr_args("aset", args[0], args[1], &data, &index); + check_addr_args("aset!", args[0], args[1], &data, &index); char *dest = data + index*eltype->size; cvalue_init(eltype, args[2], dest); return args[2]; diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 23902d0..34bf6ee 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -60,7 +60,7 @@ static char *builtin_names[] = "cons", "list", "car", "cdr", "set-car!", "set-cdr!", "eval", "eval*", "apply", "prog1", "raise", "+", "-", "*", "/", "<", "~", "&", "!", "$", - "vector", "aref", "aset", "length", "assq", "compare", "for", + "vector", "aref", "aset!", "length", "assq", "compare", "for", "", "", "" }; #define N_STACK 98304 @@ -1004,19 +1004,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } break; case F_ASET: - argcount("aset", nargs, 3); + argcount("aset!", nargs, 3); e = Stack[SP-3]; if (isvector(e)) { - i = tofixnum(Stack[SP-2], "aset"); + i = tofixnum(Stack[SP-2], "aset!"); if (__unlikely((unsigned)i >= vector_size(e))) - bounds_error("aref", v, Stack[SP-1]); + bounds_error("aset!", v, Stack[SP-1]); vector_elt(e, i) = (v=Stack[SP-1]); } else if (isarray(e)) { v = cvalue_array_aset(&Stack[SP-3]); } else { - type_error("aset", "sequence", e); + type_error("aset!", "sequence", e); } break; case F_ATOM: diff --git a/femtolisp/print.c b/femtolisp/print.c index acdd455..5f036b3 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -520,14 +520,22 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, else HPOS+=ios_printf(f, "%s", rep); } + else if (d == 0) { + if (1/d < 0) + HPOS+=ios_printf(f, "-0.0%s", type==floatsym?"f":""); + else + HPOS+=ios_printf(f, "0.0%s", type==floatsym?"f":""); + } else { snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10); - if (weak || princ || strpbrk(buf, ".eE")) { - outs(buf, f); + int hasdec = (strpbrk(buf, ".eE") != NULL); + outs(buf, f); + if (weak || princ || hasdec) { if (type == floatsym) outc('f', f); } else { - HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), buf); + if (!hasdec) outs(".0", f); + if (type==floatsym) outc('f', f); } } } diff --git a/femtolisp/read.c b/femtolisp/read.c index 6c06c3c..55730cc 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -16,7 +16,16 @@ static int symchar(char c) return (!isspace(c) && !strchr(special, c)); } -static int isnumtok(char *tok, value_t *pval) +static int isdigit_base(char c, int base) +{ + if (base < 11) + return (c >= '0' && c < '0'+base); + return ((c >= '0' && c <= '9') || + (c >= 'a' && c < 'a'+base-10) || + (c >= 'A' && c < 'A'+base-10)); +} + +static int isnumtok_base(char *tok, value_t *pval, int base) { char *end; int64_t i64; @@ -24,50 +33,63 @@ static int isnumtok(char *tok, value_t *pval) double d; if (*tok == '\0') return 0; - if (!(tok[0]=='0' && isdigit(tok[1])) && - strpbrk(tok, ".eEpP")) { + if (strpbrk(tok, ".eEpP")) { d = strtod(tok, &end); if (*end == '\0') { if (pval) *pval = mk_double(d); return 1; } - if (end > tok && end[0] == 'f' && end[1] == '\0') { + // floats can end in f or f0 + if (end > tok && end[0] == 'f' && + (end[1] == '\0' || + (end[1] == '0' && end[2] == '\0'))) { if (pval) *pval = mk_float((float)d); return 1; } } if (tok[0] == '+') { - if (!strcmp(tok,"+NaN")) { + if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) { if (pval) *pval = mk_double(D_PNAN); return 1; } - if (!strcmp(tok,"+Inf")) { + if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) { if (pval) *pval = mk_double(D_PINF); return 1; } } else if (tok[0] == '-') { - if (!strcmp(tok,"-NaN")) { + if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) { if (pval) *pval = mk_double(D_NNAN); return 1; } - if (!strcmp(tok,"-Inf")) { + if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) { if (pval) *pval = mk_double(D_NINF); return 1; } - i64 = strtoll(tok, &end, 0); + i64 = strtoll(tok, &end, base); if (pval) *pval = return_from_int64(i64); return (*end == '\0'); } - else if (!isdigit(tok[0])) { - return 0; - } - ui64 = strtoull(tok, &end, 0); + ui64 = strtoull(tok, &end, base); if (pval) *pval = return_from_uint64(ui64); return (*end == '\0'); } +static int isnumtok(char *tok, value_t *pval) +{ + return isnumtok_base(tok, pval, 0); +} + +static int read_numtok(char *tok, value_t *pval, int base) +{ + int result; + errno = 0; + result = isnumtok_base(tok, pval, base); + if (errno) lerror(ParseError, "read: overflow in numeric constant"); + return result; +} + static u_int32_t toktype = TOK_NONE; static value_t tokval; static char buf[256]; @@ -148,7 +170,7 @@ static u_int32_t peek(ios_t *f) { char c, *end; fixnum_t x; - int ch; + int ch, base; if (toktype != TOK_NONE) return toktype; @@ -176,30 +198,30 @@ static u_int32_t peek(ios_t *f) toktype = TOK_DOUBLEQUOTE; } else if (c == '#') { - ch = ios_getc(f); + ch = ios_getc(f); c = (char)ch; if (ch == IOS_EOF) lerror(ParseError, "read: invalid read macro"); - if ((char)ch == '.') { + if (c == '.') { toktype = TOK_SHARPDOT; } - else if ((char)ch == '\'') { + else if (c == '\'') { toktype = TOK_SHARPQUOTE; } - else if ((char)ch == '\\') { + else if (c == '\\') { uint32_t cval; if (ios_getutf8(f, &cval) == IOS_EOF) lerror(ParseError, "read: end of input in character constant"); toktype = TOK_NUM; tokval = mk_wchar(cval); } - else if ((char)ch == '(') { + else if (c == '(') { toktype = TOK_SHARPOPEN; } - else if ((char)ch == '<') { + else if (c == '<') { lerror(ParseError, "read: unreadable object"); } - else if (isdigit((char)ch)) { - read_token(f, (char)ch, 1); + else if (isdigit(c)) { + read_token(f, c, 1); c = (char)ios_getc(f); if (c == '#') toktype = TOK_BACKREF; @@ -213,14 +235,14 @@ static u_int32_t peek(ios_t *f) lerror(ParseError, "read: invalid label"); tokval = fixnum(x); } - else if ((char)ch == '!') { + else if (c == '!') { // #! single line comment for shbang script support do { ch = ios_getc(f); } while (ch != IOS_EOF && (char)ch != '\n'); return peek(f); } - else if ((char)ch == '|') { + else if (c == '|') { // multiline comment int commentlevel=1; while (1) { @@ -250,10 +272,10 @@ static u_int32_t peek(ios_t *f) // this was whitespace, so keep peeking return peek(f); } - else if ((char)ch == ';') { + else if (c == ';') { toktype = TOK_SHARPSEMI; } - else if ((char)ch == ':') { + else if (c == ':') { // gensym ch = ios_getc(f); if ((char)ch == 'g') @@ -266,8 +288,18 @@ static u_int32_t peek(ios_t *f) toktype = TOK_GENSYM; tokval = fixnum(x); } - else if (symchar((char)ch)) { + else if (symchar(c)) { read_token(f, ch, 0); + + if (((c == 'b' && (base= 2)) || + (c == 'o' && (base= 8)) || + (c == 'd' && (base=10)) || + (c == 'x' && (base=16))) && isdigit_base(buf[1],base)) { + if (!read_numtok(&buf[1], &tokval, base)) + lerror(ParseError, "read: invalid base %d constant", base); + return (toktype=TOK_NUM); + } + toktype = TOK_SHARPSYM; tokval = symbol(buf); } @@ -293,12 +325,8 @@ static u_int32_t peek(ios_t *f) return (toktype=TOK_DOT); } else { - errno = 0; - if (isnumtok(buf, &tokval)) { - if (errno) - lerror(ParseError,"read: overflow in numeric constant"); + if (read_numtok(buf, &tokval, 0)) return (toktype=TOK_NUM); - } } } toktype = TOK_SYM; diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index c828e12..d1201e0 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -6,28 +6,17 @@ (set-constant! 'eq eq?) (set-constant! 'eqv eqv?) (set-constant! 'equal equal?) -(set-constant! 'booleanp boolean?) -(set-constant! 'consp pair?) -(set-constant! 'null null?) -(set-constant! 'atom atom?) -(set-constant! 'symbolp symbol?) -(set-constant! 'numberp number?) -(set-constant! 'boundp bound?) -(set-constant! 'builtinp builtin?) -(set-constant! 'vectorp vector?) -(set-constant! 'fixnump fixnum?) (set-constant! 'rplaca set-car!) (set-constant! 'rplacd set-cdr!) (set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar))) -(set-constant! 'T #t) ; convert a sequence of body statements to a single expression. ; this allows define, defun, defmacro, let, etc. to contain multiple ; body expressions as in Common Lisp. (set! f-body (lambda (e) - (cond ((atom e) e) + (cond ((atom? e) e) ((eq (cdr e) ()) (car e)) - (T (cons 'begin e))))) + (#t (cons 'begin e))))) (set-syntax! 'define-macro (lambda (form . body) @@ -38,7 +27,7 @@ (list (list 'lambda (list name) (list 'set! name fn)) #f)) (define-macro (define form . body) - (if (symbolp form) + (if (symbol? form) (list 'set! form (car body)) (list 'set! (car form) (list 'lambda (cdr form) (f-body body))))) @@ -47,73 +36,73 @@ (define (identity x) x) (define (map f lst) - (if (atom lst) lst + (if (atom? lst) lst (cons (f (car lst)) (map f (cdr lst))))) (define-macro (let binds . body) (cons (list 'lambda - (map (lambda (c) (if (consp c) (car c) c)) binds) + (map (lambda (c) (if (pair? c) (car c) c)) binds) (f-body body)) - (map (lambda (c) (if (consp c) (cadr c) #f)) binds))) + (map (lambda (c) (if (pair? c) (cadr c) #f)) binds))) (define (nconc . lsts) - (cond ((null lsts) ()) - ((null (cdr lsts)) (car lsts)) - ((null (car lsts)) (apply nconc (cdr lsts))) - (T (prog1 (car lsts) - (rplacd (last (car lsts)) - (apply nconc (cdr lsts))))))) + (cond ((null? lsts) ()) + ((null? (cdr lsts)) (car lsts)) + ((null? (car lsts)) (apply nconc (cdr lsts))) + (#t (prog1 (car lsts) + (rplacd (last (car lsts)) + (apply nconc (cdr lsts))))))) (define (append . lsts) - (cond ((null lsts) ()) - ((null (cdr lsts)) (car lsts)) - (T ((label append2 (lambda (l d) - (if (null l) d - (cons (car l) - (append2 (cdr l) d))))) - (car lsts) (apply append (cdr lsts)))))) + (cond ((null? lsts) ()) + ((null? (cdr lsts)) (car lsts)) + (#t ((label append2 (lambda (l d) + (if (null? l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (apply append (cdr lsts)))))) (define (member item lst) - (cond ((atom lst) #f) - ((equal (car lst) item) lst) - (T (member item (cdr lst))))) + (cond ((atom? lst) #f) + ((equal (car lst) item) lst) + (#t (member item (cdr lst))))) (define (memq item lst) - (cond ((atom lst) #f) - ((eq (car lst) item) lst) - (T (memq item (cdr lst))))) + (cond ((atom? lst) #f) + ((eq (car lst) item) lst) + (#t (memq item (cdr lst))))) (define (memv item lst) - (cond ((atom lst) #f) - ((eqv (car lst) item) lst) - (T (memv item (cdr lst))))) + (cond ((atom? lst) #f) + ((eqv (car lst) item) lst) + (#t (memv item (cdr lst))))) (define (assoc item lst) - (cond ((atom lst) #f) - ((equal (caar lst) item) (car lst)) - (T (assoc item (cdr lst))))) + (cond ((atom? lst) #f) + ((equal (caar lst) item) (car lst)) + (#t (assoc item (cdr lst))))) (define (assv item lst) - (cond ((atom lst) #f) - ((eqv (caar lst) item) (car lst)) - (T (assv item (cdr lst))))) + (cond ((atom? lst) #f) + ((eqv (caar lst) item) (car lst)) + (#t (assv item (cdr lst))))) -(define (macrocall? e) (and (symbolp (car e)) +(define (macrocall? e) (and (symbol? (car e)) (symbol-syntax (car e)))) (define (function? x) - (or (builtinp x) - (and (consp x) (eq (car x) 'lambda)))) + (or (builtin? x) + (and (pair? x) (eq (car x) 'lambda)))) (define procedure? function?) (define (macroexpand-1 e) - (if (atom e) e + (if (atom? e) e (let ((f (macrocall? e))) (if f (apply f (cdr e)) e)))) ; convert to proper list, i.e. remove "dots", and append (define (append.2 l tail) - (cond ((null l) tail) - ((atom l) (cons l tail)) - (T (cons (car l) (append.2 (cdr l) tail))))) + (cond ((null? l) tail) + ((atom? l) (cons l tail)) + (#t (cons (car l) (append.2 (cdr l) tail))))) (define (cadr x) (car (cdr x))) @@ -124,27 +113,27 @@ ((label mexpand (lambda (e env f) (begin - (while (and (consp e) + (while (and (pair? e) (not (member (car e) env)) (set! f (macrocall? e))) (set! e (apply f (cdr e)))) - (cond ((and (consp e) + (cond ((and (pair? e) (not (eq (car e) 'quote))) (let ((newenv (if (and (eq (car e) 'lambda) - (consp (cdr e))) + (pair? (cdr e))) (append.2 (cadr e) env) env))) (map (lambda (x) (mexpand x newenv ())) e))) - ;((and (symbolp e) (constant? e)) (eval e)) - ;((and (symbolp e) + ;((and (symbol? e) (constant? e)) (eval e)) + ;((and (symbol? e) ; (not (member e *special-forms*)) ; (not (member e env))) (cons '%top e)) - (T e))))) + (#t e))))) e () ())) (define-macro (define form . body) - (if (symbolp form) + (if (symbol? form) (list 'set! form (car body)) (list 'set! (car form) (macroexpand (list 'lambda (cdr form) (f-body body)))))) @@ -163,6 +152,7 @@ (define (1+ n) (+ n 1)) (define (1- n) (- n 1)) (define (mod x y) (- x (* (/ x y) y))) +(define remainder mod) (define (abs x) (if (< x 0) (- x) x)) (define K prog1) ; K combinator ;) @@ -180,99 +170,101 @@ (define (cdddr x) (cdr (cdr (cdr x)))) (define (every pred lst) - (or (atom lst) + (or (atom? lst) (and (pred (car lst)) (every pred (cdr lst))))) (define (any pred lst) - (and (consp lst) + (and (pair? lst) (or (pred (car lst)) (any pred (cdr lst))))) -(define (listp a) (or (null a) (consp a))) -(define (list? a) (or (null a) (and (pair? a) (list? (cdr a))))) +(define (listp a) (or (null? a) (pair? a))) +(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a))))) (define (nthcdr lst n) (if (<= n 0) lst (nthcdr (cdr lst) (- n 1)))) +(define list-tail nthcdr) (define (list-ref lst n) (car (nthcdr lst n))) (define (list* . l) - (if (atom (cdr l)) + (if (atom? (cdr l)) (car l) (cons (car l) (apply list* (cdr l))))) (define (nlist* . l) - (if (atom (cdr l)) + (if (atom? (cdr l)) (car l) (rplacd l (apply nlist* (cdr l))))) (define (lastcdr l) - (if (atom l) l + (if (atom? l) l (lastcdr (cdr l)))) (define (last l) - (cond ((atom l) l) - ((atom (cdr l)) l) - (T (last (cdr l))))) + (cond ((atom? l) l) + ((atom? (cdr l)) l) + (#t (last (cdr l))))) +(define last-pair last) (define (map! f lst) (prog1 lst - (while (consp lst) + (while (pair? lst) (rplaca lst (f (car lst))) (set! lst (cdr lst))))) (define (mapcar f . lsts) ((label mapcar- (lambda (lsts) - (cond ((null lsts) (f)) - ((atom (car lsts)) (car lsts)) - (T (cons (apply f (map car lsts)) - (mapcar- (map cdr lsts))))))) + (cond ((null? lsts) (f)) + ((atom? (car lsts)) (car lsts)) + (#t (cons (apply f (map car lsts)) + (mapcar- (map cdr lsts))))))) lsts)) (define (transpose M) (apply mapcar (cons list M))) (define (filter pred lst) (filter- pred lst ())) (define (filter- pred lst accum) - (cond ((null lst) accum) + (cond ((null? lst) accum) ((pred (car lst)) (filter- pred (cdr lst) (cons (car lst) accum))) - (T + (#t (filter- pred (cdr lst) accum)))) (define (separate pred lst) (separate- pred lst () ())) (define (separate- pred lst yes no) - (cond ((null lst) (cons yes no)) + (cond ((null? lst) (cons yes no)) ((pred (car lst)) (separate- pred (cdr lst) (cons (car lst) yes) no)) - (T + (#t (separate- pred (cdr lst) yes (cons (car lst) no))))) (define (foldr f zero lst) - (if (null lst) zero + (if (null? lst) zero (f (car lst) (foldr f zero (cdr lst))))) (define (foldl f zero lst) - (if (null lst) zero + (if (null? lst) zero (foldl f (f (car lst) zero) (cdr lst)))) (define (reverse lst) (foldl cons () lst)) (define (copy-list l) - (if (atom l) l + (if (atom? l) l (cons (car l) (copy-list (cdr l))))) (define (copy-tree l) - (if (atom l) l + (if (atom? l) l (cons (copy-tree (car l)) (copy-tree (cdr l))))) (define (nreverse l) (let ((prev ())) - (while (consp l) + (while (pair? l) (set! l (prog1 (cdr l) (rplacd l (prog1 prev (set! prev l)))))) @@ -324,7 +316,7 @@ (define-macro (catch tag expr) (let ((e (gensym))) `(trycatch ,expr - (lambda (,e) (if (and (consp ,e) + (lambda (,e) (if (and (pair? ,e) (eq (car ,e) 'thrown-value) (eq (cadr ,e) ,tag)) (caddr ,e) @@ -354,15 +346,15 @@ extype)) (todo (cddr catc))) `(,(if specific - ; exception matching logic + ; exception matching logic `(or (eq ,e ',extype) - (and (consp ,e) + (and (pair? ,e) (eq (car ,e) ',extype))) - T); (catch (e) ...), match anything + #t); (catch (e) ...), match anything (let ((,var ,e)) (begin ,@todo))))) catches) - (T (raise ,e))))) ; no matches, reraise + (#t (raise ,e))))) ; no matches, reraise (if final (if catches ; form with both catch and finally @@ -400,15 +392,15 @@ (cddar rplacd cdar) (cdddr rplacd cddr) (list-ref rplaca nthcdr) - (get put identity) - (aref aset identity) + (get put! identity) + (aref aset! identity) (symbol-syntax set-syntax! identity))) (define (setf-place-mutator place val) - (if (symbolp place) + (if (symbol? place) (list 'set! place val) (let ((mutator (assq (car place) *setf-place-list*))) - (if (null mutator) + (if (null? mutator) (error "setf: unknown place " (car place)) (if (eq (caddr mutator) 'identity) (cons (cadr mutator) (append (cdr place) (list val))) @@ -420,7 +412,7 @@ (f-body ((label setf- (lambda (args) - (if (null args) + (if (null? args) () (cons (setf-place-mutator (car args) (cadr args)) (setf- (cddr args)))))) @@ -439,8 +431,8 @@ l)) (define (self-evaluating? x) - (or (and (atom x) - (not (symbolp x))) + (or (and (atom? x) + (not (symbol? x))) (and (constant? x) (eq x (eval x))))) @@ -448,54 +440,54 @@ (define-macro (backquote x) (bq-process x)) (define (splice-form? x) - (or (and (consp x) (or (eq (car x) '*comma-at*) + (or (and (pair? x) (or (eq (car x) '*comma-at*) (eq (car x) '*comma-dot*))) (eq x '*comma*))) (define (bq-process x) (cond ((self-evaluating? x) - (if (vectorp x) + (if (vector? x) (let ((body (bq-process (vector-to-list x)))) (if (eq (car body) 'list) (cons vector (cdr body)) (list apply vector body))) x)) - ((atom x) (list 'quote x)) + ((atom? x) (list 'quote x)) ((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) ((eq (car x) '*comma*) (cadr x)) ((not (any splice-form? x)) (let ((lc (lastcdr x)) (forms (map bq-bracket1 x))) - (if (null lc) + (if (null? lc) (cons 'list forms) (nconc (cons 'nlist* forms) (list (bq-process lc)))))) - (T (let ((p x) (q ())) - (while (and (consp p) - (not (eq (car p) '*comma*))) - (set! q (cons (bq-bracket (car p)) q)) - (set! p (cdr p))) - (let ((forms - (cond ((consp p) (nreconc q (list (cadr p)))) - ((null p) (nreverse q)) - (T (nreconc q (list (bq-process p))))))) - (if (null (cdr forms)) - (car forms) - (cons 'nconc forms))))))) + (#t (let ((p x) (q ())) + (while (and (pair? p) + (not (eq (car p) '*comma*))) + (set! q (cons (bq-bracket (car p)) q)) + (set! p (cdr p))) + (let ((forms + (cond ((pair? p) (nreconc q (list (cadr p)))) + ((null? p) (nreverse q)) + (#t (nreconc q (list (bq-process p))))))) + (if (null? (cdr forms)) + (car forms) + (cons 'nconc forms))))))) (define (bq-bracket x) - (cond ((atom x) (list list (bq-process x))) + (cond ((atom? x) (list list (bq-process x))) ((eq (car x) '*comma*) (list list (cadr x))) ((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) ((eq (car x) '*comma-dot*) (cadr x)) - (T (list list (bq-process x))))) + (#t (list list (bq-process x))))) ; bracket without splicing (define (bq-bracket1 x) - (if (and (consp x) (eq (car x) '*comma*)) + (if (and (pair? x) (eq (car x) '*comma*)) (cadr x) (bq-process x))) -(define-macro (assert expr) `(if ,expr T (raise '(assert-failed ,expr)))) +(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (time expr) (let ((t0 (gensym))) @@ -504,14 +496,16 @@ ,expr (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) -(define (display x) (princ x) (princ "\n")) +(define (display x) (princ x) #t) + +(define (vu8 . elts) (apply array (cons 'uint8 elts))) (define (vector.map f v) (let* ((n (length v)) (nv (vector.alloc n))) (for 0 (- n 1) (lambda (i) - (aset nv i (f (aref v i))))) + (aset! nv i (f (aref v i))))) nv)) (define (table.pairs t) @@ -525,6 +519,6 @@ () t)) (define (table.clone t) (let ((nt (table))) - (table.foldl (lambda (k v z) (put nt k v)) + (table.foldl (lambda (k v z) (put! nt k v)) () t) nt)) diff --git a/femtolisp/table.c b/femtolisp/table.c index 751cca1..58f5375 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -103,11 +103,11 @@ value_t fl_table(value_t *args, uint32_t nargs) return nt; } -// (put table key value) +// (put! table key value) value_t fl_table_put(value_t *args, uint32_t nargs) { - argcount("put", nargs, 3); - htable_t *h = totable(args[0], "put"); + argcount("put!", nargs, 3); + htable_t *h = totable(args[0], "put!"); void **table0 = h->table; equalhash_put(h, (void*)args[1], (void*)args[2]); // register finalizer if we outgrew inline space @@ -142,13 +142,13 @@ value_t fl_table_has(value_t *args, uint32_t nargs) return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F; } -// (del table key) +// (del! table key) value_t fl_table_del(value_t *args, uint32_t nargs) { - argcount("del", nargs, 2); - htable_t *h = totable(args[0], "del"); + argcount("del!", nargs, 2); + htable_t *h = totable(args[0], "del!"); if (!equalhash_remove(h, (void*)args[1])) - lerror(KeyError, "del: key not found"); + lerror(KeyError, "del!: key not found"); return args[0]; } @@ -178,10 +178,10 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs) static builtinspec_t tablefunc_info[] = { { "table", fl_table }, { "table?", fl_tablep }, - { "put", fl_table_put }, + { "put!", fl_table_put }, { "get", fl_table_get }, { "has", fl_table_has }, - { "del", fl_table_del }, + { "del!", fl_table_del }, { "table.foldl", fl_table_foldl }, { NULL, NULL } }; diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index bea51a5..18b6cd5 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -9,20 +9,20 @@ ;(define (reverse lst) ; ((label rev-help (lambda (lst result) -; (if (null lst) result +; (if (null? lst) result ; (rev-help (cdr lst) (cons (car lst) result))))) ; lst ())) (define (append- . lsts) ((label append-h (lambda (lsts) - (cond ((null lsts) ()) - ((null (cdr lsts)) (car lsts)) - (T ((label append2 (lambda (l d) - (if (null l) d - (cons (car l) - (append2 (cdr l) d))))) - (car lsts) (append-h (cdr lsts))))))) + (cond ((null? lsts) ()) + ((null? (cdr lsts)) (car lsts)) + (#t ((label append2 (lambda (l d) + (if (null? l) d + (cons (car l) + (append2 (cdr l) d))))) + (car lsts) (append-h (cdr lsts))))))) lsts)) ;(princ 'Hello '| | 'world! "\n") @@ -38,13 +38,13 @@ ; iterative filter (define (ifilter pred lst) ((label f (lambda (accum lst) - (cond ((null lst) (nreverse accum)) + (cond ((null? lst) (nreverse accum)) ((not (pred (car lst))) (f accum (cdr lst))) - (T (f (cons (car lst) accum) (cdr lst)))))) + (#t (f (cons (car lst) accum) (cdr lst)))))) () lst)) (define (sort l) - (if (or (null l) (null (cdr l))) l + (if (or (null? l) (null? (cdr l))) l (let* ((piv (car l)) (halves (separate (lambda (x) (< x piv)) (cdr l)))) (nconc (sort (car halves)) @@ -81,13 +81,13 @@ (cond ((= p 0) 1) ((= b 0) 0) ((evenp p) (square (expt b (/ p 2)))) - (T (* b (expt b (- p 1)))))) + (#t (* b (expt b (- p 1)))))) (define (gcd a b) (cond ((= a 0) b) ((= b 0) a) ((< a b) (gcd a (- b a))) - (T (gcd b (- a b))))) + (#t (gcd b (- a b))))) ; like eval-when-compile (define-macro (literal expr) @@ -95,7 +95,7 @@ (if (self-evaluating? v) v (list quote v)))) (define (cardepth l) - (if (atom l) 0 + (if (atom? l) 0 (+ 1 (cardepth (car l))))) (define (nestlist f zero n) @@ -105,7 +105,7 @@ (define (mapl f . lsts) ((label mapl- (lambda (lsts) - (if (null (car lsts)) () + (if (null? (car lsts)) () (begin (apply f lsts) (mapl- (map cdr lsts)))))) lsts)) @@ -115,7 +115,7 @@ ; swap the cars and cdrs of every cons in a structure (define (swapad c) - (if (atom c) c + (if (atom? c) c (rplacd c (K (swapad (car c)) (rplaca c (swapad (cdr c))))))) @@ -123,7 +123,7 @@ (filter (lambda (e) (not (eq e x))) l)) (define (conscount c) - (if (consp c) (+ 1 + (if (pair? c) (+ 1 (conscount (car c)) (conscount (cdr c))) 0)) @@ -163,7 +163,7 @@ (todo (f-body (cddr catc)))) `(lambda (,var) (if (or (eq ,var ',extype) - (and (consp ,var) + (and (pair? ,var) (eq (car ,var) ',extype))) ,todo (,next ,var))))) @@ -220,8 +220,8 @@ (cdr ,first)))) (define (map-indexed f lst) - (if (atom lst) lst + (if (atom? lst) lst (let ((i 0)) - (accumulate-while (consp lst) (f (car lst) i) + (accumulate-while (pair? lst) (f (car lst) i) (begin (set! lst (cdr lst)) (set! i (1+ i))))))) diff --git a/femtolisp/torus.lsp b/femtolisp/torus.lsp index dd62299..64cdbc3 100644 --- a/femtolisp/torus.lsp +++ b/femtolisp/torus.lsp @@ -1,6 +1,6 @@ ; -*- scheme -*- (define (maplist f l) - (if (null l) () + (if (null? l) () (cons (f l) (maplist f (cdr l))))) ; produce a beautiful, toroidal cons structure diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp index 9518c2d..b6b98ad 100644 --- a/femtolisp/unittest.lsp +++ b/femtolisp/unittest.lsp @@ -7,9 +7,9 @@ (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n))) (define (each f l) - (if (atom l) () - (begin (f (car l)) - (each f (cdr l))))) + (if (atom? l) () + (begin (f (car l)) + (each f (cdr l))))) (define (each^2 f l m) (each (lambda (o) (each (lambda (p) (f o p)) m)) l)) @@ -82,4 +82,4 @@ (3 . d) (2 . c) (0 . b) (1 . a)))) (princ "all tests pass\n") -T +#t