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

switching to scheme #t, #f, and () values 

porting code to sort out which NILs are false and which are
empty lists

switching to scheme-style special forms. however you feel about
scheme names vs. CL names, using both is silly.

mostly switching to scheme predicate names, with compatibility
aliases for now. adding set-constant! to make this efficient.

adding null?, eqv?, assq, assv, assoc, memq, memv, member

adding 2-argument form of if
allowing else as final cond condition

looking for init file in same directory as executable, so flisp
can be started from anywhere

renaming T to FL_T, since exporting a 1-character symbol is
not very nice

adding opaque type boilerplate example file

adding correctness checking for the pattern-lambda benchmark

bugfix in int2str
This commit is contained in:
JeffBezanson 2009-01-29 01:04:23 +00:00
parent 38cf75733e
commit a55b46e9a6
26 changed files with 2374 additions and 496 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
femtolisp/ast/asttools.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
; utilities for AST processing ; utilities for AST processing
(define (symconcat s1 s2) (define (symconcat s1 s2)
@ -9,13 +10,13 @@
(cons item lst))) (cons item lst)))
(define (index-of item lst start) (define (index-of item lst start)
(cond ((null lst) nil) (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
(progn (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)
@ -136,19 +137,19 @@
env)))) env))))
; flatten op with any associativity ; flatten op with any associativity
(defmacro flatten-all-op (op e) (define-macro (flatten-all-op op e)
`(pattern-expand `(pattern-expand
(pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...)) (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
(cons ',op (append l (cdr inner) r))) (cons ',op (append l (cdr inner) r)))
,e)) ,e))
(defmacro pattern-lambda (pat body) (define-macro (pattern-lambda pat body)
(let* ((args (patargs pat)) (let* ((args (patargs pat))
(expander `(lambda ,args ,body))) (expander `(lambda ,args ,body)))
`(lambda (expr) `(lambda (expr)
(let ((m (match ',pat expr))) (let ((m (match ',pat expr)))
(if m (if m
; matches; perform expansion ; matches; perform expansion
(apply ,expander (map (lambda (var) (cdr (or (assoc var m) '(0 . nil)))) (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
',args)) ',args))
nil))))) #f)))))

25
femtolisp/ast/match.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
; tree regular expression pattern matching ; tree regular expression pattern matching
; by Jeff Bezanson ; by Jeff Bezanson
@ -41,12 +42,12 @@
(cond ((symbolp p) (cond ((symbolp p)
(cond ((eq p '_) state) (cond ((eq p '_) state)
(T (T
(let ((capt (assoc 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))))))
((functionp p) ((function? p)
(and (p expr) state)) (and (p expr) state))
((consp p) ((consp p)
@ -56,7 +57,7 @@
(and (match- (caddr p) expr state) (and (match- (caddr p) expr state)
(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 nil 1)) (match-alt (cdr p) () (list expr) state #f 1))
(T (T
(and (consp expr) (and (consp expr)
(equal (car p) (car expr)) (equal (car p) (car expr))
@ -67,7 +68,7 @@
; 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) nil ; 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)
@ -81,7 +82,7 @@
; 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) nil) ((> 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)
@ -101,16 +102,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) nil) (cond ((not state) #f)
((null p) (if (null expr) state nil)) ((null p) (if (null expr) state #f))
(T (T
(let ((subp (car p)) (let ((subp (car p))
(var nil)) (var #f))
(if (and (consp subp) (if (and (consp subp)
(eq (car subp) '--)) (eq (car subp) '--))
(progn (setq var (cadr subp)) (begin (set! var (cadr subp))
(setq subp (caddr subp))) (set! subp (caddr subp)))
nil) #f)
(let ((head (if (consp subp) (car subp) ()))) (let ((head (if (consp 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))
@ -149,7 +150,7 @@
; 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 (functionp plist) (if (function? plist)
(let ((enew (plist expr))) (let ((enew (plist expr)))
(if (not enew) (if (not enew)
expr expr

1710
femtolisp/ast/rpasses-out.lsp Normal file
View File

File diff suppressed because it is too large Load Diff

28
femtolisp/ast/rpasses.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
(load "match.lsp") (load "match.lsp")
(load "asttools.lsp") (load "asttools.lsp")
@ -18,10 +19,14 @@
; transformations ; transformations
(let ((ctr 0))
(define (r-gensym) (prog1 (intern (string "%r:" ctr))
(set! ctr (+ ctr 1)))))
(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 (gensym))) (let* ((g (if (not (consp lhs)) lhs (r-gensym)))
(n (if (symbolp name) (n (if (symbolp name)
name ;(symbol->string name) name ;(symbol->string name)
name)) name))
@ -41,7 +46,7 @@
(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) (gensym) rhs)) (let ((g (if (consp rhs) (r-gensym) rhs))
(op (car __))) (op (car __)))
`(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ()) `(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
@ -77,9 +82,9 @@
(let ((vars ())) (let ((vars ()))
(maptree-pre (lambda (s) (maptree-pre (lambda (s)
(if (not (consp s)) s (if (not (consp s)) s
(cond ((eq (car s) 'lambda) nil) (cond ((eq (car s) 'lambda) ())
((eq (car s) '<-) ((eq (car s) '<-)
(setq vars (list-adjoin (cadr s) vars)) (set! vars (list-adjoin (cadr s) vars))
(cddr s)) (cddr s))
(T s)))) (T s))))
n) n)
@ -102,18 +107,3 @@
(fancy-assignment-transform (fancy-assignment-transform
(dollarsign-transform (dollarsign-transform
(flatten-all-op && (flatten-all-op \|\| e))))))) (flatten-all-op && (flatten-all-op \|\| e)))))))
;(trace map)
;(pretty-print (compile-ish *input*))
;(print
; (time-call (lambda () (compile-ish *input*)) 1)
;)
(define (main)
(progn
(define *input* (load "datetimeR.lsp"))
;(define t0 ((java.util.Date:new):getTime))
(time (compile-ish *input*))
;(define t1 ((java.util.Date:new):getTime))
))
(main)

46
femtolisp/builtins.c
View File

@ -81,21 +81,32 @@ value_t fl_intern(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0])); return symbol(cvalue_data(args[0]));
} }
value_t fl_setconstant(value_t *args, u_int32_t nargs)
{
argcount("set-constant!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-constant!");
if (isconstant(args[0]) || sym->binding != UNBOUND)
lerror(ArgError, "set-constant!: cannot redefine %s",
symbol_name(args[0]));
setc(args[0], args[1]);
return args[1];
}
extern value_t LAMBDA; extern value_t LAMBDA;
value_t fl_setsyntax(value_t *args, u_int32_t nargs) value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{ {
argcount("set-syntax", nargs, 2); argcount("set-syntax!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-syntax"); symbol_t *sym = tosymbol(args[0], "set-syntax!");
if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax))) if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax)))
lerror(ArgError, "set-syntax: cannot define syntax for %s", lerror(ArgError, "set-syntax!: cannot define syntax for %s",
symbol_name(args[0])); symbol_name(args[0]));
if (args[1] == NIL) { if (args[1] == FL_F) {
sym->syntax = 0; sym->syntax = 0;
} }
else { else {
if (!iscons(args[1]) || car_(args[1])!=LAMBDA) if (!iscons(args[1]) || car_(args[1])!=LAMBDA)
type_error("set-syntax", "function", args[1]); type_error("set-syntax!", "function", args[1]);
sym->syntax = args[1]; sym->syntax = args[1];
} }
return args[1]; return args[1];
@ -109,7 +120,7 @@ value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
// don't behave like functions (they take their arguments directly // don't behave like functions (they take their arguments directly
// from the form rather than from the stack of evaluated arguments) // from the form rather than from the stack of evaluated arguments)
if (sym->syntax == TAG_CONST || isspecial(sym->syntax)) if (sym->syntax == TAG_CONST || isspecial(sym->syntax))
return NIL; return FL_F;
return sym->syntax; return sym->syntax;
} }
@ -160,15 +171,15 @@ extern value_t QUOTE;
value_t fl_constantp(value_t *args, u_int32_t nargs) value_t fl_constantp(value_t *args, u_int32_t nargs)
{ {
argcount("constantp", nargs, 1); argcount("constant?", nargs, 1);
if (issymbol(args[0])) if (issymbol(args[0]))
return (isconstant(args[0]) ? T : NIL); return (isconstant(args[0]) ? FL_T : FL_F);
if (iscons(args[0])) { if (iscons(args[0])) {
if (car_(args[0]) == QUOTE) if (car_(args[0]) == QUOTE)
return T; return FL_T;
return NIL; return FL_F;
} }
return T; return FL_T;
} }
value_t fl_fixnum(value_t *args, u_int32_t nargs) value_t fl_fixnum(value_t *args, u_int32_t nargs)
@ -278,7 +289,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs)
char *ptr = tostring(args[0], "path.cwd"); char *ptr = tostring(args[0], "path.cwd");
if (set_cwd(ptr)) if (set_cwd(ptr))
lerror(IOError, "could not cd to %s", ptr); lerror(IOError, "could not cd to %s", ptr);
return T; return FL_T;
} }
value_t fl_os_getenv(value_t *args, uint32_t nargs) value_t fl_os_getenv(value_t *args, uint32_t nargs)
@ -286,7 +297,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs)
argcount("os.getenv", nargs, 1); argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv"); char *name = tostring(args[0], "os.getenv");
char *val = getenv(name); char *val = getenv(name);
if (val == NULL) return NIL; if (val == NULL) return FL_F;
if (*val == 0) if (*val == 0)
return symbol_value(emptystringsym); return symbol_value(emptystringsym);
return cvalue_static_cstring(val); return cvalue_static_cstring(val);
@ -297,7 +308,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
argcount("os.setenv", nargs, 2); argcount("os.setenv", nargs, 2);
char *name = tostring(args[0], "os.setenv"); char *name = tostring(args[0], "os.setenv");
int result; int result;
if (args[1] == NIL) { if (args[1] == FL_F) {
result = unsetenv(name); result = unsetenv(name);
} }
else { else {
@ -306,7 +317,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
} }
if (result != 0) if (result != 0)
lerror(ArgError, "os.setenv: invalid environment variable"); lerror(ArgError, "os.setenv: invalid environment variable");
return T; return FL_T;
} }
value_t fl_rand(value_t *args, u_int32_t nargs) value_t fl_rand(value_t *args, u_int32_t nargs)
@ -351,11 +362,12 @@ extern void stringfuncs_init();
extern void table_init(); extern void table_init();
static builtinspec_t builtin_info[] = { static builtinspec_t builtin_info[] = {
{ "set-syntax", fl_setsyntax }, { "set-constant!", fl_setconstant },
{ "set-syntax!", fl_setsyntax },
{ "symbol-syntax", fl_symbolsyntax }, { "symbol-syntax", fl_symbolsyntax },
{ "syntax-environment", fl_syntax_env }, { "syntax-environment", fl_syntax_env },
{ "environment", fl_global_env }, { "environment", fl_global_env },
{ "constantp", fl_constantp }, { "constant?", fl_constantp },
{ "print", fl_print }, { "print", fl_print },
{ "princ", fl_princ }, { "princ", fl_princ },

25
femtolisp/color.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
; uncomment for compatibility with CL ; uncomment for compatibility with CL
;(defun mapp (f l) (mapcar f l)) ;(defun mapp (f l) (mapcar f l))
;(defmacro define (name &rest body) ;(defmacro define (name &rest body)
@ -18,7 +19,7 @@
((equal key (caar dl)) (cdar dl)) ((equal key (caar dl)) (cdar dl))
(T (dict-lookup (cdr dl) key)))) (T (dict-lookup (cdr dl) key))))
(define (dict-keys dl) (map (symbol-function 'car) dl)) (define (dict-keys dl) (map car dl))
; graphs ---------------------------------------------------------------------- ; graphs ----------------------------------------------------------------------
(define (graph-empty) (dict-new)) (define (graph-empty) (dict-new))
@ -50,14 +51,14 @@
color-of-node color-of-node
(map (map
(lambda (n) (lambda (n)
(let ((color-pair (assoc n coloring))) (let ((color-pair (assq n coloring)))
(if (consp color-pair) (cdr color-pair) nil))) (if (consp 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) nil (if (null lst) #f
(let ((ret (funcall 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
@ -71,24 +72,24 @@
(define (color-graph g colors) (define (color-graph g colors)
(if (null colors) (if (null colors)
(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)
(color-graph (graph-from-edges pairs) colors)) (color-graph (graph-from-edges pairs) colors))
; queens ---------------------------------------------------------------------- ; queens ----------------------------------------------------------------------
(defun can-attack (x y) (define (can-attack x y)
(let ((x1 (mod x 5)) (let ((x1 (mod x 5))
(y1 (truncate (/ x 5))) (y1 (truncate (/ x 5)))
(x2 (mod y 5)) (x2 (mod y 5))
(y2 (truncate (/ y 5)))) (y2 (truncate (/ y 5))))
(or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1)))))) (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
(defun generate-5x5-pairs () (define (generate-5x5-pairs)
(let ((result nil)) (let ((result ()))
(dotimes (x 25) (dotimes (x 25)
(dotimes (y 25) (dotimes (y 25)
(if (and (/= x y) (can-attack x y)) (if (and (/= x y) (can-attack x y))
(setq result (cons (cons x y) result)) nil))) (set! result (cons (cons x y) result)) ())))
result)) result))

90
femtolisp/cps.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
(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)
@ -8,30 +9,30 @@
,(f-body (cdr clause)) ,(f-body (cdr clause))
,(cond-clauses->if (cdr lst)))))) ,(cond-clauses->if (cdr lst))))))
(define (progn->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 (,_)
,(progn->cps (cdr forms) k))))))) ,(begin->cps (cdr forms) k)))))))
(defmacro lambda/cc (args body) (define-macro (lambda/cc args body)
`(rplaca (lambda ,args ,body) 'lambda/cc)) `(rplaca (lambda ,args ,body) 'lambda/cc))
; a utility used at run time to dispatch a call with or without ; a utility used at run time to dispatch a call with or without
; the continuation argument, depending on the function ; the continuation argument, depending on the function
(define (funcall/cc f k . args) (define (funcall/cc f k . args)
(if (and (consp f) (eq (car f) 'lambda/cc)) (if (and (pair? f) (eq (car f) 'lambda/cc))
(apply f (cons k args)) (apply f (cons k args))
(k (apply f args)))) (k (apply f args))))
(define *funcall/cc-names* (define *funcall/cc-names*
(list-to-vector (list-to-vector
(map (lambda (i) (intern (string 'funcall/cc- i))) (map (lambda (i) (intern (string 'funcall/cc- i)))
(iota 6)))) (iota 6))))
(defmacro def-funcall/cc-n (args) (define-macro (def-funcall/cc-n args)
(let* ((name (aref *funcall/cc-names* (length args)))) (let* ((name (aref *funcall/cc-names* (length args))))
`(define (,name f k ,@args) `(define (,name f k ,@args)
(if (and (consp f) (eq (car f) 'lambda/cc)) (if (and (pair? f) (eq (car f) 'lambda/cc))
(f k ,@args) (f k ,@args)
(k (f ,@args)))))) (k (f ,@args))))))
(def-funcall/cc-n ()) (def-funcall/cc-n ())
@ -43,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) (constantp 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)
@ -79,14 +80,14 @@
(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) (constantp form)) (cond ((or (atom form) (constant? form))
`(,k ,form)) `(,k ,form))
((eq (car form) 'lambda) ((eq (car form) 'lambda)
`(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g)))) `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
((eq (car form) 'progn) ((eq (car form) 'begin)
(progn->cps (cdr form) k)) (begin->cps (cdr form) k))
((eq (car form) 'cond) ((eq (car form) 'cond)
(cps- (cond->if form) k)) (cps- (cond->if form) k))
@ -116,7 +117,7 @@
,(cps- form g)))))) ,(cps- form g))))))
((eq (car form) 'or) ((eq (car form) 'or)
(cond ((atom (cdr form)) `(,k ())) (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)
@ -132,18 +133,18 @@
(body (caddr form)) (body (caddr form))
(lastval (gensym))) (lastval (gensym)))
(cps- (macroexpand (cps- (macroexpand
`(let ((,lastval nil)) `(let ((,lastval #f))
((label ,g (lambda () ((label ,g (lambda ()
(if ,test (if ,test
(progn (setq ,lastval ,body) (begin (set! ,lastval ,body)
(,g)) (,g))
,lastval)))))) ,lastval))))))
k))) k)))
((eq (car form) 'setq) ((eq (car form) 'set!)
(let ((var (cadr form)) (let ((var (cadr form))
(E (caddr form))) (E (caddr form)))
(cps- E `(lambda (,g) (,k (setq ,var ,g)))))) (cps- E `(lambda (,g) (,k (set! ,var ,g))))))
((eq (car form) 'reset) ((eq (car form) 'reset)
`(,k ,(cps- (cadr form) *top-k*))) `(,k ,(cps- (cadr form) *top-k*)))
@ -158,12 +159,12 @@
((eq (car form) 'without-delimited-continuations) ((eq (car form) 'without-delimited-continuations)
`(,k ,(cadr form))) `(,k ,(cadr form)))
((and (constantp (car form)) ((and (constant? (car form))
(builtinp (eval (car form)))) (builtin? (eval (car form))))
(builtincall->cps form k)) (builtincall->cps form k))
; ((lambda (...) body) ...) ; ((lambda (...) body) ...)
((and (consp (car form)) ((and (pair? (car form))
(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))))
@ -183,13 +184,13 @@
; (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) (constantp 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)))
(and (consp body) (and (pair? body)
(equal (cdr body) args) (equal (cdr body) args)
(constantp (car (caddr form)))))) (constant? (car (caddr form))))))
(car (caddr form))) (car (caddr form)))
(T (map η-reduce form)))) (T (map η-reduce form))))
@ -198,18 +199,18 @@
(any (lambda (p) (contains x p)) form))) (any (lambda (p) (contains x p)) form)))
(define (β-reduce form) (define (β-reduce form)
(if (or (atom form) (constantp 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)
(cond ((and (= (length form) 2) (cond ((and (= (length form) 2)
(consp (car form)) (pair? (car form))
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(body (caddr (car form)))) (body (caddr (car form))))
(and (consp body) (consp args) (and (pair? body) (pair? args)
(= (length body) 2) (= (length body) 2)
(= (length args) 1) (= (length args) 1)
(eq (car body) (car args)) (eq (car body) (car args))
@ -227,15 +228,15 @@
; ((lambda (p1 args...) body) s exprs...) ; ((lambda (p1 args...) body) s exprs...)
; where exprs... doesn't contain p1 ; where exprs... doesn't contain p1
((and (= (length form) 2) ((and (= (length form) 2)
(consp (car form)) (pair? (car form))
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(or (atom (cadr form)) (constantp (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))))
(and (consp args) (= (length args) 1) (and (pair? args) (= (length args) 1)
(consp body) (pair? body)
(consp (car body)) (pair? (car body))
(eq (caar body) 'lambda) (eq (caar body) 'lambda)
(let ((innerargs (cadr (car body))) (let ((innerargs (cadr (car body)))
(innerbody (caddr (car body))) (innerbody (caddr (car body)))
@ -248,14 +249,17 @@
(T form))) (T form)))
(defmacro with-delimited-continuations code (cps (f-body code))) (define-macro (with-delimited-continuations . code)
(cps (f-body code)))
(defmacro defgenerator (name args . body) (define-macro (define-generator form . body)
(let ((ko (gensym)) (let ((ko (gensym))
(cur (gensym))) (cur (gensym))
`(defun ,name ,args (name (car form))
(let ((,ko ()) (args (cdr form)))
(,cur ())) `(define (,name ,@args)
(let ((,ko #f)
(,cur #f))
(lambda () (lambda ()
(with-delimited-continuations (with-delimited-continuations
(if ,ko (,ko ,cur) (if ,ko (,ko ,cur)
@ -263,17 +267,17 @@
(let ((yield (let ((yield
(lambda (v) (lambda (v)
(shift yk (shift yk
(progn (setq ,ko yk) (begin (set! ,ko yk)
(setq ,cur v)))))) (set! ,cur v))))))
,(f-body body)))))))))) ,(f-body body))))))))))
; a test case ; a test case
(defgenerator range-iterator (lo hi) (define-generator (range-iterator lo hi)
((label loop ((label loop
(lambda (i) (lambda (i)
(if (< hi i) (if (< hi i)
'done 'done
(progn (yield i) (begin (yield i)
(loop (+ 1 i)))))) (loop (+ 1 i))))))
lo)) lo))
@ -301,15 +305,15 @@ todo:
(let ((x 0)) (let ((x 0))
(while (< x 10) (while (< x 10)
(progn (print x) (setq x (+ 1 x))))) (begin (print x) (set! x (+ 1 x)))))
=> =>
(let ((x 0)) (let ((x 0))
(reset (reset
(let ((l nil)) (let ((l #f))
(let ((k (shift k (k k)))) (let ((k (shift k (k k))))
(if (< x 10) (if (< x 10)
(progn (setq l (progn (print x) (begin (set! l (begin (print x)
(setq x (+ 1 x)))) (set! x (+ 1 x))))
(k k)) (k k))
l))))) l)))))
|# |#

7
femtolisp/cvalues.c
View File

@ -617,7 +617,12 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
case TAG_NUM: return fixnumsym; case TAG_NUM: return fixnumsym;
case TAG_SYM: return symbolsym; case TAG_SYM: return symbolsym;
case TAG_VECTOR: return vectorsym; case TAG_VECTOR: return vectorsym;
case TAG_BUILTIN: return builtinsym; case TAG_BUILTIN:
if (args[0] == FL_T || args[0] == FL_F)
return booleansym;
if (args[0] == NIL)
return nullsym;
return builtinsym;
} }
return cv_type((cvalue_t*)ptr(args[0])); return cv_type((cvalue_t*)ptr(args[0]));
} }

4
femtolisp/equal.c
View File

@ -256,8 +256,8 @@ value_t compare(value_t a, value_t b)
value_t equal(value_t a, value_t b) value_t equal(value_t a, value_t b)
{ {
if (eq_comparable(a, b)) if (eq_comparable(a, b))
return (a == b) ? T : NIL; return (a == b) ? FL_T : FL_F;
return (numval(compare_(a,b,1))==0 ? T : NIL); return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
} }
/* /*

194
femtolisp/flisp.c
View File

@ -28,7 +28,7 @@
* cvalues system providing C data types and a C FFI * cvalues system providing C data types and a C FFI
* constructor notation for nicely printing arbitrary values * constructor notation for nicely printing arbitrary values
* strings * strings
- hash tables * hash tables
by Jeff Bezanson (C) 2009 by Jeff Bezanson (C) 2009
Distributed under the BSD License Distributed under the BSD License
@ -52,27 +52,28 @@
static char *builtin_names[] = static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", { "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "setq", "progn", "trycatch", "%apply", "set!", "begin",
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp", "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
"builtinp", "vectorp", "fixnump", "equal", "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
"cons", "list", "car", "cdr", "rplaca", "rplacd",
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
"eval", "eval*", "apply", "prog1", "raise", "eval", "eval*", "apply", "prog1", "raise",
"+", "-", "*", "/", "<", "~", "&", "!", "$", "+", "-", "*", "/", "<", "~", "&", "!", "$",
"vector", "aref", "aset", "length", "assoc", "compare", "vector", "aref", "aset", "length", "assq", "compare", "for",
"for" }; "", "", "" };
#define N_STACK 98304 #define N_STACK 98304
value_t Stack[N_STACK]; value_t Stack[N_STACK];
uint32_t SP = 0; uint32_t SP = 0;
value_t NIL, T, LAMBDA, QUOTE, IF, TRYCATCH; value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError; value_t DivideError, BoundsError, Error, KeyError;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
value_t defunsym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
static value_t eval_sexpr(value_t e, uint32_t penv, int tail); static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
static value_t *alloc_words(int n); static value_t *alloc_words(int n);
@ -592,7 +593,7 @@ int isnumber(value_t v)
// eval ----------------------------------------------------------------------- // eval -----------------------------------------------------------------------
// return a cons element of v whose car is item // return a cons element of v whose car is item
static value_t assoc(value_t item, value_t v) static value_t assq(value_t item, value_t v)
{ {
value_t bind; value_t bind;
@ -602,7 +603,7 @@ static value_t assoc(value_t item, value_t v)
return bind; return bind;
v = cdr_(v); v = cdr_(v);
} }
return NIL; return FL_F;
} }
/* /*
@ -646,7 +647,7 @@ static value_t do_trycatch(value_t expr, uint32_t penv)
FL_CATCH { FL_CATCH {
v = cdr_(Stack[SP-1]); v = cdr_(Stack[SP-1]);
if (!iscons(v)) { if (!iscons(v)) {
v = NIL; // 1-argument form v = FL_F; // 1-argument form
} }
else { else {
Stack[SP-1] = car_(v); Stack[SP-1] = car_(v);
@ -771,7 +772,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
if (*pv == NIL) break; if (*pv == NIL) break;
pv = &vector_elt(*pv, 0); pv = &vector_elt(*pv, 0);
} }
sym = tosymbol(e, "setq"); sym = tosymbol(e, "set!");
if (sym->syntax != TAG_CONST) if (sym->syntax != TAG_CONST)
sym->binding = v; sym->binding = v;
break; break;
@ -809,24 +810,28 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_IF: case F_IF:
if (!iscons(Stack[saveSP])) goto notpair; if (!iscons(Stack[saveSP])) goto notpair;
v = car_(Stack[saveSP]); v = car_(Stack[saveSP]);
if (eval(v) != NIL) { if (eval(v) != FL_F) {
v = cdr_(Stack[saveSP]); v = cdr_(Stack[saveSP]);
if (!iscons(v)) goto notpair; if (!iscons(v)) goto notpair;
v = car_(v); v = car_(v);
} }
else { else {
v = cdr_(Stack[saveSP]); v = cdr_(Stack[saveSP]);
if (!iscons(v) || !iscons(v=cdr_(v))) goto notpair; if (!iscons(v)) goto notpair;
v = car_(v); if (!iscons(v=cdr_(v))) v = FL_F; // allow 2-arg form
else v = car_(v);
} }
tail_eval(v); tail_eval(v);
break; break;
case F_COND: case F_COND:
pv = &Stack[saveSP]; v = NIL; pv = &Stack[saveSP]; v = FL_F;
while (iscons(*pv)) { while (iscons(*pv)) {
c = tocons(car_(*pv), "cond"); c = tocons(car_(*pv), "cond");
v = eval(c->car); v = c->car;
if (v != NIL) { // allow last condition to be 'else'
if (iscons(cdr_(*pv)) || v != elsesym)
v = eval(v);
if (v != FL_F) {
*pv = cdr_(car_(*pv)); *pv = cdr_(car_(*pv));
// evaluate body forms // evaluate body forms
if (iscons(*pv)) { if (iscons(*pv)) {
@ -842,11 +847,11 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
break; break;
case F_AND: case F_AND:
pv = &Stack[saveSP]; v = T; pv = &Stack[saveSP]; v = FL_T;
if (iscons(*pv)) { if (iscons(*pv)) {
while (iscons(cdr_(*pv))) { while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) == NIL) { if ((v=eval(car_(*pv))) == FL_F) {
SP = saveSP; return NIL; SP = saveSP; return FL_F;
} }
*pv = cdr_(*pv); *pv = cdr_(*pv);
} }
@ -854,10 +859,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
break; break;
case F_OR: case F_OR:
pv = &Stack[saveSP]; v = NIL; pv = &Stack[saveSP]; v = FL_F;
if (iscons(*pv)) { if (iscons(*pv)) {
while (iscons(cdr_(*pv))) { while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) != NIL) { if ((v=eval(car_(*pv))) != FL_F) {
SP = saveSP; return v; SP = saveSP; return v;
} }
*pv = cdr_(*pv); *pv = cdr_(*pv);
@ -871,9 +876,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
PUSH(*body); PUSH(*body);
Stack[saveSP] = car_(Stack[saveSP]); Stack[saveSP] = car_(Stack[saveSP]);
value_t *cond = &Stack[saveSP]; value_t *cond = &Stack[saveSP];
PUSH(NIL); PUSH(FL_F);
pv = &Stack[SP-1]; pv = &Stack[SP-1];
while (eval(*cond) != NIL) { while (eval(*cond) != FL_F) {
*body = Stack[SP-2]; *body = Stack[SP-2];
while (iscons(*body)) { while (iscons(*body)) {
*pv = eval(car_(*body)); *pv = eval(car_(*body));
@ -892,7 +897,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
tail_eval(car_(*pv)); tail_eval(car_(*pv));
} }
v = NIL; v = FL_F;
break; break;
case F_TRYCATCH: case F_TRYCATCH:
v = do_trycatch(car(Stack[saveSP]), penv); v = do_trycatch(car(Stack[saveSP]), penv);
@ -900,13 +905,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
// ordinary functions // ordinary functions
case F_BOUNDP: case F_BOUNDP:
argcount("boundp", nargs, 1); argcount("bound?", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp"); sym = tosymbol(Stack[SP-1], "bound?");
v = (sym->binding == UNBOUND) ? NIL : T; v = (sym->binding == UNBOUND) ? FL_F : FL_T;
break; break;
case F_EQ: case F_EQ:
argcount("eq", nargs, 2); argcount("eq?", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); v = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
break; break;
case F_CONS: case F_CONS:
argcount("cons", nargs, 2); argcount("cons", nargs, 2);
@ -937,12 +942,12 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
if (!iscons(v)) goto notpair; if (!iscons(v)) goto notpair;
v = cdr_(v); v = cdr_(v);
break; break;
case F_RPLACA: case F_SETCAR:
argcount("rplaca", nargs, 2); argcount("set-car!", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1]; car(v=Stack[SP-2]) = Stack[SP-1];
break; break;
case F_RPLACD: case F_SETCDR:
argcount("rplacd", nargs, 2); argcount("set-cdr!", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1]; cdr(v=Stack[SP-2]) = Stack[SP-1];
break; break;
case F_VECTOR: case F_VECTOR:
@ -1015,36 +1020,47 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
break; break;
case F_ATOM: case F_ATOM:
argcount("atom", nargs, 1); argcount("atom?", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL); v = ((!iscons(Stack[SP-1])) ? FL_T : FL_F);
break; break;
case F_CONSP: case F_CONSP:
argcount("consp", nargs, 1); argcount("pair?", nargs, 1);
v = (iscons(Stack[SP-1]) ? T : NIL); v = (iscons(Stack[SP-1]) ? FL_T : FL_F);
break; break;
case F_SYMBOLP: case F_SYMBOLP:
argcount("symbolp", nargs, 1); argcount("symbol?", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL); v = ((issymbol(Stack[SP-1])) ? FL_T : FL_F);
break; break;
case F_NUMBERP: case F_NUMBERP:
argcount("numberp", nargs, 1); argcount("number?", nargs, 1);
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL); v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? FL_T : FL_F);
break; break;
case F_FIXNUMP: case F_FIXNUMP:
argcount("fixnump", nargs, 1); argcount("fixnum?", nargs, 1);
v = (isfixnum(Stack[SP-1]) ? T : NIL); v = (isfixnum(Stack[SP-1]) ? FL_T : FL_F);
break; break;
case F_BUILTINP: case F_BUILTINP:
argcount("builtinp", nargs, 1); argcount("builtin?", nargs, 1);
v = (isbuiltinish(Stack[SP-1]) ? T : NIL); v = Stack[SP-1];
v = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL)
? FL_T : FL_F);
break; break;
case F_VECTORP: case F_VECTORP:
argcount("vectorp", nargs, 1); argcount("vector?", nargs, 1);
v = ((isvector(Stack[SP-1])) ? T : NIL); v = ((isvector(Stack[SP-1])) ? FL_T : FL_F);
break; break;
case F_NOT: case F_NOT:
argcount("not", nargs, 1); argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL); v = ((Stack[SP-1] == FL_F) ? FL_T : FL_F);
break;
case F_NULL:
argcount("null?", nargs, 1);
v = ((Stack[SP-1] == NIL) ? FL_T : FL_F);
break;
case F_BOOLEANP:
argcount("boolean?", nargs, 1);
v = Stack[SP-1];
v = ((v == FL_T || v == FL_F) ? FL_T : FL_F);
break; break;
case F_ADD: case F_ADD:
s = 0; s = 0;
@ -1157,19 +1173,37 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_LT: case F_LT:
argcount("<", nargs, 2); argcount("<", nargs, 2);
if (bothfixnums(Stack[SP-2], Stack[SP-1])) { if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL; v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F;
} }
else { else {
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL; v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ?
FL_T : FL_F;
} }
break; break;
case F_EQUAL: case F_EQUAL:
argcount("equal", nargs, 2); argcount("equal?", nargs, 2);
if (eq_comparable(Stack[SP-2],Stack[SP-1])) { if (Stack[SP-2] == Stack[SP-1]) {
v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL; v = FL_T;
}
else if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
v = FL_F;
} }
else { else {
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? T : NIL; v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F;
}
break;
case F_EQV:
argcount("eqv?", nargs, 2);
if (Stack[SP-2] == Stack[SP-1]) {
v = FL_T;
}
else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) {
v = FL_F;
}
else {
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
FL_T : FL_F;
} }
break; break;
case F_EVAL: case F_EVAL:
@ -1207,9 +1241,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
lerror(ArgError, "prog1: too few arguments"); lerror(ArgError, "prog1: too few arguments");
v = Stack[saveSP+1]; v = Stack[saveSP+1];
break; break;
case F_ASSOC: case F_ASSQ:
argcount("assoc", nargs, 2); argcount("assq", nargs, 2);
v = assoc(Stack[SP-2], Stack[SP-1]); v = assq(Stack[SP-2], Stack[SP-1]);
break; break;
case F_FOR: case F_FOR:
argcount("for", nargs, 3); argcount("for", nargs, 3);
@ -1224,7 +1258,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
SP += 4; // make space SP += 4; // make space
Stack[SP-4] = fixnum(3); // env size Stack[SP-4] = fixnum(3); // env size
Stack[SP-1] = cdr_(cdr_(f)); // cloenv Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = NIL; v = FL_F;
for(s=lo; s <= hi; s++) { for(s=lo; s <= hi; s++) {
f = Stack[SP-5]; f = Stack[SP-5];
Stack[SP-3] = car_(f); // lambda list Stack[SP-3] = car_(f); // lambda list
@ -1256,6 +1290,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
noeval = 1; noeval = 1;
goto apply_lambda; goto apply_lambda;
case F_TRUE:
case F_FALSE:
case F_NIL:
goto apply_type_error;
default: default:
// function pointer tagged as a builtin // function pointer tagged as a builtin
v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs); v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs);
@ -1358,6 +1396,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
// not reached // not reached
} }
apply_type_error:
type_error("apply", "function", f); type_error("apply", "function", f);
notpair: notpair:
lerror(TypeError, "expected cons"); lerror(TypeError, "expected cons");
@ -1369,7 +1408,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
extern void builtins_init(); extern void builtins_init();
extern void comparehash_init(); extern void comparehash_init();
static char *EXEDIR; static char *EXEDIR = NULL;
void assign_global_builtins(builtinspec_t *b) void assign_global_builtins(builtinspec_t *b)
{ {
@ -1393,8 +1432,9 @@ void lisp_init(void)
htable_new(&printconses, 32); htable_new(&printconses, 32);
comparehash_init(); comparehash_init();
NIL = symbol("nil"); setc(NIL, NIL); NIL = builtin(F_NIL);
T = symbol("T"); setc(T, T); FL_T = builtin(F_TRUE);
FL_F = builtin(F_FALSE);
LAMBDA = symbol("lambda"); LAMBDA = symbol("lambda");
QUOTE = symbol("quote"); QUOTE = symbol("quote");
TRYCATCH = symbol("trycatch"); TRYCATCH = symbol("trycatch");
@ -1417,12 +1457,17 @@ void lisp_init(void)
fixnumsym = symbol("fixnum"); fixnumsym = symbol("fixnum");
vectorsym = symbol("vector"); vectorsym = symbol("vector");
builtinsym = symbol("builtin"); builtinsym = symbol("builtin");
defunsym = symbol("defun"); booleansym = symbol("boolean");
defmacrosym = symbol("defmacro"); nullsym = symbol("null");
definesym = symbol("define");
defmacrosym = symbol("define-macro");
forsym = symbol("for"); forsym = symbol("for");
labelsym = symbol("label"); labelsym = symbol("label");
setqsym = symbol("setq"); setqsym = symbol("set!");
set(printprettysym=symbol("*print-pretty*"), T); elsesym = symbol("else");
tsym = symbol("t"); Tsym = symbol("T");
fsym = symbol("f"); Fsym = symbol("F");
set(printprettysym=symbol("*print-pretty*"), FL_T);
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
lasterror = NIL; lasterror = NIL;
lerrorbuf[0] = '\0'; lerrorbuf[0] = '\0';
@ -1433,7 +1478,7 @@ void lisp_init(void)
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++; i++;
} }
for (; i < N_BUILTINS; i++) { for (; i < F_TRUE; i++) {
setc(symbol(builtin_names[i]), builtin(i)); setc(symbol(builtin_names[i]), builtin(i));
} }
@ -1559,6 +1604,7 @@ int locale_is_utf8;
int main(int argc, char *argv[]) int main(int argc, char *argv[])
{ {
value_t v; value_t v;
char fname_buf[1024];
locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, "")); locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
@ -1575,7 +1621,13 @@ int main(int argc, char *argv[])
if (argc > 1) return 1; if (argc > 1) return 1;
else goto repl; else goto repl;
} }
load_file("system.lsp"); fname_buf[0] = '\0';
if (EXEDIR != NULL) {
strcat(fname_buf, EXEDIR);
strcat(fname_buf, PATHSEPSTRING);
}
strcat(fname_buf, "system.lsp");
load_file(fname_buf);
if (argc > 1) { load_file(argv[1]); return 0; } if (argc > 1) { load_file(argv[1]); return 0; }
printf("; _ \n"); printf("; _ \n");
printf("; |_ _ _ |_ _ | . _ _\n"); printf("; |_ _ _ |_ _ | . _ _\n");

15
femtolisp/flisp.h
View File

@ -103,18 +103,21 @@ enum {
// special forms // special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN, F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN,
// functions // functions
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL, F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP,
F_CONS, F_LIST, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE, F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR, F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_COMPARE, F_FOR,
N_BUILTINS F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
}; };
#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN) #define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN)
extern value_t NIL, T; extern value_t NIL, FL_T, FL_F;
/* read, eval, print main entry points */ /* read, eval, print main entry points */
value_t read_sexpr(ios_t *f); value_t read_sexpr(ios_t *f);

63
femtolisp/opaque_type_template.c Normal file
View File

@ -0,0 +1,63 @@
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <string.h>
#include <assert.h>
#include <sys/types.h>
#include "llt.h"
#include "flisp.h"
// global replace TYPE with your type name to make your very own type!
static value_t TYPEsym;
static fltype_t *TYPEtype;
void print_TYPE(value_t v, ios_t *f, int princ)
{
}
void print_traverse_TYPE(value_t self)
{
}
void free_TYPE(value_t self)
{
}
void relocate_TYPE(value_t oldv, value_t newv)
{
}
cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,
print_traverse_TYPE };
int isTYPE(value_t v)
{
return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype;
}
value_t fl_TYPEp(value_t *args, uint32_t nargs)
{
argcount("TYPE?", nargs, 1);
return isTYPE(args[0]) ? FL_T : FL_F;
}
static TYPE_t *toTYPE(value_t v, char *fname)
{
if (!isTYPE(v))
type_error(fname, "TYPE", v);
return (TYPE_t*)cv_data((cvalue_t*)ptr(v));
}
static builtinspec_t TYPEfunc_info[] = {
{ "TYPE?", fl_TYPEp },
{ NULL, NULL }
};
void TYPE_init()
{
TYPEsym = symbol("TYPE");
TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
&TYPE_vtable, NULL);
assign_global_builtins(TYPEfunc_info);
}

7
femtolisp/perf.lsp
View File

@ -9,17 +9,20 @@
(assert (equal (time (yfib 32)) 2178309)) (assert (equal (time (yfib 32)) 2178309))
(princ "sort: ") (princ "sort: ")
(setq r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000)) (set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
(time (sort r)) (time (sort r))
(princ "mexpand: ") (princ "mexpand: ")
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2)))) (time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
(princ "append: ") (princ "append: ")
(setq L (map-int (lambda (x) (map-int identity 20)) 20)) (set! L (map-int (lambda (x) (map-int identity 20)) 20))
(time (dotimes (n 1000) (apply append L))) (time (dotimes (n 1000) (apply append L)))
(path.cwd "ast") (path.cwd "ast")
(princ "p-lambda: ") (princ "p-lambda: ")
(load "rpasses.lsp") (load "rpasses.lsp")
(define *input* (load "datetimeR.lsp"))
(time (set! *output* (compile-ish *input*)))
(assert (equal *output* (load "rpasses-out.lsp")))
(path.cwd "..") (path.cwd "..")

2
femtolisp/pisum.lsp
View File

@ -1,4 +1,4 @@
(defun pisum () (define (pisum)
(dotimes (j 500) (dotimes (j 500)
((label sumloop ((label sumloop
(lambda (i sum) (lambda (i sum)

28
femtolisp/print.c
View File

@ -169,7 +169,7 @@ static int smallp(value_t v)
static int specialindent(value_t head) static int specialindent(value_t head)
{ {
// indent these forms 2 spaces, not lined up with the first argument // indent these forms 2 spaces, not lined up with the first argument
if (head == LAMBDA || head == TRYCATCH || head == defunsym || if (head == LAMBDA || head == TRYCATCH || head == definesym ||
head == defmacrosym || head == forsym || head == labelsym) head == defmacrosym || head == forsym || head == labelsym)
return 2; return 2;
return -1; return -1;
@ -200,7 +200,13 @@ static int allsmallp(value_t v)
static int indentafter3(value_t head, value_t v) static int indentafter3(value_t head, value_t v)
{ {
// for certain X always indent (X a b c) after b // for certain X always indent (X a b c) after b
return ((head == defunsym || head == defmacrosym || head == forsym) && return ((head == forsym) && !allsmallp(cdr_(v)));
}
static int indentafter2(value_t head, value_t v)
{
// for certain X always indent (X a b) after a
return ((head == definesym || head == defmacrosym) &&
!allsmallp(cdr_(v))); !allsmallp(cdr_(v)));
} }
@ -251,6 +257,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
if (!blk) always = indentevery(v); if (!blk) always = indentevery(v);
value_t head = car_(v); value_t head = car_(v);
int after3 = indentafter3(head, v); int after3 = indentafter3(head, v);
int after2 = indentafter2(head, v);
int n_unindented = 1; int n_unindented = 1;
while (1) { while (1) {
lastv = VPOS; lastv = VPOS;
@ -287,6 +294,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
(n > 0 && always) || (n > 0 && always) ||
(n == 2 && after3) || (n == 2 && after3) ||
(n == 1 && after2) ||
(n_unindented >= 3 && !nextsmall) || (n_unindented >= 3 && !nextsmall) ||
@ -328,8 +336,6 @@ void fl_print_child(ios_t *f, value_t v, int princ)
name = symbol_name(v); name = symbol_name(v);
if (princ) if (princ)
outs(name, f); outs(name, f);
else if (v == NIL)
outs("()", f);
else if (ismanaged(v)) { else if (ismanaged(v)) {
outs("#:", f); outs("#:", f);
outs(name, f); outs(name, f);
@ -338,6 +344,18 @@ void fl_print_child(ios_t *f, value_t v, int princ)
print_symbol_name(f, name); print_symbol_name(f, name);
break; break;
case TAG_BUILTIN: case TAG_BUILTIN:
if (v == FL_T) {
outs("#t", f);
break;
}
if (v == FL_F) {
outs("#f", f);
break;
}
if (v == NIL) {
outs("()", f);
break;
}
if (isbuiltin(v)) { if (isbuiltin(v)) {
outs("#.", f); outs("#.", f);
outs(builtin_names[uintval(v)], f); outs(builtin_names[uintval(v)], f);
@ -624,7 +642,7 @@ static void set_print_width()
void print(ios_t *f, value_t v, int princ) void print(ios_t *f, value_t v, int princ)
{ {
print_pretty = (symbol_value(printprettysym) != NIL); print_pretty = (symbol_value(printprettysym) != FL_F);
if (print_pretty) if (print_pretty)
set_print_width(); set_print_width();
printlabel = 0; printlabel = 0;

19
femtolisp/read.c
View File

@ -270,12 +270,6 @@ static u_int32_t peek(ios_t *f)
read_token(f, ch, 0); read_token(f, ch, 0);
toktype = TOK_SHARPSYM; toktype = TOK_SHARPSYM;
tokval = symbol(buf); tokval = symbol(buf);
c = nextchar(f);
if (c != '(') {
take();
lerror(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
}
} }
else { else {
lerror(ParseError, "read: unknown read macro"); lerror(ParseError, "read: unknown read macro");
@ -465,6 +459,7 @@ static value_t do_read_sexpr(ios_t *f, value_t label)
value_t v, sym, oldtokval, *head; value_t v, sym, oldtokval, *head;
value_t *pv; value_t *pv;
u_int32_t t; u_int32_t t;
char c;
t = peek(f); t = peek(f);
take(); take();
@ -511,8 +506,18 @@ static value_t do_read_sexpr(ios_t *f, value_t label)
read_list(f, &Stack[SP-1], label); read_list(f, &Stack[SP-1], label);
return POP(); return POP();
case TOK_SHARPSYM: case TOK_SHARPSYM:
// constructor notation
sym = tokval; sym = tokval;
if (sym == tsym || sym == Tsym)
return FL_T;
else if (sym == fsym || sym == Fsym)
return FL_F;
// constructor notation
c = nextchar(f);
if (c != '(') {
take();
lerror(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
}
PUSH(NIL); PUSH(NIL);
read_list(f, &Stack[SP-1], UNBOUND); read_list(f, &Stack[SP-1], UNBOUND);
v = POP(); v = POP();

6
femtolisp/stream.c
View File

@ -31,8 +31,8 @@ int isstream(value_t v)
value_t fl_streamp(value_t *args, uint32_t nargs) value_t fl_streamp(value_t *args, uint32_t nargs)
{ {
argcount("streamp", nargs, 1); argcount("stream?", nargs, 1);
return isstream(args[0]) ? T : NIL; return isstream(args[0]) ? FL_T : FL_F;
} }
static ios_t *tostream(value_t v, char *fname) static ios_t *tostream(value_t v, char *fname)
@ -43,7 +43,7 @@ static ios_t *tostream(value_t v, char *fname)
} }
static builtinspec_t streamfunc_info[] = { static builtinspec_t streamfunc_info[] = {
{ "streamp", fl_streamp }, { "stream?", fl_streamp },
{ NULL, NULL } { NULL, NULL }
}; };

14
femtolisp/string.c
View File

@ -37,8 +37,8 @@ static value_t print_to_string(value_t v, int princ)
value_t fl_stringp(value_t *args, u_int32_t nargs) value_t fl_stringp(value_t *args, u_int32_t nargs)
{ {
argcount("stringp", nargs, 1); argcount("string?", nargs, 1);
return isstring(args[0]) ? T : NIL; return isstring(args[0]) ? FL_T : FL_F;
} }
value_t fl_string_length(value_t *args, u_int32_t nargs) value_t fl_string_length(value_t *args, u_int32_t nargs)
@ -84,7 +84,7 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs)
{ {
int term=0; int term=0;
if (nargs == 2) { if (nargs == 2) {
term = (POP() != NIL); term = (POP() != FL_F);
nargs--; nargs--;
} }
argcount("string.decode", nargs, 1); argcount("string.decode", nargs, 1);
@ -254,7 +254,7 @@ static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
{ {
char *p = memchr(s+start, c, len-start); char *p = memchr(s+start, c, len-start);
if (p == NULL) if (p == NULL)
return NIL; return FL_F;
return size_wrap((size_t)(p - s)); return size_wrap((size_t)(p - s));
} }
@ -293,7 +293,7 @@ value_t fl_string_find(value_t *args, u_int32_t nargs)
type_error("string.find", "string", args[1]); type_error("string.find", "string", args[1]);
} }
if (needlesz > len-start) if (needlesz > len-start)
return NIL; return FL_F;
else if (needlesz == 1) else if (needlesz == 1)
return mem_find_byte(s, needle[0], start, len); return mem_find_byte(s, needle[0], start, len);
else if (needlesz == 0) else if (needlesz == 0)
@ -305,7 +305,7 @@ value_t fl_string_find(value_t *args, u_int32_t nargs)
return size_wrap(i); return size_wrap(i);
} }
} }
return NIL; return FL_F;
} }
value_t fl_string_inc(value_t *args, u_int32_t nargs) value_t fl_string_inc(value_t *args, u_int32_t nargs)
@ -349,7 +349,7 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs)
static builtinspec_t stringfunc_info[] = { static builtinspec_t stringfunc_info[] = {
{ "string", fl_string }, { "string", fl_string },
{ "stringp", fl_stringp }, { "string?", fl_stringp },
{ "string.length", fl_string_length }, { "string.length", fl_string_length },
{ "string.split", fl_string_split }, { "string.split", fl_string_split },
{ "string.sub", fl_string_sub }, { "string.sub", fl_string_sub },

363
femtolisp/system.lsp
View File

@ -1,56 +1,70 @@
; -*- scheme -*-
; femtoLisp standard library ; femtoLisp standard library
; by Jeff Bezanson (C) 2009 ; by Jeff Bezanson (C) 2009
; Distributed under the BSD License ; Distributed under the BSD License
(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. ; 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.
(setq 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 'progn e))))) (T (cons 'begin e)))))
(set-syntax 'defmacro (set-syntax! 'define-macro
(lambda (name args . body) (lambda (form . body)
(list 'set-syntax (list 'quote name) (list 'set-syntax! (list 'quote (car form))
(list 'lambda args (f-body body))))) (list 'lambda (cdr form) (f-body body)))))
(defmacro label (name fn) (define-macro (label name fn)
(list (list 'lambda (list name) (list 'setq name fn)) nil)) (list (list 'lambda (list name) (list 'set! name fn)) #f))
; support both CL defun and Scheme-style define (define-macro (define form . body)
(defmacro defun (name args . body) (if (symbolp form)
(list 'setq name (list 'lambda args (f-body body)))) (list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
(defmacro define (name . body) (define (set s v) (eval (list 'set! s (list 'quote v))))
(if (symbolp name)
(list 'setq name (car body))
(cons 'defun (cons (car name) (cons (cdr name) body)))))
(defun set (s v) (eval (list 'setq s (list 'quote v)))) (define (identity x) x)
(defun identity (x) x) (define (map f lst)
(setq null not)
(defun 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)))))
(defmacro 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 (consp c) (car c) c)) binds)
(f-body body)) (f-body body))
(map (lambda (c) (if (consp c) (cadr c) nil)) binds))) (map (lambda (c) (if (consp c) (cadr c) #f)) binds)))
(defun 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)))))))
(defun 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)
@ -59,43 +73,61 @@
(append2 (cdr l) d))))) (append2 (cdr l) d)))))
(car lsts) (apply append (cdr lsts)))))) (car lsts) (apply append (cdr lsts))))))
(defun member (item lst) (define (member item lst)
(cond ((atom lst) ()) (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)
(cond ((atom lst) #f)
((eq (car lst) item) lst)
(T (memq item (cdr lst)))))
(define (memv item lst)
(cond ((atom lst) #f)
((eqv (car lst) item) lst)
(T (memv item (cdr lst)))))
(defun macrocallp (e) (and (symbolp (car e)) (define (assoc item lst)
(symbol-syntax (car e)))) (cond ((atom lst) #f)
((equal (caar lst) item) (car lst))
(T (assoc item (cdr lst)))))
(define (assv item lst)
(cond ((atom lst) #f)
((eqv (caar lst) item) (car lst))
(T (assv item (cdr lst)))))
(defun functionp (x) (define (macrocall? e) (and (symbolp (car e))
(symbol-syntax (car e))))
(define (function? x)
(or (builtinp x) (or (builtinp x)
(and (consp x) (eq (car x) 'lambda)))) (and (consp x) (eq (car x) 'lambda))))
(define procedure? function?)
(defun macroexpand-1 (e) (define (macroexpand-1 e)
(if (atom e) e (if (atom e) e
(let ((f (macrocallp 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
(defun 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)))
;(setq *special-forms* '(quote cond if and or while lambda trycatch ;(set! *special-forms* '(quote cond if and or while lambda trycatch
; setq progn)) ; set! begin))
(defun macroexpand (e) (define (macroexpand e)
((label mexpand ((label mexpand
(lambda (e env f) (lambda (e env f)
(progn (begin
(while (and (consp e) (while (and (consp e)
(not (member (car e) env)) (not (member (car e) env))
(setq f (macrocallp e))) (set! f (macrocall? e)))
(setq e (apply f (cdr e)))) (set! e (apply f (cdr e))))
(cond ((and (consp e) (cond ((and (consp e)
(not (eq (car e) 'quote))) (not (eq (car e) 'quote)))
(let ((newenv (let ((newenv
@ -103,28 +135,26 @@
(consp (cdr e))) (consp (cdr e)))
(append.2 (cadr e) env) (append.2 (cadr e) env)
env))) env)))
(map (lambda (x) (mexpand x newenv nil)) e))) (map (lambda (x) (mexpand x newenv ())) e)))
;((and (symbolp e) (constantp e)) (eval e)) ;((and (symbolp e) (constant? e)) (eval e))
;((and (symbolp e) ;((and (symbolp 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 nil nil)) e () ()))
; uncomment this to macroexpand functions at definition time. (define-macro (define form . body)
; makes typical code ~25% faster, but only works for defun expressions (if (symbolp form)
; at the top level. (list 'set! form (car body))
(defmacro defun (name args . body) (list 'set! (car form)
(list 'setq name (macroexpand (list 'lambda args (f-body body))))) (macroexpand (list 'lambda (cdr form) (f-body body))))))
(define-macro (define-macro form . body)
(list 'set-syntax! (list 'quote (car form))
(macroexpand (list 'lambda (cdr form) (f-body body)))))
(define macroexpand (macroexpand macroexpand))
; same thing for macros. enabled by default because macros are usually (define = equal)
; defined at the top level. (define eql eqv)
(defmacro defmacro (name args . body)
(list 'set-syntax (list 'quote name)
(macroexpand (list 'lambda args (f-body body)))))
(setq = equal)
(setq eql equal)
(define (/= a b) (not (equal a b))) (define (/= a b) (not (equal a b)))
(define != /=) (define != /=)
(define (> a b) (< b a)) (define (> a b) (< b a))
@ -134,11 +164,7 @@
(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 (abs x) (if (< x 0) (- x) x)) (define (abs x) (if (< x 0) (- x) x))
(setq K prog1) ; K combinator ;) (define K prog1) ; K combinator ;)
(define (funcall f . args) (apply f args))
(define (symbol-value sym) (eval sym))
(define symbol-function symbol-value)
(define (terpri) (princ "\n") nil)
(define (caar x) (car (car x))) (define (caar x) (car (car x)))
(define (cdar x) (cdr (car x))) (define (cdar x) (cdr (car x)))
@ -153,51 +179,52 @@
(define (cddar x) (cdr (cdr (car x)))) (define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x)))) (define (cdddr x) (cdr (cdr (cdr x))))
(defun 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)))))
(defun any (pred lst) (define (any pred lst)
(and (consp lst) (and (consp lst)
(or (pred (car lst)) (or (pred (car lst))
(any pred (cdr lst))))) (any pred (cdr lst)))))
(defun listp (a) (or (eq a ()) (consp a))) (define (listp a) (or (null a) (consp a)))
(define (list? a) (or (null a) (and (pair? a) (list? (cdr a)))))
(defun 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))))
(defun list-ref (lst n) (define (list-ref lst n)
(car (nthcdr lst n))) (car (nthcdr lst n)))
(defun 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)))))
(defun 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)))))
(defun lastcdr (l) (define (lastcdr l)
(if (atom l) l (if (atom l) l
(lastcdr (cdr l)))) (lastcdr (cdr l))))
(defun 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)))))
(defun map! (f lst) (define (map! f lst)
(prog1 lst (prog1 lst
(while (consp lst) (while (consp lst)
(rplaca lst (f (car lst))) (rplaca lst (f (car lst)))
(setq lst (cdr lst))))) (set! lst (cdr lst)))))
(defun mapcar (f . lsts) (define (mapcar f . lsts)
((label mapcar- ((label mapcar-
(lambda (lsts) (lambda (lsts)
(cond ((null lsts) (f)) (cond ((null lsts) (f))
@ -206,18 +233,18 @@
(mapcar- (map cdr lsts))))))) (mapcar- (map cdr lsts)))))))
lsts)) lsts))
(defun transpose (M) (apply mapcar (cons list M))) (define (transpose M) (apply mapcar (cons list M)))
(defun filter (pred lst) (filter- pred lst nil)) (define (filter pred lst) (filter- pred lst ()))
(defun 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))))
(defun separate (pred lst) (separate- pred lst nil nil)) (define (separate pred lst) (separate- pred lst () ()))
(defun 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))
@ -232,11 +259,7 @@
(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 nil lst)) (define (reverse lst) (foldl cons () lst))
(defun reduce (f zero lst)
(if (null lst) zero
(reduce f (f zero (car lst)) (cdr lst))))
(define (copy-list l) (define (copy-list l)
(if (atom l) l (if (atom l) l
@ -248,80 +271,80 @@
(copy-tree (cdr l))))) (copy-tree (cdr l)))))
(define (nreverse l) (define (nreverse l)
(let ((prev nil)) (let ((prev ()))
(while (consp l) (while (consp l)
(setq l (prog1 (cdr l) (set! l (prog1 (cdr l)
(rplacd l (prog1 prev (rplacd l (prog1 prev
(setq prev l)))))) (set! prev l))))))
prev)) prev))
(defmacro let* (binds . body) (define-macro (let* binds . body)
(cons (list 'lambda (map car binds) (cons (list 'lambda (map car binds)
(cons 'progn (cons 'begin
(nconc (map (lambda (b) (cons 'setq b)) binds) (nconc (map (lambda (b) (cons 'set! b)) binds)
body))) body)))
(map (lambda (x) nil) binds))) (map (lambda (x) #f) binds)))
(defmacro labels (binds . body) (define-macro (labels binds . body)
(cons (list 'lambda (map car binds) (cons (list 'lambda (map car binds)
(cons 'progn (cons 'begin
(nconc (map (lambda (b) (nconc (map (lambda (b)
(list 'setq (car b) (cons 'lambda (cdr b)))) (list 'set! (car b) (cons 'lambda (cdr b))))
binds) binds)
body))) body)))
(map (lambda (x) nil) binds))) (map (lambda (x) #f) binds)))
(defmacro when (c . body) (list 'if c (f-body body) nil)) (define-macro (when c . body) (list 'if c (f-body body) #f))
(defmacro unless (c . body) (list 'if c nil (f-body body))) (define-macro (unless c . body) (list 'if c #f (f-body body)))
(defmacro dotimes (var . body) (define-macro (dotimes var . body)
(let ((v (car var)) (let ((v (car var))
(cnt (cadr var))) (cnt (cadr var)))
`(for 0 (- ,cnt 1) `(for 0 (- ,cnt 1)
(lambda (,v) ,(f-body body))))) (lambda (,v) ,(f-body body)))))
(defun map-int (f n) (define (map-int f n)
(if (<= n 0) (if (<= n 0)
() ()
(let ((first (cons (f 0) nil)) (let ((first (cons (f 0) ()))
(acc nil)) (acc ()))
(setq acc first) (set! acc first)
(for 1 (- n 1) (for 1 (- n 1)
(lambda (i) (lambda (i)
(progn (rplacd acc (cons (f i) nil)) (begin (rplacd acc (cons (f i) ()))
(setq acc (cdr acc))))) (set! acc (cdr acc)))))
first))) first)))
(defun iota (n) (map-int identity n)) (define (iota n) (map-int identity n))
(define ι iota) (define ι iota)
(defun error args (raise (cons 'error args))) (define (error . args) (raise (cons 'error args)))
(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value))) (define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
(defmacro 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 (consp ,e)
(eq (car ,e) 'thrown-value) (eq (car ,e) 'thrown-value)
(eq (cadr ,e) ,tag)) (eq (cadr ,e) ,tag))
(caddr ,e) (caddr ,e)
(raise ,e)))))) (raise ,e))))))
(defmacro unwind-protect (expr finally) (define-macro (unwind-protect expr finally)
(let ((e (gensym))) (let ((e (gensym)))
`(prog1 (trycatch ,expr `(prog1 (trycatch ,expr
(lambda (,e) (progn ,finally (raise ,e)))) (lambda (,e) (begin ,finally (raise ,e))))
,finally))) ,finally)))
; (try expr ; (try expr
; (catch (type-error e) . exprs) ; (catch (type-error e) . exprs)
; (catch (io-error e) . exprs) ; (catch (io-error e) . exprs)
; (catch (e) . exprs) ; (catch (e) . exprs)
; (finally . exprs)) ; (finally . exprs))
(defmacro try (expr . forms) (define-macro (try expr . forms)
(let* ((e (gensym)) (let* ((e (gensym))
(reraised (gensym)) (reraised (gensym))
(final (f-body (cdr (or (assoc 'finally forms) '(()))))) (final (f-body (cdr (or (assq 'finally forms) '(())))))
(catches (filter (lambda (f) (eq (car f) 'catch)) forms)) (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
(catchblock `(cond (catchblock `(cond
,.(map (lambda (catc) ,.(map (lambda (catc)
@ -337,7 +360,7 @@
(eq (car ,e) (eq (car ,e)
',extype))) ',extype)))
T); (catch (e) ...), match anything T); (catch (e) ...), match anything
(let ((,var ,e)) (progn ,@todo))))) (let ((,var ,e)) (begin ,@todo)))))
catches) catches)
(T (raise ,e))))) ; no matches, reraise (T (raise ,e))))) ; no matches, reraise
(if final (if final
@ -347,12 +370,12 @@
(lambda (,e) (lambda (,e)
(trycatch ,catchblock (trycatch ,catchblock
(lambda (,reraised) (lambda (,reraised)
(progn ,final (begin ,final
(raise ,reraised)))))) (raise ,reraised))))))
,final) ,final)
; finally only; same as unwind-protect ; finally only; same as unwind-protect
`(prog1 (trycatch ,expr (lambda (,e) `(prog1 (trycatch ,expr (lambda (,e)
(progn ,final (raise ,e)))) (begin ,final (raise ,e))))
,final)) ,final))
; catch, no finally ; catch, no finally
`(trycatch ,expr (lambda (,e) ,catchblock))))) `(trycatch ,expr (lambda (,e) ,catchblock)))))
@ -360,7 +383,7 @@
; setf ; setf
; expands (setf (place x ...) v) to (mutator (f x ...) v) ; expands (setf (place x ...) v) to (mutator (f x ...) v)
; (mutator (identity x ...) v) is interpreted as (mutator x ... v) ; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
(setq *setf-place-list* (set! *setf-place-list*
; place mutator f ; place mutator f
'((car rplaca identity) '((car rplaca identity)
(cdr rplacd identity) (cdr rplacd identity)
@ -379,60 +402,58 @@
(list-ref rplaca nthcdr) (list-ref rplaca nthcdr)
(get put identity) (get put identity)
(aref aset identity) (aref aset identity)
(symbol-function set identity) (symbol-syntax set-syntax! identity)))
(symbol-value set identity)
(symbol-syntax set-syntax identity)))
(defun setf-place-mutator (place val) (define (setf-place-mutator place val)
(if (symbolp place) (if (symbolp place)
(list 'setq place val) (list 'set! place val)
(let ((mutator (assoc (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)))
(list (cadr mutator) (list (cadr mutator)
(cons (caddr mutator) (cdr place)) (cons (caddr mutator) (cdr place))
val)))))) val))))))
(defmacro setf args (define-macro (setf . args)
(f-body (f-body
((label setf- ((label setf-
(lambda (args) (lambda (args)
(if (null args) (if (null args)
nil ()
(cons (setf-place-mutator (car args) (cadr args)) (cons (setf-place-mutator (car args) (cadr args))
(setf- (cddr args)))))) (setf- (cddr args))))))
args))) args)))
(defun revappend (l1 l2) (nconc (reverse l1) l2)) (define (revappend l1 l2) (nconc (reverse l1) l2))
(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) (define (nreconc l1 l2) (nconc (nreverse l1) l2))
(defun list-to-vector (l) (apply vector l)) (define (list-to-vector l) (apply vector l))
(defun vector-to-list (v) (define (vector-to-list v)
(let ((n (length v)) (let ((n (length v))
(l nil)) (l ()))
(for 1 n (for 1 n
(lambda (i) (lambda (i)
(setq l (cons (aref v (- n i)) l)))) (set! l (cons (aref v (- n i)) l))))
l)) l))
(defun self-evaluating-p (x) (define (self-evaluating? x)
(or (and (atom x) (or (and (atom x)
(not (symbolp x))) (not (symbolp x)))
(and (constantp x) (and (constant? x)
(eq x (eval x))))) (eq x (eval x)))))
; backquote ; backquote
(defmacro backquote (x) (bq-process x)) (define-macro (backquote x) (bq-process x))
(defun splice-form-p (x) (define (splice-form? x)
(or (and (consp x) (or (eq (car x) '*comma-at*) (or (and (consp x) (or (eq (car x) '*comma-at*)
(eq (car x) '*comma-dot*))) (eq (car x) '*comma-dot*)))
(eq x '*comma*))) (eq x '*comma*)))
(defun bq-process (x) (define (bq-process x)
(cond ((self-evaluating-p x) (cond ((self-evaluating? x)
(if (vectorp x) (if (vectorp 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)
@ -442,7 +463,7 @@
((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-p 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)
@ -451,8 +472,8 @@
(T (let ((p x) (q ())) (T (let ((p x) (q ()))
(while (and (consp p) (while (and (consp p)
(not (eq (car p) '*comma*))) (not (eq (car p) '*comma*)))
(setq q (cons (bq-bracket (car p)) q)) (set! q (cons (bq-bracket (car p)) q))
(setq p (cdr p))) (set! p (cdr p)))
(let ((forms (let ((forms
(cond ((consp p) (nreconc q (list (cadr p)))) (cond ((consp p) (nreconc q (list (cadr p))))
((null p) (nreverse q)) ((null p) (nreverse q))
@ -461,7 +482,7 @@
(car forms) (car forms)
(cons 'nconc forms))))))) (cons 'nconc forms)))))))
(defun 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)))
@ -469,21 +490,23 @@
(T (list list (bq-process x))))) (T (list list (bq-process x)))))
; bracket without splicing ; bracket without splicing
(defun bq-bracket1 (x) (define (bq-bracket1 x)
(if (and (consp x) (eq (car x) '*comma*)) (if (and (consp x) (eq (car x) '*comma*))
(cadr x) (cadr x)
(bq-process x))) (bq-process x)))
(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr)))) (define-macro (assert expr) `(if ,expr T (raise '(assert-failed ,expr))))
(defmacro time (expr) (define-macro (time expr)
(let ((t0 (gensym))) (let ((t0 (gensym)))
`(let ((,t0 (time.now))) `(let ((,t0 (time.now)))
(prog1 (prog1
,expr ,expr
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
(defun vector.map (f v) (define (display x) (princ x) (princ "\n"))
(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)
@ -491,16 +514,16 @@
(aset nv i (f (aref v i))))) (aset nv i (f (aref v i)))))
nv)) nv))
(defun table.pairs (t) (define (table.pairs t)
(table.foldl (lambda (k v z) (cons (cons k v) z)) (table.foldl (lambda (k v z) (cons (cons k v) z))
() t)) () t))
(defun table.keys (t) (define (table.keys t)
(table.foldl (lambda (k v z) (cons k z)) (table.foldl (lambda (k v z) (cons k z))
() t)) () t))
(defun table.values (t) (define (table.values t)
(table.foldl (lambda (k v z) (cons v z)) (table.foldl (lambda (k v z) (cons v z))
() t)) () t))
(defun 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)

8
femtolisp/table.c
View File

@ -70,8 +70,8 @@ int ishashtable(value_t v)
value_t fl_tablep(value_t *args, uint32_t nargs) value_t fl_tablep(value_t *args, uint32_t nargs)
{ {
argcount("tablep", nargs, 1); argcount("table?", nargs, 1);
return ishashtable(args[0]) ? T : NIL; return ishashtable(args[0]) ? FL_T : FL_F;
} }
static htable_t *totable(value_t v, char *fname) static htable_t *totable(value_t v, char *fname)
@ -139,7 +139,7 @@ value_t fl_table_has(value_t *args, uint32_t nargs)
{ {
argcount("has", nargs, 2); argcount("has", nargs, 2);
htable_t *h = totable(args[0], "has"); htable_t *h = totable(args[0], "has");
return equalhash_has(h, (void*)args[1]) ? T : NIL; return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F;
} }
// (del table key) // (del table key)
@ -177,7 +177,7 @@ 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 },
{ "tablep", 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 },

7
femtolisp/tcolor.lsp
View File

@ -1,11 +1,12 @@
; -*- scheme -*-
; color for performance ; color for performance
(load "color.lsp") (load "color.lsp")
; 100x color 5 queens ; 100x color 5 queens
(setq Q (generate-5x5-pairs)) (define Q (generate-5x5-pairs))
(defun ct () (define (ct)
(setq C (color-pairs Q '(a b c d e))) (set! C (color-pairs Q '(a b c d e)))
(dotimes (n 99) (color-pairs Q '(a b c d e)))) (dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct)) (time (ct))
(assert (equal C '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) (assert (equal C '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)

141
femtolisp/test.lsp
View File

@ -1,15 +1,17 @@
; -*- scheme -*-
; make label self-evaluating, but evaluating the lambda in the process ; make label self-evaluating, but evaluating the lambda in the process
;(defmacro labl (name f) ;(defmacro labl (name f)
; (list list ''labl (list 'quote name) f)) ; (list list ''labl (list 'quote name) f))
(defmacro labl (name f) (define-macro (labl name f)
`(let (,name) (setq ,name ,f))) `(let (,name) (set! ,name ,f)))
;(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 nil)) ; lst ()))
(define (append- . lsts) (define (append- . lsts)
((label append-h ((label append-h
@ -28,20 +30,20 @@
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;(princ (time (fib 34)) "\n") ;(princ (time (fib 34)) "\n")
;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8)) ;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
;(dotimes (i 40000) (append '(a b) '(1 2 3 4) nil '(c) nil '(5 6))) ;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
;(dotimes (i 80000) (list 1 2 3 4 5)) ;(dotimes (i 80000) (list 1 2 3 4 5))
;(setq a (map-int identity 10000)) ;(set! a (map-int identity 10000))
;(dotimes (i 200) (rfoldl cons nil a)) ;(dotimes (i 200) (rfoldl cons () a))
; iterative filter ; iterative filter
(defun 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))))))
nil lst)) () lst))
(defun 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))))
@ -49,29 +51,29 @@
(list piv) (list piv)
(sort (cdr halves)))))) (sort (cdr halves))))))
(defmacro dotimes (var . body) (define-macro (dotimes var . body)
(let ((v (car var)) (let ((v (car var))
(cnt (cadr var))) (cnt (cadr var)))
`(let ((,v 0)) `(let ((,v 0))
(while (< ,v ,cnt) (while (< ,v ,cnt)
(prog1 (prog1
,(f-body body) ,(f-body body)
(setq ,v (+ ,v 1))))))) (set! ,v (+ ,v 1)))))))
(defun map-int (f n) (define (map-int f n)
(if (<= n 0) (if (<= n 0)
() ()
(let ((first (cons (f 0) nil))) (let ((first (cons (f 0) ())))
((label map-int- ((label map-int-
(lambda (acc i n) (lambda (acc i n)
(if (= i n) (if (= i n)
first first
(progn (rplacd acc (cons (f i) nil)) (begin (rplacd acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n))))) (map-int- (cdr acc) (+ i 1) n)))))
first 1 n)))) first 1 n))))
(defmacro labl (name fn) (define-macro (labl name fn)
`((lambda (,name) (setq ,name ,fn)) nil)) `((lambda (,name) (set! ,name ,fn)) ()))
(define (square x) (* x x)) (define (square x) (* x x))
(define (evenp x) (= x (* (/ x 2) 2))) (define (evenp x) (= x (* (/ x 2) 2)))
@ -88,43 +90,43 @@
(T (gcd b (- a b))))) (T (gcd b (- a b)))))
; like eval-when-compile ; like eval-when-compile
(defmacro literal (expr) (define-macro (literal expr)
(let ((v (eval expr))) (let ((v (eval expr)))
(if (self-evaluating-p v) v (list quote v)))) (if (self-evaluating? v) v (list quote v))))
(defun cardepth (l) (define (cardepth l)
(if (atom l) 0 (if (atom l) 0
(+ 1 (cardepth (car l))))) (+ 1 (cardepth (car l)))))
(defun nestlist (f zero n) (define (nestlist f zero n)
(if (<= n 0) () (if (<= n 0) ()
(cons zero (nestlist f (f zero) (- n 1))))) (cons zero (nestlist f (f zero) (- n 1)))))
(defun mapl (f . lsts) (define (mapl f . lsts)
((label mapl- ((label mapl-
(lambda (lsts) (lambda (lsts)
(if (null (car lsts)) () (if (null (car lsts)) ()
(progn (apply f lsts) (mapl- (map cdr lsts)))))) (begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts)) lsts))
; test to see if a symbol begins with : ; test to see if a symbol begins with :
(defun keywordp (s) (define (keywordp s)
(and (>= s '|:|) (<= s '|:~|))) (and (>= s '|:|) (<= s '|:~|)))
; swap the cars and cdrs of every cons in a structure ; swap the cars and cdrs of every cons in a structure
(defun 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)))))))
(defun without (x l) (define (without x l)
(filter (lambda (e) (not (eq e x))) l)) (filter (lambda (e) (not (eq e x))) l))
(defun conscount (c) (define (conscount c)
(if (consp c) (+ 1 (if (consp c) (+ 1
(conscount (car c)) (conscount (car c))
(conscount (cdr c))) (conscount (cdr c)))
0)) 0))
; _ Welcome to ; _ Welcome to
; (_ _ _ |_ _ | . _ _ 2 ; (_ _ _ |_ _ | . _ _ 2
@ -135,12 +137,12 @@
;| (/_||||_()|_|_\|) ;| (/_||||_()|_|_\|)
; | ; |
(defmacro while- (test . forms) (define-macro (while- test . forms)
`((label -loop- (lambda () `((label -loop- (lambda ()
(if ,test (if ,test
(progn ,@forms (begin ,@forms
(-loop-)) (-loop-))
nil))))) ())))))
; this would be a cool use of thunking to handle 'finally' clauses, but ; this would be a cool use of thunking to handle 'finally' clauses, but
; this code doesn't work in the case where the user manually re-raises ; this code doesn't work in the case where the user manually re-raises
@ -150,8 +152,8 @@
; (catch (TypeError e) . exprs) ; (catch (TypeError e) . exprs)
; (catch (IOError e) . exprs) ; (catch (IOError e) . exprs)
; (finally . exprs)) ; (finally . exprs))
(defmacro try (expr . forms) (define-macro (try expr . forms)
(let ((final (f-body (cdr (or (assoc 'finally forms) '(()))))) (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
(body (foldr (body (foldr
; create a function to check for and handle one exception ; create a function to check for and handle one exception
; type, and pass off control to the next when no match ; type, and pass off control to the next when no match
@ -167,7 +169,7 @@
(,next ,var))))) (,next ,var)))))
; default function; no matches so re-raise ; default function; no matches so re-raise
'(lambda (e) (progn (*_try_finally_thunk_*) (raise e))) '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
; make list of catch forms ; make list of catch forms
(filter (lambda (f) (eq (car f) 'catch)) forms)))) (filter (lambda (f) (eq (car f) 'catch)) forms))))
@ -175,10 +177,6 @@
(prog1 (attempt ,expr ,body) (prog1 (attempt ,expr ,body)
(*_try_finally_thunk_*))))) (*_try_finally_thunk_*)))))
(defun map (f lst)
(if (atom lst) lst
(cons (funcall f (car lst)) (map f (cdr lst)))))
(define Y (define Y
(lambda (f) (lambda (f)
((lambda (h) ((lambda (h)
@ -191,56 +189,39 @@
(lambda (n) (lambda (n)
(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))))) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
(defmacro debug ()
(let ((g (gensym)))
`(progn (princ "Debug REPL:\n")
(let ((,g (read)))
(while (not (eq ,g 'quit))
(prog1
(print (trycatch (apply '(macro x x) ,g)
identity))
(setq ,g (read))))))))
;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) ))) ;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
;(tt) ;(tt)
;(tt) ;(tt)
;(tt) ;(tt)
(let ((g (gensym))) (define-macro (accumulate-while cnd what . body)
(defmacro delay (expr)
`(let ((,g ',g))
(lambda () (if (eq ,g ',g) (setq ,g ,expr) ,g)))))
(defun force (p) (p))
(defmacro accumulate-while (cnd what . body)
(let ((first (gensym)) (let ((first (gensym))
(acc (gensym))) (acc (gensym)))
`(let ((,first nil) `(let ((,first ())
(,acc (list nil))) (,acc (list ())))
(setq ,first ,acc) (set! ,first ,acc)
(while ,cnd (while ,cnd
(progn (setq ,acc (begin (set! ,acc
(cdr (rplacd ,acc (cons ,what nil)))) (cdr (rplacd ,acc (cons ,what ()))))
,@body)) ,@body))
(cdr ,first)))) (cdr ,first))))
(defmacro accumulate-for (var lo hi what . body) (define-macro (accumulate-for var lo hi what . body)
(let ((first (gensym)) (let ((first (gensym))
(acc (gensym))) (acc (gensym)))
`(let ((,first nil) `(let ((,first ())
(,acc (list nil))) (,acc (list ())))
(setq ,first ,acc) (set! ,first ,acc)
(for ,lo ,hi (for ,lo ,hi
(lambda (,var) (lambda (,var)
(progn (setq ,acc (begin (set! ,acc
(cdr (rplacd ,acc (cons ,what nil)))) (cdr (rplacd ,acc (cons ,what ()))))
,@body))) ,@body)))
(cdr ,first)))) (cdr ,first))))
(defun 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 (consp lst) (f (car lst) i)
(progn (setq lst (cdr lst)) (begin (set! lst (cdr lst))
(setq i (1+ i))))))) (set! i (1+ i)))))))

31
femtolisp/torus.lsp
View File

@ -1,4 +1,5 @@
(defun maplist (f l) ; -*- scheme -*-
(define (maplist f l)
(if (null l) () (if (null l) ()
(cons (f l) (maplist f (cdr l))))) (cons (f l) (maplist f (cdr l)))))
@ -6,37 +7,37 @@
; make m copies of a CDR-circular list of length n, and connect corresponding ; make m copies of a CDR-circular list of length n, and connect corresponding
; conses in CAR-circular loops ; conses in CAR-circular loops
; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use ; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
(defun torus (m n) (define (torus m n)
(let* ((l (map-int identity n)) (let* ((l (map-int identity n))
(g l) (g l)
(prev g)) (prev g))
(dotimes (i (- m 1)) (dotimes (i (- m 1))
(setq prev g) (set! prev g)
(setq g (maplist identity g)) (set! g (maplist identity g))
(rplacd (last prev) prev)) (set-cdr! (last prev) prev))
(rplacd (last g) g) (set-cdr! (last g) g)
(let ((a l) (let ((a l)
(b g)) (b g))
(dotimes (i n) (dotimes (i n)
(rplaca a b) (set-car! a b)
(setq a (cdr a)) (set! a (cdr a))
(setq b (cdr b)))) (set! b (cdr b))))
l)) l))
(defun cyl (m n) (define (cyl m n)
(let* ((l (map-int identity n)) (let* ((l (map-int identity n))
(g l)) (g l))
(dotimes (i (- m 1)) (dotimes (i (- m 1))
(setq g (maplist identity g))) (set! g (maplist identity g)))
(let ((a l) (let ((a l)
(b g)) (b g))
(dotimes (i n) (dotimes (i n)
(rplaca a b) (set-car! a b)
(setq a (cdr a)) (set! a (cdr a))
(setq b (cdr b)))) (set! b (cdr b))))
l)) l))
(time (progn (print (torus 100 100)) nil)) (time (begin (print (torus 100 100)) ()))
;(time (dotimes (i 1) (load "100x100.lsp"))) ;(time (dotimes (i 1) (load "100x100.lsp")))
; with ltable ; with ltable
; printing time: 0.415sec ; printing time: 0.415sec

7
femtolisp/unittest.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
(define (every-int n) (define (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
(int64 n) (uint64 n))) (int64 n) (uint64 n)))
@ -7,7 +8,7 @@
(define (each f l) (define (each f l)
(if (atom l) () (if (atom l) ()
(progn (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)
@ -15,7 +16,7 @@
(define (test-lt a b) (define (test-lt a b)
(each^2 (lambda (neg pos) (each^2 (lambda (neg pos)
(progn (begin
(eval `(assert (= -1 (compare ,neg ,pos)))) (eval `(assert (= -1 (compare ,neg ,pos))))
(eval `(assert (= 1 (compare ,pos ,neg)))))) (eval `(assert (= 1 (compare ,pos ,neg))))))
a a
@ -23,7 +24,7 @@
(define (test-eq a b) (define (test-eq a b)
(each^2 (lambda (a b) (each^2 (lambda (a b)
(progn (begin
(eval `(assert (= 0 (compare ,a ,b)))))) (eval `(assert (= 0 (compare ,a ,b))))))
a a
b)) b))

10
femtolisp/wt.lsp
View File

@ -1,8 +1,8 @@
(setq i 0) (set! i 0)
(defmacro while- (test . forms) (define-macro (while- test . forms)
`((label -loop- (lambda () `((label -loop- (lambda ()
(if ,test (if ,test
(progn ,@forms (begin ,@forms
(-loop-)) (-loop-))
nil))))) nil)))))
(while (< i 10000000) (setq i (+ i 1))) (while (< i 10000000) (set! i (+ i 1)))

7
llt/int2str.c
View File

@ -4,9 +4,12 @@
char *int2str(char *dest, size_t n, long num, uint32_t base) char *int2str(char *dest, size_t n, long num, uint32_t base)
{ {
int i = n-1; int i = n-1;
int b = (int)base; int b = (int)base, neg = 0;
int neg = (num<0 ? 1 : 0);
char ch; char ch;
if (num < 0) {
num = -num;
neg = 1;
}
dest[i--] = '\0'; dest[i--] = '\0';
while (i >= 0) { while (i >= 0) {
ch = (char)(num % b); ch = (char)(num % b);