lassik
/
upscheme
1
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

26
femtolisp/ast/asttools.lsp
View File

@ -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,13 +85,13 @@
; 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)))
@ -102,14 +102,14 @@
(map (lambda (se) (lvc- se newenv))
(cddr e))))
(map (lambda (se) (lvc- se env)) e)))))
(T e)))
(#t e)))
(define (lexical-var-conversion e)
(lvc- e ()))
; convert let to lambda
(define (let-expand e)
(maptree-post (lambda (n)
(if (and (consp n) (eq (car n) 'let))
(if (and (pair? n) (eq (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n)))
n))

45
femtolisp/ast/match.lsp
View File

@ -3,7 +3,7 @@
; by Jeff Bezanson
(define (unique lst)
(if (null lst)
(if (null? lst)
()
(cons (car lst)
(filter (lambda (x) (not (eq x (car lst))))
@ -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))))))
((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,17 +58,17 @@
(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
(if (null? alt) #f ; no alternatives left
(let ((subma (match- (car alt) (car expr) state)))
(or (and subma
(match-seq prest (cdr expr)
@ -94,7 +94,7 @@
(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
(#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) ())))
(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,24 +133,24 @@
; 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))))))
(T ())))
(#t ())))
(define (patargs p)
(cons '__ (patargs- p)))
; try to transform expr using a pattern-lambda from plist
; returns the new expression, or expr if no matches
(define (apply-patterns plist expr)
(if (null plist) expr
(if (function? plist)
(if (null? plist) expr
(if (procedure? plist)
(let ((enew (plist expr)))
(if (not enew)
expr
@ -170,7 +170,7 @@
; (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)
@ -178,5 +178,4 @@
(cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
; expr changed; iterate
(pattern-expand plist enew)))))

24
femtolisp/ast/rpasses.lsp
View File

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

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

30
femtolisp/color.lsp
View File

@ -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)

58
femtolisp/cps.lsp
View File

@ -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,9 +10,9 @@
,(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
(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)))))))
@ -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,14 +192,14 @@
(equal (cdr body) args)
(constant? (car (caddr form))))))
(car (caddr form)))
(T (map η-reduce form))))
(#t (map η-reduce form))))
(define (contains x form)
(or (eq form x)
(any (lambda (p) (contains x p)) form)))
(define (β-reduce form)
(if (or (atom form) (constant? form))
(if (or (atom? form) (constant? form))
form
(β-reduce- (map β-reduce form))))
@ -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:

2
femtolisp/cvalues.c
View File

@ -791,7 +791,7 @@ static value_t cvalue_array_aset(value_t *args)
{
char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
check_addr_args("aset", args[0], args[1], &data, &index);
check_addr_args("aset!", args[0], args[1], &data, &index);
char *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];

10
femtolisp/flisp.c
View File

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

12
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
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")) {
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);
}
}
}

92
femtolisp/read.c
View File

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

194
femtolisp/system.lsp
View File

@ -6,28 +6,17 @@
(set-constant! 'eq eq?)
(set-constant! 'eqv eqv?)
(set-constant! 'equal equal?)
(set-constant! 'booleanp boolean?)
(set-constant! 'consp pair?)
(set-constant! 'null null?)
(set-constant! 'atom atom?)
(set-constant! 'symbolp symbol?)
(set-constant! 'numberp number?)
(set-constant! 'boundp bound?)
(set-constant! 'builtinp builtin?)
(set-constant! 'vectorp vector?)
(set-constant! 'fixnump fixnum?)
(set-constant! 'rplaca set-car!)
(set-constant! 'rplacd set-cdr!)
(set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar)))
(set-constant! 'T #t)
; convert a sequence of body statements to a single expression.
; this allows define, defun, defmacro, let, etc. to contain multiple
; body expressions as in Common Lisp.
(set! f-body (lambda (e)
(cond ((atom e) e)
(cond ((atom? e) e)
((eq (cdr e) ()) (car e))
(T (cons 'begin e)))))
(#t (cons 'begin e)))))
(set-syntax! 'define-macro
(lambda (form . body)
@ -38,7 +27,7 @@
(list (list 'lambda (list name) (list 'set! name fn)) #f))
(define-macro (define form . body)
(if (symbolp form)
(if (symbol? form)
(list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
@ -47,73 +36,73 @@
(define (identity x) x)
(define (map f lst)
(if (atom lst) lst
(if (atom? lst) lst
(cons (f (car lst)) (map f (cdr lst)))))
(define-macro (let binds . body)
(cons (list 'lambda
(map (lambda (c) (if (consp c) (car c) c)) binds)
(map (lambda (c) (if (pair? c) (car c) c)) binds)
(f-body body))
(map (lambda (c) (if (consp c) (cadr c) #f)) binds)))
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))
(define (nconc . lsts)
(cond ((null lsts) ())
((null (cdr lsts)) (car lsts))
((null (car lsts)) (apply nconc (cdr lsts)))
(T (prog1 (car lsts)
(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
(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)
(cond ((atom? lst) #f)
((equal (car lst) item) lst)
(T (member item (cdr lst)))))
(#t (member item (cdr lst)))))
(define (memq item lst)
(cond ((atom lst) #f)
(cond ((atom? lst) #f)
((eq (car lst) item) lst)
(T (memq item (cdr lst)))))
(#t (memq item (cdr lst)))))
(define (memv item lst)
(cond ((atom lst) #f)
(cond ((atom? lst) #f)
((eqv (car lst) item) lst)
(T (memv item (cdr lst)))))
(#t (memv item (cdr lst)))))
(define (assoc item lst)
(cond ((atom lst) #f)
(cond ((atom? lst) #f)
((equal (caar lst) item) (car lst))
(T (assoc item (cdr lst)))))
(#t (assoc item (cdr lst)))))
(define (assv item lst)
(cond ((atom lst) #f)
(cond ((atom? lst) #f)
((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))))
(define (function? x)
(or (builtinp x)
(and (consp x) (eq (car x) 'lambda))))
(or (builtin? x)
(and (pair? x) (eq (car x) 'lambda))))
(define procedure? function?)
(define (macroexpand-1 e)
(if (atom e) e
(if (atom? e) e
(let ((f (macrocall? e)))
(if f (apply f (cdr e))
e))))
; convert to proper list, i.e. remove "dots", and append
(define (append.2 l tail)
(cond ((null l) tail)
((atom l) (cons l tail))
(T (cons (car l) (append.2 (cdr l) tail)))))
(cond ((null? l) tail)
((atom? l) (cons l tail))
(#t (cons (car l) (append.2 (cdr l) tail)))))
(define (cadr x) (car (cdr x)))
@ -124,27 +113,27 @@
((label mexpand
(lambda (e env f)
(begin
(while (and (consp e)
(while (and (pair? e)
(not (member (car e) env))
(set! f (macrocall? e)))
(set! e (apply f (cdr e))))
(cond ((and (consp e)
(cond ((and (pair? e)
(not (eq (car e) 'quote)))
(let ((newenv
(if (and (eq (car e) 'lambda)
(consp (cdr e)))
(pair? (cdr e)))
(append.2 (cadr e) env)
env)))
(map (lambda (x) (mexpand x newenv ())) e)))
;((and (symbolp e) (constant? e)) (eval e))
;((and (symbolp e)
;((and (symbol? e) (constant? e)) (eval e))
;((and (symbol? e)
; (not (member e *special-forms*))
; (not (member e env))) (cons '%top e))
(T e)))))
(#t e)))))
e () ()))
(define-macro (define form . body)
(if (symbolp form)
(if (symbol? form)
(list 'set! form (car body))
(list 'set! (car form)
(macroexpand (list 'lambda (cdr form) (f-body body))))))
@ -163,6 +152,7 @@
(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (mod x y) (- x (* (/ x y) y)))
(define remainder mod)
(define (abs x) (if (< x 0) (- x) x))
(define K prog1) ; K combinator ;)
@ -180,56 +170,58 @@
(define (cdddr x) (cdr (cdr (cdr x))))
(define (every pred lst)
(or (atom lst)
(or (atom? lst)
(and (pred (car lst))
(every pred (cdr lst)))))
(define (any pred lst)
(and (consp lst)
(and (pair? lst)
(or (pred (car lst))
(any pred (cdr lst)))))
(define (listp a) (or (null a) (consp a)))
(define (list? a) (or (null a) (and (pair? a) (list? (cdr a)))))
(define (listp a) (or (null? a) (pair? a)))
(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
(define (nthcdr lst n)
(if (<= n 0) lst
(nthcdr (cdr lst) (- n 1))))
(define list-tail nthcdr)
(define (list-ref lst n)
(car (nthcdr lst n)))
(define (list* . l)
(if (atom (cdr l))
(if (atom? (cdr l))
(car l)
(cons (car l) (apply list* (cdr l)))))
(define (nlist* . l)
(if (atom (cdr l))
(if (atom? (cdr l))
(car l)
(rplacd l (apply nlist* (cdr l)))))
(define (lastcdr l)
(if (atom l) l
(if (atom? l) l
(lastcdr (cdr l))))
(define (last l)
(cond ((atom l) l)
((atom (cdr l)) l)
(T (last (cdr l)))))
(cond ((atom? l) l)
((atom? (cdr l)) l)
(#t (last (cdr l)))))
(define last-pair last)
(define (map! f lst)
(prog1 lst
(while (consp lst)
(while (pair? lst)
(rplaca lst (f (car lst)))
(set! lst (cdr lst)))))
(define (mapcar f . lsts)
((label mapcar-
(lambda (lsts)
(cond ((null lsts) (f))
((atom (car lsts)) (car lsts))
(T (cons (apply f (map car lsts))
(cond ((null? lsts) (f))
((atom? (car lsts)) (car lsts))
(#t (cons (apply f (map car lsts))
(mapcar- (map cdr lsts)))))))
lsts))
@ -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)
@ -356,13 +348,13 @@
`(,(if specific
; 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)
(#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 ((consp p) (nreconc q (list (cadr p))))
((null p) (nreverse q))
(T (nreconc q (list (bq-process p)))))))
(if (null (cdr 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))

18
femtolisp/table.c
View File

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

34
femtolisp/test.lsp
View File

@ -9,17 +9,17 @@
;(define (reverse lst)
; ((label rev-help (lambda (lst result)
; (if (null lst) result
; (if (null? lst) result
; (rev-help (cdr lst) (cons (car lst) result)))))
; lst ()))
(define (append- . lsts)
((label append-h
(lambda (lsts)
(cond ((null lsts) ())
((null (cdr lsts)) (car lsts))
(T ((label append2 (lambda (l d)
(if (null l) d
(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)))))))
@ -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)))))))

2
femtolisp/torus.lsp
View File

@ -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

4
femtolisp/unittest.lsp
View File

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