conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
JeffBezanson 2009-02-01 01:53:58 +00:00
parent a55b46e9a6
commit 17d81eb4e6
15 changed files with 356 additions and 333 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
femtolisp/ast/asttools.lsp
View File

@ -10,23 +10,23 @@
(cons item lst))) (cons item lst)))
(define (index-of item lst start) (define (index-of item lst start)
(cond ((null lst) #f) (cond ((null? lst) #f)
((eq item (car lst)) start) ((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) (define (each f l)
(if (null l) l (if (null? l) l
(begin (f (car l)) (begin (f (car l))
(each f (cdr l))))) (each f (cdr l)))))
(define (maptree-pre f tr) (define (maptree-pre f tr)
(let ((new-t (f tr))) (let ((new-t (f tr)))
(if (consp new-t) (if (pair? new-t)
(map (lambda (e) (maptree-pre f e)) new-t) (map (lambda (e) (maptree-pre f e)) new-t)
new-t))) new-t)))
(define (maptree-post f tr) (define (maptree-post f tr)
(if (not (consp tr)) (if (not (pair? tr))
(f tr) (f tr)
(let ((new-t (map (lambda (e) (maptree-post f e)) tr))) (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
(f new-t)))) (f new-t))))
@ -70,10 +70,10 @@
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
(define (flatten-left-op op e) (define (flatten-left-op op e)
(maptree-post (lambda (node) (maptree-post (lambda (node)
(if (and (consp node) (if (and (pair? node)
(eq (car node) op) (eq (car node) op)
(consp (cdr node)) (pair? (cdr node))
(consp (cadr node)) (pair? (cadr node))
(eq (caadr node) op)) (eq (caadr node) op))
(cons op (cons op
(append (cdadr node) (cddr node))) (append (cdadr node) (cddr node)))
@ -85,31 +85,31 @@
; name is just there for reference ; name is just there for reference
; this assumes lambda is the only remaining naming form ; this assumes lambda is the only remaining naming form
(define (lookup-var v env lev) (define (lookup-var v env lev)
(if (null env) v (if (null? env) v
(let ((i (index-of v (car env) 0))) (let ((i (index-of v (car env) 0)))
(if i (list 'lexref lev i v) (if i (list 'lexref lev i v)
(lookup-var v (cdr env) (+ lev 1)))))) (lookup-var v (cdr env) (+ lev 1))))))
(define (lvc- e env) (define (lvc- e env)
(cond ((symbolp e) (lookup-var e env 0)) (cond ((symbol? e) (lookup-var e env 0))
((consp e) ((pair? e)
(if (eq (car e) 'quote) (if (eq (car e) 'quote)
e e
(let* ((newvs (and (eq (car e) 'lambda) (cadr e))) (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env))) (newenv (if newvs (cons newvs env) env)))
(if newvs (if newvs
(cons 'lambda (cons 'lambda
(cons (cadr e) (cons (cadr e)
(map (lambda (se) (lvc- se newenv)) (map (lambda (se) (lvc- se newenv))
(cddr e)))) (cddr e))))
(map (lambda (se) (lvc- se env)) e))))) (map (lambda (se) (lvc- se env)) e)))))
(T e))) (#t e)))
(define (lexical-var-conversion e) (define (lexical-var-conversion e)
(lvc- e ())) (lvc- e ()))
; convert let to lambda ; convert let to lambda
(define (let-expand e) (define (let-expand e)
(maptree-post (lambda (n) (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)) `((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n))) ,@(map cadr (cadr n)))
n)) n))

113
femtolisp/ast/match.lsp
View File

@ -3,11 +3,11 @@
; by Jeff Bezanson ; by Jeff Bezanson
(define (unique lst) (define (unique lst)
(if (null lst) (if (null? lst)
() ()
(cons (car lst) (cons (car lst)
(filter (lambda (x) (not (eq x (car lst)))) (filter (lambda (x) (not (eq x (car lst))))
(unique (cdr lst)))))) (unique (cdr lst))))))
; list of special pattern symbols that cannot be variable names ; list of special pattern symbols that cannot be variable names
(define metasymbols '(_ ...)) (define metasymbols '(_ ...))
@ -39,18 +39,18 @@
; This is NP-complete. Be careful. ; This is NP-complete. Be careful.
; ;
(define (match- p expr state) (define (match- p expr state)
(cond ((symbolp p) (cond ((symbol? p)
(cond ((eq p '_) state) (cond ((eq p '_) state)
(T (#t
(let ((capt (assq p state))) (let ((capt (assq p state)))
(if capt (if capt
(and (equal expr (cdr capt)) state) (and (equal expr (cdr capt)) state)
(cons (cons p expr) state)))))) (cons (cons p expr) state))))))
((function? p) ((procedure? p)
(and (p expr) state)) (and (p expr) state))
((consp p) ((pair? p)
(cond ((eq (car p) '-/) (and (equal (cadr p) expr) state)) (cond ((eq (car p) '-/) (and (equal (cadr p) expr) state))
((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
((eq (car p) '--) ((eq (car p) '--)
@ -58,43 +58,43 @@
(cons (cons (cadr p) expr) state))) (cons (cons (cadr p) expr) state)))
((eq (car p) '-$) ; greedy alternation for toplevel pattern ((eq (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1)) (match-alt (cdr p) () (list expr) state #f 1))
(T (#t
(and (consp expr) (and (pair? expr)
(equal (car p) (car expr)) (equal (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(T (#t
(and (equal p expr) state)))) (and (equal p expr) state))))
; match an alternation ; match an alternation
(define (match-alt alt prest expr state var L) (define (match-alt alt prest expr state var L)
(if (null alt) #f ; no alternatives left (if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state))) (let ((subma (match- (car alt) (car expr) state)))
(or (and subma (or (and subma
(match-seq prest (cdr expr) (match-seq prest (cdr expr)
(if var (if var
(cons (cons var (car expr)) (cons (cons var (car expr))
subma) subma)
subma) subma)
(- L 1))) (- L 1)))
(match-alt (cdr alt) prest expr state var L))))) (match-alt (cdr alt) prest expr state var L)))))
; match generalized kleene star (try consuming min to max) ; match generalized kleene star (try consuming min to max)
(define (match-star- p prest expr state var min max L sofar) (define (match-star- p prest expr state var min max L sofar)
(cond ; case 0: impossible to match (cond ; case 0: impossible to match
((> min max) #f) ((> 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 ((= max 0) (match-seq prest expr
(if var (cons (cons var (reverse sofar)) state) (if var (cons (cons var (reverse sofar)) state)
state) state)
L)) L))
; case 2: must match at least 1 ; case 2: must match at least 1
((> min 0) ((> min 0)
(and (match- p (car expr) state) (and (match- p (car expr) state)
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
(cons (car expr) sofar)))) (cons (car expr) sofar))))
; otherwise, must match either 0 or between 1 and max subexpressions ; otherwise, must match either 0 or between 1 and max subexpressions
(T (#t
(or (match-star- p prest expr state var 0 0 L sofar) (or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar))))) (match-star- p prest expr state var 1 max L sofar)))))
(define (match-star p prest expr state var min max L) (define (match-star p prest expr state var min max L)
@ -103,16 +103,16 @@
; match sequences of expressions ; match sequences of expressions
(define (match-seq p expr state L) (define (match-seq p expr state L)
(cond ((not state) #f) (cond ((not state) #f)
((null p) (if (null expr) state #f)) ((null? p) (if (null? expr) state #f))
(T (#t
(let ((subp (car p)) (let ((subp (car p))
(var #f)) (var #f))
(if (and (consp subp) (if (and (pair? subp)
(eq (car subp) '--)) (eq (car subp) '--))
(begin (set! var (cadr subp)) (begin (set! var (cadr subp))
(set! subp (caddr subp))) (set! subp (caddr subp)))
#f) #f)
(let ((head (if (consp subp) (car subp) ()))) (let ((head (if (pair? subp) (car subp) ())))
(cond ((eq subp '...) (cond ((eq subp '...)
(match-star '_ (cdr p) expr state var 0 L L)) (match-star '_ (cdr p) expr state var 0 L L))
((eq head '-*) ((eq head '-*)
@ -123,8 +123,8 @@
(match-star (cadr subp) (cdr p) expr state var 0 1 L)) (match-star (cadr subp) (cdr p) expr state var 0 1 L))
((eq head '-$) ((eq head '-$)
(match-alt (cdr subp) (cdr p) expr state var L)) (match-alt (cdr subp) (cdr p) expr state var L))
(T (#t
(and (consp expr) (and (pair? expr)
(match-seq (cdr p) (cdr expr) (match-seq (cdr p) (cdr expr)
(match- (car p) (car expr) state) (match- (car p) (car expr) state)
(- L 1)))))))))) (- L 1))))))))))
@ -133,32 +133,32 @@
; given a pattern p, return the list of capturing variables it uses ; given a pattern p, return the list of capturing variables it uses
(define (patargs- p) (define (patargs- p)
(cond ((and (symbolp p) (cond ((and (symbol? p)
(not (member p metasymbols))) (not (member p metasymbols)))
(list p)) (list p))
((consp p) ((pair? p)
(if (eq (car p) '-/) (if (eq (car p) '-/)
() ()
(unique (apply append (map patargs- (cdr p)))))) (unique (apply append (map patargs- (cdr p))))))
(T ()))) (#t ())))
(define (patargs p) (define (patargs p)
(cons '__ (patargs- p))) (cons '__ (patargs- p)))
; try to transform expr using a pattern-lambda from plist ; try to transform expr using a pattern-lambda from plist
; returns the new expression, or expr if no matches ; returns the new expression, or expr if no matches
(define (apply-patterns plist expr) (define (apply-patterns plist expr)
(if (null plist) expr (if (null? plist) expr
(if (function? plist) (if (procedure? plist)
(let ((enew (plist expr))) (let ((enew (plist expr)))
(if (not enew) (if (not enew)
expr expr
enew)) enew))
(let ((enew ((car plist) expr))) (let ((enew ((car plist) expr)))
(if (not enew) (if (not enew)
(apply-patterns (cdr plist) expr) (apply-patterns (cdr plist) expr)
enew))))) enew)))))
; top-down fixed-point macroexpansion. this is a typical algorithm, ; top-down fixed-point macroexpansion. this is a typical algorithm,
; but it may leave some structure that matches a pattern unexpanded. ; 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)) ; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
; TODO: ignore quoted expressions ; TODO: ignore quoted expressions
(define (pattern-expand plist expr) (define (pattern-expand plist expr)
(if (not (consp expr)) (if (not (pair? expr))
expr expr
(let ((enew (apply-patterns plist expr))) (let ((enew (apply-patterns plist expr)))
(if (eq enew expr) (if (eq enew expr)
; expr didn't change; move to subexpressions ; expr didn't change; move to subexpressions
(cons (car expr) (cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate ; expr changed; iterate
(pattern-expand plist enew)))))
(pattern-expand plist enew)))))

24
femtolisp/ast/rpasses.lsp
View File

@ -7,9 +7,9 @@
; tree inspection utils ; tree inspection utils
(define (assigned-var e) (define (assigned-var e)
(and (consp e) (and (pair? e)
(or (eq (car e) '<-) (eq (car e) 'ref=)) (or (eq (car e) '<-) (eq (car e) 'ref=))
(symbolp (cadr e)) (symbol? (cadr e))
(cadr e))) (cadr e)))
(define (func-argnames f) (define (func-argnames f)
@ -26,13 +26,13 @@
(define (dollarsign-transform e) (define (dollarsign-transform e)
(pattern-expand (pattern-expand
(pattern-lambda ($ lhs name) (pattern-lambda ($ lhs name)
(let* ((g (if (not (consp lhs)) lhs (r-gensym))) (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
(n (if (symbolp name) (n (if (symbol? name)
name ;(symbol->string name) name ;(symbol->string name)
name)) name))
(expr `(r-call (expr `(r-call
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
(if (not (consp lhs)) (if (not (pair? lhs))
expr expr
`(r-block (ref= ,g ,lhs) ,expr)))) `(r-block (ref= ,g ,lhs) ,expr))))
e)) e))
@ -46,9 +46,9 @@
(pattern-expand (pattern-expand
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs) (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
(<<- (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 __))) (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)) (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
,g))) ,g)))
e)) e))
@ -68,10 +68,10 @@
; convert r function expressions to lambda ; convert r function expressions to lambda
(define (normalize-r-functions e) (define (normalize-r-functions e)
(maptree-post (lambda (n) (maptree-post (lambda (n)
(if (and (consp n) (eq (car n) 'function)) (if (and (pair? n) (eq (car n) 'function))
`(lambda ,(func-argnames n) `(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n)) (r-block ,@(gen-default-inits (cadr n))
,@(if (and (consp (caddr n)) ,@(if (and (pair? (caddr n))
(eq (car (caddr n)) 'r-block)) (eq (car (caddr n)) 'r-block))
(cdr (caddr n)) (cdr (caddr n))
(list (caddr n))))) (list (caddr n)))))
@ -81,19 +81,19 @@
(define (find-assigned-vars n) (define (find-assigned-vars n)
(let ((vars ())) (let ((vars ()))
(maptree-pre (lambda (s) (maptree-pre (lambda (s)
(if (not (consp s)) s (if (not (pair? s)) s
(cond ((eq (car s) 'lambda) ()) (cond ((eq (car s) 'lambda) ())
((eq (car s) '<-) ((eq (car s) '<-)
(set! vars (list-adjoin (cadr s) vars)) (set! vars (list-adjoin (cadr s) vars))
(cddr s)) (cddr s))
(T s)))) (#t s))))
n) n)
vars)) vars))
; introduce let based on assignment statements ; introduce let based on assignment statements
(define (letbind-locals e) (define (letbind-locals e)
(maptree-post (lambda (n) (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)))) (let ((vars (find-assigned-vars (cddr n))))
`(lambda ,(cadr n) (let ,(map (lambda (v) (list v ())) `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
vars) vars)

0
femtolisp/dict.lsp → femtolisp/attic/dict.lsp
View File

30
femtolisp/color.lsp
View File

@ -1,23 +1,17 @@
; -*- scheme -*- ; -*- 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 ---------------------------------------------------------------- ; dictionaries ----------------------------------------------------------------
(define (dict-new) ()) (define (dict-new) ())
(define (dict-extend dl key value) (define (dict-extend dl key value)
(cond ((null dl) (list (cons key value))) (cond ((null? dl) (list (cons key value)))
((equal key (caar dl)) (cons (cons key value) (cdr dl))) ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
(T (cons (car dl) (dict-extend (cdr dl) key value))))) (else (cons (car dl) (dict-extend (cdr dl) key value)))))
(define (dict-lookup dl key) (define (dict-lookup dl key)
(cond ((null dl) ()) (cond ((null? dl) ())
((equal key (caar dl)) (cdar dl)) ((equal? key (caar dl)) (cdar dl))
(T (dict-lookup (cdr dl) key)))) (else (dict-lookup (cdr dl) key))))
(define (dict-keys dl) (map car dl)) (define (dict-keys dl) (map car dl))
@ -39,7 +33,7 @@
(define (graph-add-node g n1) (dict-extend g n1 ())) (define (graph-add-node g n1) (dict-extend g n1 ()))
(define (graph-from-edges edge-list) (define (graph-from-edges edge-list)
(if (null edge-list) (if (null? edge-list)
(graph-empty) (graph-empty)
(graph-connect (graph-from-edges (cdr edge-list)) (graph-connect (graph-from-edges (cdr edge-list))
(caar edge-list) (caar edge-list)
@ -52,17 +46,17 @@
(map (map
(lambda (n) (lambda (n)
(let ((color-pair (assq n coloring))) (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))))) (graph-neighbors g node-to-color)))))
(define (try-each f lst) (define (try-each f lst)
(if (null lst) #f (if (null? lst) #f
(let ((ret (f (car lst)))) (let ((ret (f (car lst))))
(if ret ret (try-each f (cdr lst)))))) (if ret ret (try-each f (cdr lst))))))
(define (color-node g coloring colors uncolored-nodes color) (define (color-node g coloring colors uncolored-nodes color)
(cond (cond
((null uncolored-nodes) coloring) ((null? uncolored-nodes) coloring)
((node-colorable? g coloring (car uncolored-nodes) color) ((node-colorable? g coloring (car uncolored-nodes) color)
(let ((new-coloring (let ((new-coloring
(cons (cons (car uncolored-nodes) color) coloring))) (cons (cons (car uncolored-nodes) color) coloring)))
@ -71,8 +65,8 @@
colors))))) colors)))))
(define (color-graph g colors) (define (color-graph g colors)
(if (null colors) (if (null? colors)
(and (null (graph-nodes g)) ()) (and (null? (graph-nodes g)) ())
(color-node g () colors (graph-nodes g) (car colors)))) (color-node g () colors (graph-nodes g) (car colors))))
(define (color-pairs pairs colors) (define (color-pairs pairs colors)

64
femtolisp/cps.lsp
View File

@ -2,7 +2,7 @@
(define (cond->if form) (define (cond->if form)
(cond-clauses->if (cdr form))) (cond-clauses->if (cdr form)))
(define (cond-clauses->if lst) (define (cond-clauses->if lst)
(if (atom lst) (if (atom? lst)
lst lst
(let ((clause (car lst))) (let ((clause (car lst)))
`(if ,(car clause) `(if ,(car clause)
@ -10,11 +10,11 @@
,(cond-clauses->if (cdr lst)))))) ,(cond-clauses->if (cdr lst))))))
(define (begin->cps forms k) (define (begin->cps forms k)
(cond ((atom forms) `(,k ,forms)) (cond ((atom? forms) `(,k ,forms))
((null (cdr forms)) (cps- (car forms) k)) ((null? (cdr forms)) (cps- (car forms) k))
(T (let ((_ (gensym))) ; var to bind ignored value (#t (let ((_ (gensym))) ; var to bind ignored value
(cps- (car forms) `(lambda (,_) (cps- (car forms) `(lambda (,_)
,(begin->cps (cdr forms) k))))))) ,(begin->cps (cdr forms) k)))))))
(define-macro (lambda/cc args body) (define-macro (lambda/cc args body)
`(rplaca (lambda ,args ,body) 'lambda/cc)) `(rplaca (lambda ,args ,body) 'lambda/cc))
@ -44,7 +44,7 @@
(define (rest->cps xformer form k argsyms) (define (rest->cps xformer form k argsyms)
(let ((el (car form))) (let ((el (car form)))
(if (or (atom el) (constant? el)) (if (or (atom? el) (constant? el))
(xformer (cdr form) k (cons el argsyms)) (xformer (cdr form) k (cons el argsyms))
(let ((g (gensym))) (let ((g (gensym)))
(cps- el `(lambda (,g) (cps- el `(lambda (,g)
@ -58,17 +58,17 @@
; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X))))) ; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
(define (app->cps form k argsyms) (define (app->cps form k argsyms)
(cond ((atom form) (cond ((atom? form)
(let ((r (reverse argsyms))) (let ((r (reverse argsyms)))
(make-funcall/cc (car r) k (cdr r)))) (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)))) ; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
(define (builtincall->cps form k) (define (builtincall->cps form k)
(prim->cps (cdr form) k (list (car form)))) (prim->cps (cdr form) k (list (car form))))
(define (prim->cps form k argsyms) (define (prim->cps form k argsyms)
(cond ((atom form) `(,k ,(reverse argsyms))) (cond ((atom? form) `(,k ,(reverse argsyms)))
(T (rest->cps prim->cps form k argsyms)))) (#t (rest->cps prim->cps form k argsyms))))
(define *top-k* (gensym)) (define *top-k* (gensym))
(set *top-k* identity) (set *top-k* identity)
@ -80,7 +80,7 @@
(cps- (macroexpand form) *top-k*))))) (cps- (macroexpand form) *top-k*)))))
(define (cps- form k) (define (cps- form k)
(let ((g (gensym))) (let ((g (gensym)))
(cond ((or (atom form) (constant? form)) (cond ((or (atom? form) (constant? form))
`(,k ,form)) `(,k ,form))
((eq (car form) 'lambda) ((eq (car form) 'lambda)
@ -96,7 +96,7 @@
(let ((test (cadr form)) (let ((test (cadr form))
(then (caddr form)) (then (caddr form))
(else (cadddr form))) (else (cadddr form)))
(if (atom k) (if (atom? k)
(cps- test `(lambda (,g) (cps- test `(lambda (,g)
(if ,g (if ,g
,(cps- then k) ,(cps- then k)
@ -105,9 +105,9 @@
,(cps- form g))))) ,(cps- form g)))))
((eq (car form) 'and) ((eq (car form) 'and)
(cond ((atom (cdr form)) `(,k T)) (cond ((atom? (cdr form)) `(,k #t))
((atom (cddr form)) (cps- (cadr form) k)) ((atom? (cddr form)) (cps- (cadr form) k))
(T (#t
(if (atom k) (if (atom k)
(cps- (cadr form) (cps- (cadr form)
`(lambda (,g) `(lambda (,g)
@ -117,10 +117,10 @@
,(cps- form g)))))) ,(cps- form g))))))
((eq (car form) 'or) ((eq (car form) 'or)
(cond ((atom (cdr form)) `(,k #f)) (cond ((atom? (cdr form)) `(,k #f))
((atom (cddr form)) (cps- (cadr form) k)) ((atom? (cddr form)) (cps- (cadr form) k))
(T (#t
(if (atom k) (if (atom? k)
(cps- (cadr form) (cps- (cadr form)
`(lambda (,g) `(lambda (,g)
(if ,g (,k ,g) (if ,g (,k ,g)
@ -168,23 +168,23 @@
(eq (caar form) 'lambda)) (eq (caar form) 'lambda))
(let ((largs (cadr (car form))) (let ((largs (cadr (car form)))
(lbody (caddr (car form)))) (lbody (caddr (car form))))
(cond ((null largs) ; ((lambda () body)) (cond ((null? largs) ; ((lambda () body))
(cps- lbody k)) (cps- lbody k))
((symbolp largs) ; ((lambda x body) args...) ((symbol? largs) ; ((lambda x body) args...)
(cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k)) (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
(T (#t
(cps- (cadr form) `(lambda (,(car largs)) (cps- (cadr form) `(lambda (,(car largs))
,(cps- `((lambda ,(cdr largs) ,lbody) ,(cps- `((lambda ,(cdr largs) ,lbody)
,@(cddr form)) ,@(cddr form))
k))))))) k)))))))
(T (#t
(app->cps form k ()))))) (app->cps form k ())))))
; (lambda (args...) (f args...)) => f ; (lambda (args...) (f args...)) => f
; but only for constant, builtin f ; but only for constant, builtin f
(define (η-reduce form) (define (η-reduce form)
(cond ((or (atom form) (constant? form)) form) (cond ((or (atom? form) (constant? form)) form)
((and (eq (car form) 'lambda) ((and (eq (car form) 'lambda)
(let ((body (caddr form)) (let ((body (caddr form))
(args (cadr form))) (args (cadr form)))
@ -192,16 +192,16 @@
(equal (cdr body) args) (equal (cdr body) args)
(constant? (car (caddr form)))))) (constant? (car (caddr form))))))
(car (caddr form))) (car (caddr form)))
(T (map η-reduce form)))) (#t (map η-reduce form))))
(define (contains x form) (define (contains x form)
(or (eq form x) (or (eq form x)
(any (lambda (p) (contains x p)) form))) (any (lambda (p) (contains x p)) form)))
(define (β-reduce form) (define (β-reduce form)
(if (or (atom form) (constant? form)) (if (or (atom? form) (constant? form))
form form
(β-reduce- (map β-reduce form)))) (β-reduce- (map β-reduce form))))
(define (β-reduce- form) (define (β-reduce- form)
; ((lambda (f) (f arg)) X) => (X arg) ; ((lambda (f) (f arg)) X) => (X arg)
@ -215,7 +215,7 @@
(= (length args) 1) (= (length args) 1)
(eq (car body) (car args)) (eq (car body) (car args))
(not (eq (cadr body) (car args))) (not (eq (cadr body) (car args)))
(symbolp (cadr body))))) (symbol? (cadr body)))))
`(,(cadr form) `(,(cadr form)
,(cadr (caddr (car form))))) ,(cadr (caddr (car form)))))
@ -230,7 +230,7 @@
((and (= (length form) 2) ((and (= (length form) 2)
(pair? (car form)) (pair? (car form))
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(or (atom (cadr form)) (constant? (cadr form))) (or (atom? (cadr form)) (constant? (cadr form)))
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(s (cadr form)) (s (cadr form))
(body (caddr (car form)))) (body (caddr (car form))))
@ -247,7 +247,7 @@
,s ,s
,@params))))))) ,@params)))))))
(T form))) (#t form)))
(define-macro (with-delimited-continuations . code) (define-macro (with-delimited-continuations . code)
(cps (f-body code))) (cps (f-body code)))
@ -287,7 +287,7 @@
(cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ()))))))))) (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
'(a 1 b b c))) '(a 1 b b c)))
T #t
#| #|
todo: todo:

2
femtolisp/cvalues.c
View File

@ -791,7 +791,7 @@ static value_t cvalue_array_aset(value_t *args)
{ {
char *data; ulong_t index; char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype; 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; char *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest); cvalue_init(eltype, args[2], dest);
return args[2]; return args[2];

10
femtolisp/flisp.c
View File

@ -60,7 +60,7 @@ static char *builtin_names[] =
"cons", "list", "car", "cdr", "set-car!", "set-cdr!", "cons", "list", "car", "cdr", "set-car!", "set-cdr!",
"eval", "eval*", "apply", "prog1", "raise", "eval", "eval*", "apply", "prog1", "raise",
"+", "-", "*", "/", "<", "~", "&", "!", "$", "+", "-", "*", "/", "<", "~", "&", "!", "$",
"vector", "aref", "aset", "length", "assq", "compare", "for", "vector", "aref", "aset!", "length", "assq", "compare", "for",
"", "", "" }; "", "", "" };
#define N_STACK 98304 #define N_STACK 98304
@ -1004,19 +1004,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
break; break;
case F_ASET: case F_ASET:
argcount("aset", nargs, 3); argcount("aset!", nargs, 3);
e = Stack[SP-3]; e = Stack[SP-3];
if (isvector(e)) { if (isvector(e)) {
i = tofixnum(Stack[SP-2], "aset"); i = tofixnum(Stack[SP-2], "aset!");
if (__unlikely((unsigned)i >= vector_size(e))) 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]); vector_elt(e, i) = (v=Stack[SP-1]);
} }
else if (isarray(e)) { else if (isarray(e)) {
v = cvalue_array_aset(&Stack[SP-3]); v = cvalue_array_aset(&Stack[SP-3]);
} }
else { else {
type_error("aset", "sequence", e); type_error("aset!", "sequence", e);
} }
break; break;
case F_ATOM: case F_ATOM:

14
femtolisp/print.c
View File

@ -520,14 +520,22 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
else else
HPOS+=ios_printf(f, "%s", rep); 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 { else {
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10); snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
if (weak || princ || strpbrk(buf, ".eE")) { int hasdec = (strpbrk(buf, ".eE") != NULL);
outs(buf, f); outs(buf, f);
if (weak || princ || hasdec) {
if (type == floatsym) outc('f', f); if (type == floatsym) outc('f', f);
} }
else { else {
HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), buf); if (!hasdec) outs(".0", f);
if (type==floatsym) outc('f', f);
} }
} }
} }

92
femtolisp/read.c
View File

@ -16,7 +16,16 @@ static int symchar(char c)
return (!isspace(c) && !strchr(special, 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; char *end;
int64_t i64; int64_t i64;
@ -24,50 +33,63 @@ static int isnumtok(char *tok, value_t *pval)
double d; double d;
if (*tok == '\0') if (*tok == '\0')
return 0; return 0;
if (!(tok[0]=='0' && isdigit(tok[1])) && if (strpbrk(tok, ".eEpP")) {
strpbrk(tok, ".eEpP")) {
d = strtod(tok, &end); d = strtod(tok, &end);
if (*end == '\0') { if (*end == '\0') {
if (pval) *pval = mk_double(d); if (pval) *pval = mk_double(d);
return 1; 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); if (pval) *pval = mk_float((float)d);
return 1; return 1;
} }
} }
if (tok[0] == '+') { if (tok[0] == '+') {
if (!strcmp(tok,"+NaN")) { if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {
if (pval) *pval = mk_double(D_PNAN); if (pval) *pval = mk_double(D_PNAN);
return 1; return 1;
} }
if (!strcmp(tok,"+Inf")) { if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {
if (pval) *pval = mk_double(D_PINF); if (pval) *pval = mk_double(D_PINF);
return 1; return 1;
} }
} }
else if (tok[0] == '-') { else if (tok[0] == '-') {
if (!strcmp(tok,"-NaN")) { if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {
if (pval) *pval = mk_double(D_NNAN); if (pval) *pval = mk_double(D_NNAN);
return 1; return 1;
} }
if (!strcmp(tok,"-Inf")) { if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {
if (pval) *pval = mk_double(D_NINF); if (pval) *pval = mk_double(D_NINF);
return 1; return 1;
} }
i64 = strtoll(tok, &end, 0); i64 = strtoll(tok, &end, base);
if (pval) *pval = return_from_int64(i64); if (pval) *pval = return_from_int64(i64);
return (*end == '\0'); return (*end == '\0');
} }
else if (!isdigit(tok[0])) { ui64 = strtoull(tok, &end, base);
return 0;
}
ui64 = strtoull(tok, &end, 0);
if (pval) *pval = return_from_uint64(ui64); if (pval) *pval = return_from_uint64(ui64);
return (*end == '\0'); 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 u_int32_t toktype = TOK_NONE;
static value_t tokval; static value_t tokval;
static char buf[256]; static char buf[256];
@ -148,7 +170,7 @@ static u_int32_t peek(ios_t *f)
{ {
char c, *end; char c, *end;
fixnum_t x; fixnum_t x;
int ch; int ch, base;
if (toktype != TOK_NONE) if (toktype != TOK_NONE)
return toktype; return toktype;
@ -176,30 +198,30 @@ static u_int32_t peek(ios_t *f)
toktype = TOK_DOUBLEQUOTE; toktype = TOK_DOUBLEQUOTE;
} }
else if (c == '#') { else if (c == '#') {
ch = ios_getc(f); ch = ios_getc(f); c = (char)ch;
if (ch == IOS_EOF) if (ch == IOS_EOF)
lerror(ParseError, "read: invalid read macro"); lerror(ParseError, "read: invalid read macro");
if ((char)ch == '.') { if (c == '.') {
toktype = TOK_SHARPDOT; toktype = TOK_SHARPDOT;
} }
else if ((char)ch == '\'') { else if (c == '\'') {
toktype = TOK_SHARPQUOTE; toktype = TOK_SHARPQUOTE;
} }
else if ((char)ch == '\\') { else if (c == '\\') {
uint32_t cval; uint32_t cval;
if (ios_getutf8(f, &cval) == IOS_EOF) if (ios_getutf8(f, &cval) == IOS_EOF)
lerror(ParseError, "read: end of input in character constant"); lerror(ParseError, "read: end of input in character constant");
toktype = TOK_NUM; toktype = TOK_NUM;
tokval = mk_wchar(cval); tokval = mk_wchar(cval);
} }
else if ((char)ch == '(') { else if (c == '(') {
toktype = TOK_SHARPOPEN; toktype = TOK_SHARPOPEN;
} }
else if ((char)ch == '<') { else if (c == '<') {
lerror(ParseError, "read: unreadable object"); lerror(ParseError, "read: unreadable object");
} }
else if (isdigit((char)ch)) { else if (isdigit(c)) {
read_token(f, (char)ch, 1); read_token(f, c, 1);
c = (char)ios_getc(f); c = (char)ios_getc(f);
if (c == '#') if (c == '#')
toktype = TOK_BACKREF; toktype = TOK_BACKREF;
@ -213,14 +235,14 @@ static u_int32_t peek(ios_t *f)
lerror(ParseError, "read: invalid label"); lerror(ParseError, "read: invalid label");
tokval = fixnum(x); tokval = fixnum(x);
} }
else if ((char)ch == '!') { else if (c == '!') {
// #! single line comment for shbang script support // #! single line comment for shbang script support
do { do {
ch = ios_getc(f); ch = ios_getc(f);
} while (ch != IOS_EOF && (char)ch != '\n'); } while (ch != IOS_EOF && (char)ch != '\n');
return peek(f); return peek(f);
} }
else if ((char)ch == '|') { else if (c == '|') {
// multiline comment // multiline comment
int commentlevel=1; int commentlevel=1;
while (1) { while (1) {
@ -250,10 +272,10 @@ static u_int32_t peek(ios_t *f)
// this was whitespace, so keep peeking // this was whitespace, so keep peeking
return peek(f); return peek(f);
} }
else if ((char)ch == ';') { else if (c == ';') {
toktype = TOK_SHARPSEMI; toktype = TOK_SHARPSEMI;
} }
else if ((char)ch == ':') { else if (c == ':') {
// gensym // gensym
ch = ios_getc(f); ch = ios_getc(f);
if ((char)ch == 'g') if ((char)ch == 'g')
@ -266,8 +288,18 @@ static u_int32_t peek(ios_t *f)
toktype = TOK_GENSYM; toktype = TOK_GENSYM;
tokval = fixnum(x); tokval = fixnum(x);
} }
else if (symchar((char)ch)) { else if (symchar(c)) {
read_token(f, ch, 0); 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; toktype = TOK_SHARPSYM;
tokval = symbol(buf); tokval = symbol(buf);
} }
@ -293,12 +325,8 @@ static u_int32_t peek(ios_t *f)
return (toktype=TOK_DOT); return (toktype=TOK_DOT);
} }
else { else {
errno = 0; if (read_numtok(buf, &tokval, 0))
if (isnumtok(buf, &tokval)) {
if (errno)
lerror(ParseError,"read: overflow in numeric constant");
return (toktype=TOK_NUM); return (toktype=TOK_NUM);
}
} }
} }
toktype = TOK_SYM; toktype = TOK_SYM;

230
femtolisp/system.lsp
View File

@ -6,28 +6,17 @@
(set-constant! 'eq eq?) (set-constant! 'eq eq?)
(set-constant! 'eqv eqv?) (set-constant! 'eqv eqv?)
(set-constant! 'equal equal?) (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! 'rplaca set-car!)
(set-constant! 'rplacd set-cdr!) (set-constant! 'rplacd set-cdr!)
(set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar))) (set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar)))
(set-constant! 'T #t)
; convert a sequence of body statements to a single expression. ; convert a sequence of body statements to a single expression.
; this allows define, defun, defmacro, let, etc. to contain multiple ; this allows define, defun, defmacro, let, etc. to contain multiple
; body expressions as in Common Lisp. ; body expressions as in Common Lisp.
(set! f-body (lambda (e) (set! f-body (lambda (e)
(cond ((atom e) e) (cond ((atom? e) e)
((eq (cdr e) ()) (car e)) ((eq (cdr e) ()) (car e))
(T (cons 'begin e))))) (#t (cons 'begin e)))))
(set-syntax! 'define-macro (set-syntax! 'define-macro
(lambda (form . body) (lambda (form . body)
@ -38,7 +27,7 @@
(list (list 'lambda (list name) (list 'set! name fn)) #f)) (list (list 'lambda (list name) (list 'set! name fn)) #f))
(define-macro (define form . body) (define-macro (define form . body)
(if (symbolp form) (if (symbol? form)
(list 'set! form (car body)) (list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body body))))) (list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
@ -47,73 +36,73 @@
(define (identity x) x) (define (identity x) x)
(define (map f lst) (define (map f lst)
(if (atom lst) lst (if (atom? lst) lst
(cons (f (car lst)) (map f (cdr lst))))) (cons (f (car lst)) (map f (cdr lst)))))
(define-macro (let binds . body) (define-macro (let binds . body)
(cons (list 'lambda (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)) (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) (define (nconc . lsts)
(cond ((null lsts) ()) (cond ((null? lsts) ())
((null (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
((null (car lsts)) (apply nconc (cdr lsts))) ((null? (car lsts)) (apply nconc (cdr lsts)))
(T (prog1 (car lsts) (#t (prog1 (car lsts)
(rplacd (last (car lsts)) (rplacd (last (car lsts))
(apply nconc (cdr lsts))))))) (apply nconc (cdr lsts)))))))
(define (append . lsts) (define (append . lsts)
(cond ((null lsts) ()) (cond ((null? lsts) ())
((null (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(T ((label append2 (lambda (l d) (#t ((label append2 (lambda (l d)
(if (null l) d (if (null? l) d
(cons (car l) (cons (car l)
(append2 (cdr l) d))))) (append2 (cdr l) d)))))
(car lsts) (apply append (cdr lsts)))))) (car lsts) (apply append (cdr lsts))))))
(define (member item lst) (define (member item lst)
(cond ((atom lst) #f) (cond ((atom? lst) #f)
((equal (car lst) item) lst) ((equal (car lst) item) lst)
(T (member item (cdr lst))))) (#t (member item (cdr lst)))))
(define (memq item lst) (define (memq item lst)
(cond ((atom lst) #f) (cond ((atom? lst) #f)
((eq (car lst) item) lst) ((eq (car lst) item) lst)
(T (memq item (cdr lst))))) (#t (memq item (cdr lst)))))
(define (memv item lst) (define (memv item lst)
(cond ((atom lst) #f) (cond ((atom? lst) #f)
((eqv (car lst) item) lst) ((eqv (car lst) item) lst)
(T (memv item (cdr lst))))) (#t (memv item (cdr lst)))))
(define (assoc item lst) (define (assoc item lst)
(cond ((atom lst) #f) (cond ((atom? lst) #f)
((equal (caar lst) item) (car lst)) ((equal (caar lst) item) (car lst))
(T (assoc item (cdr lst))))) (#t (assoc item (cdr lst)))))
(define (assv item lst) (define (assv item lst)
(cond ((atom lst) #f) (cond ((atom? lst) #f)
((eqv (caar lst) item) (car lst)) ((eqv (caar lst) item) (car lst))
(T (assv item (cdr lst))))) (#t (assv item (cdr lst)))))
(define (macrocall? e) (and (symbolp (car e)) (define (macrocall? e) (and (symbol? (car e))
(symbol-syntax (car e)))) (symbol-syntax (car e))))
(define (function? x) (define (function? x)
(or (builtinp x) (or (builtin? x)
(and (consp x) (eq (car x) 'lambda)))) (and (pair? x) (eq (car x) 'lambda))))
(define procedure? function?) (define procedure? function?)
(define (macroexpand-1 e) (define (macroexpand-1 e)
(if (atom e) e (if (atom? e) e
(let ((f (macrocall? e))) (let ((f (macrocall? e)))
(if f (apply f (cdr e)) (if f (apply f (cdr e))
e)))) e))))
; convert to proper list, i.e. remove "dots", and append ; convert to proper list, i.e. remove "dots", and append
(define (append.2 l tail) (define (append.2 l tail)
(cond ((null l) tail) (cond ((null? l) tail)
((atom l) (cons l tail)) ((atom? l) (cons l tail))
(T (cons (car l) (append.2 (cdr l) tail))))) (#t (cons (car l) (append.2 (cdr l) tail)))))
(define (cadr x) (car (cdr x))) (define (cadr x) (car (cdr x)))
@ -124,27 +113,27 @@
((label mexpand ((label mexpand
(lambda (e env f) (lambda (e env f)
(begin (begin
(while (and (consp e) (while (and (pair? e)
(not (member (car e) env)) (not (member (car e) env))
(set! f (macrocall? e))) (set! f (macrocall? e)))
(set! e (apply f (cdr e)))) (set! e (apply f (cdr e))))
(cond ((and (consp e) (cond ((and (pair? e)
(not (eq (car e) 'quote))) (not (eq (car e) 'quote)))
(let ((newenv (let ((newenv
(if (and (eq (car e) 'lambda) (if (and (eq (car e) 'lambda)
(consp (cdr e))) (pair? (cdr e)))
(append.2 (cadr e) env) (append.2 (cadr e) env)
env))) env)))
(map (lambda (x) (mexpand x newenv ())) e))) (map (lambda (x) (mexpand x newenv ())) e)))
;((and (symbolp e) (constant? e)) (eval e)) ;((and (symbol? e) (constant? e)) (eval e))
;((and (symbolp e) ;((and (symbol? e)
; (not (member e *special-forms*)) ; (not (member e *special-forms*))
; (not (member e env))) (cons '%top e)) ; (not (member e env))) (cons '%top e))
(T e))))) (#t e)))))
e () ())) e () ()))
(define-macro (define form . body) (define-macro (define form . body)
(if (symbolp form) (if (symbol? form)
(list 'set! form (car body)) (list 'set! form (car body))
(list 'set! (car form) (list 'set! (car form)
(macroexpand (list 'lambda (cdr form) (f-body body)))))) (macroexpand (list 'lambda (cdr form) (f-body body))))))
@ -163,6 +152,7 @@
(define (1+ n) (+ n 1)) (define (1+ n) (+ n 1))
(define (1- n) (- n 1)) (define (1- n) (- n 1))
(define (mod x y) (- x (* (/ x y) y))) (define (mod x y) (- x (* (/ x y) y)))
(define remainder mod)
(define (abs x) (if (< x 0) (- x) x)) (define (abs x) (if (< x 0) (- x) x))
(define K prog1) ; K combinator ;) (define K prog1) ; K combinator ;)
@ -180,99 +170,101 @@
(define (cdddr x) (cdr (cdr (cdr x)))) (define (cdddr x) (cdr (cdr (cdr x))))
(define (every pred lst) (define (every pred lst)
(or (atom lst) (or (atom? lst)
(and (pred (car lst)) (and (pred (car lst))
(every pred (cdr lst))))) (every pred (cdr lst)))))
(define (any pred lst) (define (any pred lst)
(and (consp lst) (and (pair? lst)
(or (pred (car lst)) (or (pred (car lst))
(any pred (cdr lst))))) (any pred (cdr lst)))))
(define (listp a) (or (null a) (consp a))) (define (listp a) (or (null? a) (pair? a)))
(define (list? a) (or (null a) (and (pair? a) (list? (cdr a))))) (define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
(define (nthcdr lst n) (define (nthcdr lst n)
(if (<= n 0) lst (if (<= n 0) lst
(nthcdr (cdr lst) (- n 1)))) (nthcdr (cdr lst) (- n 1))))
(define list-tail nthcdr)
(define (list-ref lst n) (define (list-ref lst n)
(car (nthcdr lst n))) (car (nthcdr lst n)))
(define (list* . l) (define (list* . l)
(if (atom (cdr l)) (if (atom? (cdr l))
(car l) (car l)
(cons (car l) (apply list* (cdr l))))) (cons (car l) (apply list* (cdr l)))))
(define (nlist* . l) (define (nlist* . l)
(if (atom (cdr l)) (if (atom? (cdr l))
(car l) (car l)
(rplacd l (apply nlist* (cdr l))))) (rplacd l (apply nlist* (cdr l)))))
(define (lastcdr l) (define (lastcdr l)
(if (atom l) l (if (atom? l) l
(lastcdr (cdr l)))) (lastcdr (cdr l))))
(define (last l) (define (last l)
(cond ((atom l) l) (cond ((atom? l) l)
((atom (cdr l)) l) ((atom? (cdr l)) l)
(T (last (cdr l))))) (#t (last (cdr l)))))
(define last-pair last)
(define (map! f lst) (define (map! f lst)
(prog1 lst (prog1 lst
(while (consp lst) (while (pair? lst)
(rplaca lst (f (car lst))) (rplaca lst (f (car lst)))
(set! lst (cdr lst))))) (set! lst (cdr lst)))))
(define (mapcar f . lsts) (define (mapcar f . lsts)
((label mapcar- ((label mapcar-
(lambda (lsts) (lambda (lsts)
(cond ((null lsts) (f)) (cond ((null? lsts) (f))
((atom (car lsts)) (car lsts)) ((atom? (car lsts)) (car lsts))
(T (cons (apply f (map car lsts)) (#t (cons (apply f (map car lsts))
(mapcar- (map cdr lsts))))))) (mapcar- (map cdr lsts)))))))
lsts)) lsts))
(define (transpose M) (apply mapcar (cons list M))) (define (transpose M) (apply mapcar (cons list M)))
(define (filter pred lst) (filter- pred lst ())) (define (filter pred lst) (filter- pred lst ()))
(define (filter- pred lst accum) (define (filter- pred lst accum)
(cond ((null lst) accum) (cond ((null? lst) accum)
((pred (car lst)) ((pred (car lst))
(filter- pred (cdr lst) (cons (car lst) accum))) (filter- pred (cdr lst) (cons (car lst) accum)))
(T (#t
(filter- pred (cdr lst) accum)))) (filter- pred (cdr lst) accum))))
(define (separate pred lst) (separate- pred lst () ())) (define (separate pred lst) (separate- pred lst () ()))
(define (separate- pred lst yes no) (define (separate- pred lst yes no)
(cond ((null lst) (cons yes no)) (cond ((null? lst) (cons yes no))
((pred (car lst)) ((pred (car lst))
(separate- pred (cdr lst) (cons (car lst) yes) no)) (separate- pred (cdr lst) (cons (car lst) yes) no))
(T (#t
(separate- pred (cdr lst) yes (cons (car lst) no))))) (separate- pred (cdr lst) yes (cons (car lst) no)))))
(define (foldr f zero lst) (define (foldr f zero lst)
(if (null lst) zero (if (null? lst) zero
(f (car lst) (foldr f zero (cdr lst))))) (f (car lst) (foldr f zero (cdr lst)))))
(define (foldl f zero lst) (define (foldl f zero lst)
(if (null lst) zero (if (null? lst) zero
(foldl f (f (car lst) zero) (cdr lst)))) (foldl f (f (car lst) zero) (cdr lst))))
(define (reverse lst) (foldl cons () lst)) (define (reverse lst) (foldl cons () lst))
(define (copy-list l) (define (copy-list l)
(if (atom l) l (if (atom? l) l
(cons (car l) (cons (car l)
(copy-list (cdr l))))) (copy-list (cdr l)))))
(define (copy-tree l) (define (copy-tree l)
(if (atom l) l (if (atom? l) l
(cons (copy-tree (car l)) (cons (copy-tree (car l))
(copy-tree (cdr l))))) (copy-tree (cdr l)))))
(define (nreverse l) (define (nreverse l)
(let ((prev ())) (let ((prev ()))
(while (consp l) (while (pair? l)
(set! l (prog1 (cdr l) (set! l (prog1 (cdr l)
(rplacd l (prog1 prev (rplacd l (prog1 prev
(set! prev l)))))) (set! prev l))))))
@ -324,7 +316,7 @@
(define-macro (catch tag expr) (define-macro (catch tag expr)
(let ((e (gensym))) (let ((e (gensym)))
`(trycatch ,expr `(trycatch ,expr
(lambda (,e) (if (and (consp ,e) (lambda (,e) (if (and (pair? ,e)
(eq (car ,e) 'thrown-value) (eq (car ,e) 'thrown-value)
(eq (cadr ,e) ,tag)) (eq (cadr ,e) ,tag))
(caddr ,e) (caddr ,e)
@ -354,15 +346,15 @@
extype)) extype))
(todo (cddr catc))) (todo (cddr catc)))
`(,(if specific `(,(if specific
; exception matching logic ; exception matching logic
`(or (eq ,e ',extype) `(or (eq ,e ',extype)
(and (consp ,e) (and (pair? ,e)
(eq (car ,e) (eq (car ,e)
',extype))) ',extype)))
T); (catch (e) ...), match anything #t); (catch (e) ...), match anything
(let ((,var ,e)) (begin ,@todo))))) (let ((,var ,e)) (begin ,@todo)))))
catches) catches)
(T (raise ,e))))) ; no matches, reraise (#t (raise ,e))))) ; no matches, reraise
(if final (if final
(if catches (if catches
; form with both catch and finally ; form with both catch and finally
@ -400,15 +392,15 @@
(cddar rplacd cdar) (cddar rplacd cdar)
(cdddr rplacd cddr) (cdddr rplacd cddr)
(list-ref rplaca nthcdr) (list-ref rplaca nthcdr)
(get put identity) (get put! identity)
(aref aset identity) (aref aset! identity)
(symbol-syntax set-syntax! identity))) (symbol-syntax set-syntax! identity)))
(define (setf-place-mutator place val) (define (setf-place-mutator place val)
(if (symbolp place) (if (symbol? place)
(list 'set! place val) (list 'set! place val)
(let ((mutator (assq (car place) *setf-place-list*))) (let ((mutator (assq (car place) *setf-place-list*)))
(if (null mutator) (if (null? mutator)
(error "setf: unknown place " (car place)) (error "setf: unknown place " (car place))
(if (eq (caddr mutator) 'identity) (if (eq (caddr mutator) 'identity)
(cons (cadr mutator) (append (cdr place) (list val))) (cons (cadr mutator) (append (cdr place) (list val)))
@ -420,7 +412,7 @@
(f-body (f-body
((label setf- ((label setf-
(lambda (args) (lambda (args)
(if (null args) (if (null? args)
() ()
(cons (setf-place-mutator (car args) (cadr args)) (cons (setf-place-mutator (car args) (cadr args))
(setf- (cddr args)))))) (setf- (cddr args))))))
@ -439,8 +431,8 @@
l)) l))
(define (self-evaluating? x) (define (self-evaluating? x)
(or (and (atom x) (or (and (atom? x)
(not (symbolp x))) (not (symbol? x)))
(and (constant? x) (and (constant? x)
(eq x (eval x))))) (eq x (eval x)))))
@ -448,54 +440,54 @@
(define-macro (backquote x) (bq-process x)) (define-macro (backquote x) (bq-process x))
(define (splice-form? 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 (car x) '*comma-dot*)))
(eq x '*comma*))) (eq x '*comma*)))
(define (bq-process x) (define (bq-process x)
(cond ((self-evaluating? x) (cond ((self-evaluating? x)
(if (vectorp x) (if (vector? x)
(let ((body (bq-process (vector-to-list x)))) (let ((body (bq-process (vector-to-list x))))
(if (eq (car body) 'list) (if (eq (car body) 'list)
(cons vector (cdr body)) (cons vector (cdr body))
(list apply vector body))) (list apply vector body)))
x)) x))
((atom x) (list 'quote x)) ((atom? x) (list 'quote x))
((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
((eq (car x) '*comma*) (cadr x)) ((eq (car x) '*comma*) (cadr x))
((not (any splice-form? x)) ((not (any splice-form? x))
(let ((lc (lastcdr x)) (let ((lc (lastcdr x))
(forms (map bq-bracket1 x))) (forms (map bq-bracket1 x)))
(if (null lc) (if (null? lc)
(cons 'list forms) (cons 'list forms)
(nconc (cons 'nlist* forms) (list (bq-process lc)))))) (nconc (cons 'nlist* forms) (list (bq-process lc))))))
(T (let ((p x) (q ())) (#t (let ((p x) (q ()))
(while (and (consp p) (while (and (pair? p)
(not (eq (car p) '*comma*))) (not (eq (car p) '*comma*)))
(set! q (cons (bq-bracket (car p)) q)) (set! q (cons (bq-bracket (car p)) q))
(set! p (cdr p))) (set! p (cdr p)))
(let ((forms (let ((forms
(cond ((consp p) (nreconc q (list (cadr p)))) (cond ((pair? p) (nreconc q (list (cadr p))))
((null p) (nreverse q)) ((null? p) (nreverse q))
(T (nreconc q (list (bq-process p))))))) (#t (nreconc q (list (bq-process p)))))))
(if (null (cdr forms)) (if (null? (cdr forms))
(car forms) (car forms)
(cons 'nconc forms))))))) (cons 'nconc forms)))))))
(define (bq-bracket x) (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*) (list list (cadr x)))
((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
((eq (car x) '*comma-dot*) (cadr x)) ((eq (car x) '*comma-dot*) (cadr x))
(T (list list (bq-process x))))) (#t (list list (bq-process x)))))
; bracket without splicing ; bracket without splicing
(define (bq-bracket1 x) (define (bq-bracket1 x)
(if (and (consp x) (eq (car x) '*comma*)) (if (and (pair? x) (eq (car x) '*comma*))
(cadr x) (cadr x)
(bq-process 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) (define-macro (time expr)
(let ((t0 (gensym))) (let ((t0 (gensym)))
@ -504,14 +496,16 @@
,expr ,expr
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) (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) (define (vector.map f v)
(let* ((n (length v)) (let* ((n (length v))
(nv (vector.alloc n))) (nv (vector.alloc n)))
(for 0 (- n 1) (for 0 (- n 1)
(lambda (i) (lambda (i)
(aset nv i (f (aref v i))))) (aset! nv i (f (aref v i)))))
nv)) nv))
(define (table.pairs t) (define (table.pairs t)
@ -525,6 +519,6 @@
() t)) () t))
(define (table.clone t) (define (table.clone t)
(let ((nt (table))) (let ((nt (table)))
(table.foldl (lambda (k v z) (put nt k v)) (table.foldl (lambda (k v z) (put! nt k v))
() t) () t)
nt)) nt))

18
femtolisp/table.c
View File

@ -103,11 +103,11 @@ value_t fl_table(value_t *args, uint32_t nargs)
return nt; return nt;
} }
// (put table key value) // (put! table key value)
value_t fl_table_put(value_t *args, uint32_t nargs) value_t fl_table_put(value_t *args, uint32_t nargs)
{ {
argcount("put", nargs, 3); argcount("put!", nargs, 3);
htable_t *h = totable(args[0], "put"); htable_t *h = totable(args[0], "put!");
void **table0 = h->table; void **table0 = h->table;
equalhash_put(h, (void*)args[1], (void*)args[2]); equalhash_put(h, (void*)args[1], (void*)args[2]);
// register finalizer if we outgrew inline space // 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; 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) value_t fl_table_del(value_t *args, uint32_t nargs)
{ {
argcount("del", nargs, 2); argcount("del!", nargs, 2);
htable_t *h = totable(args[0], "del"); htable_t *h = totable(args[0], "del!");
if (!equalhash_remove(h, (void*)args[1])) if (!equalhash_remove(h, (void*)args[1]))
lerror(KeyError, "del: key not found"); lerror(KeyError, "del!: key not found");
return args[0]; return args[0];
} }
@ -178,10 +178,10 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
static builtinspec_t tablefunc_info[] = { static builtinspec_t tablefunc_info[] = {
{ "table", fl_table }, { "table", fl_table },
{ "table?", fl_tablep }, { "table?", fl_tablep },
{ "put", fl_table_put }, { "put!", fl_table_put },
{ "get", fl_table_get }, { "get", fl_table_get },
{ "has", fl_table_has }, { "has", fl_table_has },
{ "del", fl_table_del }, { "del!", fl_table_del },
{ "table.foldl", fl_table_foldl }, { "table.foldl", fl_table_foldl },
{ NULL, NULL } { NULL, NULL }
}; };

40
femtolisp/test.lsp
View File

@ -9,20 +9,20 @@
;(define (reverse lst) ;(define (reverse lst)
; ((label rev-help (lambda (lst result) ; ((label rev-help (lambda (lst result)
; (if (null lst) result ; (if (null? lst) result
; (rev-help (cdr lst) (cons (car lst) result))))) ; (rev-help (cdr lst) (cons (car lst) result)))))
; lst ())) ; lst ()))
(define (append- . lsts) (define (append- . lsts)
((label append-h ((label append-h
(lambda (lsts) (lambda (lsts)
(cond ((null lsts) ()) (cond ((null? lsts) ())
((null (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(T ((label append2 (lambda (l d) (#t ((label append2 (lambda (l d)
(if (null l) d (if (null? l) d
(cons (car l) (cons (car l)
(append2 (cdr l) d))))) (append2 (cdr l) d)))))
(car lsts) (append-h (cdr lsts))))))) (car lsts) (append-h (cdr lsts)))))))
lsts)) lsts))
;(princ 'Hello '| | 'world! "\n") ;(princ 'Hello '| | 'world! "\n")
@ -38,13 +38,13 @@
; iterative filter ; iterative filter
(define (ifilter pred lst) (define (ifilter pred lst)
((label f (lambda (accum lst) ((label f (lambda (accum lst)
(cond ((null lst) (nreverse accum)) (cond ((null? lst) (nreverse accum))
((not (pred (car lst))) (f accum (cdr lst))) ((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)) () lst))
(define (sort l) (define (sort l)
(if (or (null l) (null (cdr l))) l (if (or (null? l) (null? (cdr l))) l
(let* ((piv (car l)) (let* ((piv (car l))
(halves (separate (lambda (x) (< x piv)) (cdr l)))) (halves (separate (lambda (x) (< x piv)) (cdr l))))
(nconc (sort (car halves)) (nconc (sort (car halves))
@ -81,13 +81,13 @@
(cond ((= p 0) 1) (cond ((= p 0) 1)
((= b 0) 0) ((= b 0) 0)
((evenp p) (square (expt b (/ p 2)))) ((evenp p) (square (expt b (/ p 2))))
(T (* b (expt b (- p 1)))))) (#t (* b (expt b (- p 1))))))
(define (gcd a b) (define (gcd a b)
(cond ((= a 0) b) (cond ((= a 0) b)
((= b 0) a) ((= b 0) a)
((< a b) (gcd a (- b a))) ((< a b) (gcd a (- b a)))
(T (gcd b (- a b))))) (#t (gcd b (- a b)))))
; like eval-when-compile ; like eval-when-compile
(define-macro (literal expr) (define-macro (literal expr)
@ -95,7 +95,7 @@
(if (self-evaluating? v) v (list quote v)))) (if (self-evaluating? v) v (list quote v))))
(define (cardepth l) (define (cardepth l)
(if (atom l) 0 (if (atom? l) 0
(+ 1 (cardepth (car l))))) (+ 1 (cardepth (car l)))))
(define (nestlist f zero n) (define (nestlist f zero n)
@ -105,7 +105,7 @@
(define (mapl f . lsts) (define (mapl f . lsts)
((label mapl- ((label mapl-
(lambda (lsts) (lambda (lsts)
(if (null (car lsts)) () (if (null? (car lsts)) ()
(begin (apply f lsts) (mapl- (map cdr lsts)))))) (begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts)) lsts))
@ -115,7 +115,7 @@
; swap the cars and cdrs of every cons in a structure ; swap the cars and cdrs of every cons in a structure
(define (swapad c) (define (swapad c)
(if (atom c) c (if (atom? c) c
(rplacd c (K (swapad (car c)) (rplacd c (K (swapad (car c))
(rplaca c (swapad (cdr c))))))) (rplaca c (swapad (cdr c)))))))
@ -123,7 +123,7 @@
(filter (lambda (e) (not (eq e x))) l)) (filter (lambda (e) (not (eq e x))) l))
(define (conscount c) (define (conscount c)
(if (consp c) (+ 1 (if (pair? c) (+ 1
(conscount (car c)) (conscount (car c))
(conscount (cdr c))) (conscount (cdr c)))
0)) 0))
@ -163,7 +163,7 @@
(todo (f-body (cddr catc)))) (todo (f-body (cddr catc))))
`(lambda (,var) `(lambda (,var)
(if (or (eq ,var ',extype) (if (or (eq ,var ',extype)
(and (consp ,var) (and (pair? ,var)
(eq (car ,var) ',extype))) (eq (car ,var) ',extype)))
,todo ,todo
(,next ,var))))) (,next ,var)))))
@ -220,8 +220,8 @@
(cdr ,first)))) (cdr ,first))))
(define (map-indexed f lst) (define (map-indexed f lst)
(if (atom lst) lst (if (atom? lst) lst
(let ((i 0)) (let ((i 0))
(accumulate-while (consp lst) (f (car lst) i) (accumulate-while (pair? lst) (f (car lst) i)
(begin (set! lst (cdr lst)) (begin (set! lst (cdr lst))
(set! i (1+ i))))))) (set! i (1+ i)))))))

2
femtolisp/torus.lsp
View File

@ -1,6 +1,6 @@
; -*- scheme -*- ; -*- scheme -*-
(define (maplist f l) (define (maplist f l)
(if (null l) () (if (null? l) ()
(cons (f l) (maplist f (cdr l))))) (cons (f l) (maplist f (cdr l)))))
; produce a beautiful, toroidal cons structure ; produce a beautiful, toroidal cons structure

8
femtolisp/unittest.lsp
View File

@ -7,9 +7,9 @@
(list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n))) (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
(define (each f l) (define (each f l)
(if (atom l) () (if (atom? l) ()
(begin (f (car l)) (begin (f (car l))
(each f (cdr l))))) (each f (cdr l)))))
(define (each^2 f l m) (define (each^2 f l m)
(each (lambda (o) (each (lambda (p) (f o p)) m)) l)) (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
@ -82,4 +82,4 @@
(3 . d) (2 . c) (0 . b) (1 . a)))) (3 . d) (2 . c) (0 . b) (1 . a))))
(princ "all tests pass\n") (princ "all tests pass\n")
T #t