ref: 17d81eb4e67c178a93e7fcb3c55e81b05029820a
parent: a55b46e9a6af38081aa9376b1f57f1e0d48dc057
author: JeffBezanson <[email protected]>
date: Sat Jan 31 20:53:58 EST 2009
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
--- 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,24 +85,24 @@
; 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 ()))
@@ -109,7 +109,7 @@
; 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))
--- 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,16 +133,16 @@
; 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)))
@@ -149,16 +149,16 @@
; 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)))))
--- 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,12 +81,12 @@
(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))
@@ -93,7 +93,7 @@
; 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)
--- /dev/null
+++ b/femtolisp/attic/dict.lsp
@@ -1,0 +1,51 @@
+; dictionary as binary tree
+
+(defun dict () ())
+
+; node representation ((k . v) L R)
+(defun dict-peek (d key nf)
+ (if (null d) nf
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (cdar d))
+ ((< c 0) (dict-peek (cadr d) key nf))
+ (T (dict-peek (caddr d) key nf))))))
+
+(defun dict-get (d key) (dict-peek d key nil))
+
+(defun dict-put (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
+ ((< c 0) (list (car d)
+ (dict-put (cadr d) key v)
+ (caddr d)))
+ (T (list (car d)
+ (cadr d)
+ (dict-put (caddr d) key v)))))))
+
+; mutable dictionary
+(defun dict-nput (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (rplacd (car d) v))
+ ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v)))
+ (T (setf (caddr d) (dict-nput (caddr d) key v))))
+ d)))
+
+(defun dict-collect (f d)
+ (if (null d) ()
+ (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d))
+ (dict-collect f (caddr d))))))
+
+(defun dict-keys (d) (dict-collect K d))
+(defun dict-pairs (d) (dict-collect cons d))
+
+(defun dict-each (f d)
+ (if (null d) ()
+ (progn (f (caar d) (cdar d))
+ (dict-each f (cadr d))
+ (dict-each f (caddr d)))))
+
+(defun alist-to-dict (a)
+ (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
+ (dict) a))
--- 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)
--- 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,7 +192,7 @@
(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)
@@ -199,9 +199,9 @@
(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:
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -791,7 +791,7 @@
{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];
--- a/femtolisp/dict.lsp
+++ /dev/null
@@ -1,51 +1,0 @@
-; dictionary as binary tree
-
-(defun dict () ())
-
-; node representation ((k . v) L R)
-(defun dict-peek (d key nf)
- (if (null d) nf
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (cdar d))
- ((< c 0) (dict-peek (cadr d) key nf))
- (T (dict-peek (caddr d) key nf))))))
-
-(defun dict-get (d key) (dict-peek d key nil))
-
-(defun dict-put (d key v)
- (if (null d) (list (cons key v) (dict) (dict))
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
- ((< c 0) (list (car d)
- (dict-put (cadr d) key v)
- (caddr d)))
- (T (list (car d)
- (cadr d)
- (dict-put (caddr d) key v)))))))
-
-; mutable dictionary
-(defun dict-nput (d key v)
- (if (null d) (list (cons key v) (dict) (dict))
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (rplacd (car d) v))
- ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v)))
- (T (setf (caddr d) (dict-nput (caddr d) key v))))
- d)))
-
-(defun dict-collect (f d)
- (if (null d) ()
- (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d))
- (dict-collect f (caddr d))))))
-
-(defun dict-keys (d) (dict-collect K d))
-(defun dict-pairs (d) (dict-collect cons d))
-
-(defun dict-each (f d)
- (if (null d) ()
- (progn (f (caar d) (cdar d))
- (dict-each f (cadr d))
- (dict-each f (caddr d)))))
-
-(defun alist-to-dict (a)
- (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
- (dict) a))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -60,7 +60,7 @@
"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,12 +1004,12 @@
}
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)) {@@ -1016,7 +1016,7 @@
v = cvalue_array_aset(&Stack[SP-3]);
}
else {- type_error("aset", "sequence", e);+ type_error("aset!", "sequence", e);}
break;
case F_ATOM:
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -520,14 +520,22 @@
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);}
}
}
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -16,8 +16,17 @@
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;
uint64_t ui64;
@@ -24,14 +33,16 @@
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;
}
@@ -38,36 +49,47 @@
}
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 @@
{char c, *end;
fixnum_t x;
- int ch;
+ int ch, base;
if (toktype != TOK_NONE)
return toktype;
@@ -176,16 +198,16 @@
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");
@@ -192,14 +214,14 @@
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,7 +235,7 @@
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);
@@ -220,7 +242,7 @@
} 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 @@
// 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 @@
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 @@
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;
--- 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,64 +36,64 @@
(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))))
@@ -111,9 +100,9 @@
; 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,47 +170,49 @@
(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)))))
@@ -227,10 +219,10 @@
(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)))
@@ -237,42 +229,42 @@
(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))
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -103,11 +103,11 @@
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 @@
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 @@
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 }};
--- a/femtolisp/test.lsp
+++ b/femtolisp/test.lsp
@@ -9,7 +9,7 @@
;(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 ()))
@@ -16,13 +16,13 @@
(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)))))))
--- 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
--- 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