lassik
/
upscheme
1
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
(define (symconcat s1 s2)
@ -9,13 +10,13 @@
(cons item lst)))
(define (index-of item lst start)
(cond ((null lst) nil)
(cond ((null lst) #f)
((eq item (car lst)) start)
(T (index-of item (cdr lst) (+ start 1)))))
(define (each f l)
(if (null l) l
(progn (f (car l))
(begin (f (car l))
(each f (cdr l)))))
(define (maptree-pre f tr)
@ -136,19 +137,19 @@
env))))
; flatten op with any associativity
(defmacro flatten-all-op (op e)
(define-macro (flatten-all-op op e)
`(pattern-expand
(pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
(cons ',op (append l (cdr inner) r)))
,e))
(defmacro pattern-lambda (pat body)
(define-macro (pattern-lambda pat body)
(let* ((args (patargs pat))
(expander `(lambda ,args ,body)))
`(lambda (expr)
(let ((m (match ',pat expr)))
(if m
; 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))
nil)))))
#f)))))

25
femtolisp/ast/match.lsp
View File

@ -1,3 +1,4 @@
; -*- scheme -*-
; tree regular expression pattern matching
; by Jeff Bezanson
@ -41,12 +42,12 @@
(cond ((symbolp p)
(cond ((eq p '_) state)
(T
(let ((capt (assoc p state)))
(let ((capt (assq p state)))
(if capt
(and (equal expr (cdr capt)) state)
(cons (cons p expr) state))))))
((functionp p)
((function? p)
(and (p expr) state))
((consp p)
@ -56,7 +57,7 @@
(and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state)))
((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
(and (consp expr)
(equal (car p) (car expr))
@ -67,7 +68,7 @@
; match an alternation
(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)))
(or (and subma
(match-seq prest (cdr expr)
@ -81,7 +82,7 @@
; match generalized kleene star (try consuming min to max)
(define (match-star- p prest expr state var min max L sofar)
(cond ; case 0: impossible to match
((> min max) nil)
((> min max) #f)
; case 1: only allowed to match 0 subexpressions
((= max 0) (match-seq prest expr
(if var (cons (cons var (reverse sofar)) state)
@ -101,16 +102,16 @@
; match sequences of expressions
(define (match-seq p expr state L)
(cond ((not state) nil)
((null p) (if (null expr) state nil))
(cond ((not state) #f)
((null p) (if (null expr) state #f))
(T
(let ((subp (car p))
(var nil))
(var #f))
(if (and (consp subp)
(eq (car subp) '--))
(progn (setq var (cadr subp))
(setq subp (caddr subp)))
nil)
(begin (set! var (cadr subp))
(set! subp (caddr subp)))
#f)
(let ((head (if (consp subp) (car subp) ())))
(cond ((eq subp '...)
(match-star '_ (cdr p) expr state var 0 L L))
@ -149,7 +150,7 @@
; returns the new expression, or expr if no matches
(define (apply-patterns plist expr)
(if (null plist) expr
(if (functionp plist)
(if (function? plist)
(let ((enew (plist expr)))
(if (not enew)
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 "asttools.lsp")
@ -18,10 +19,14 @@
; transformations
(let ((ctr 0))
(define (r-gensym) (prog1 (intern (string "%r:" ctr))
(set! ctr (+ ctr 1)))))
(define (dollarsign-transform e)
(pattern-expand
(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)
name ;(symbol->string name)
name))
@ -41,7 +46,7 @@
(pattern-expand
(pattern-lambda (-$ (<- (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 __)))
`(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
@ -77,9 +82,9 @@
(let ((vars ()))
(maptree-pre (lambda (s)
(if (not (consp s)) s
(cond ((eq (car s) 'lambda) nil)
(cond ((eq (car s) 'lambda) ())
((eq (car s) '<-)
(setq vars (list-adjoin (cadr s) vars))
(set! vars (list-adjoin (cadr s) vars))
(cddr s))
(T s))))
n)
@ -102,18 +107,3 @@
(fancy-assignment-transform
(dollarsign-transform
(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]));
}
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;
value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{
argcount("set-syntax", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-syntax");
argcount("set-syntax!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-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]));
if (args[1] == NIL) {
if (args[1] == FL_F) {
sym->syntax = 0;
}
else {
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];
}
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
// from the form rather than from the stack of evaluated arguments)
if (sym->syntax == TAG_CONST || isspecial(sym->syntax))
return NIL;
return FL_F;
return sym->syntax;
}
@ -160,15 +171,15 @@ extern value_t QUOTE;
value_t fl_constantp(value_t *args, u_int32_t nargs)
{
argcount("constantp", nargs, 1);
argcount("constant?", nargs, 1);
if (issymbol(args[0]))
return (isconstant(args[0]) ? T : NIL);
return (isconstant(args[0]) ? FL_T : FL_F);
if (iscons(args[0])) {
if (car_(args[0]) == QUOTE)
return T;
return NIL;
return FL_T;
return FL_F;
}
return T;
return FL_T;
}
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");
if (set_cwd(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)
@ -286,7 +297,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs)
argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv");
char *val = getenv(name);
if (val == NULL) return NIL;
if (val == NULL) return FL_F;
if (*val == 0)
return symbol_value(emptystringsym);
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);
char *name = tostring(args[0], "os.setenv");
int result;
if (args[1] == NIL) {
if (args[1] == FL_F) {
result = unsetenv(name);
}
else {
@ -306,7 +317,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
}
if (result != 0)
lerror(ArgError, "os.setenv: invalid environment variable");
return T;
return FL_T;
}
value_t fl_rand(value_t *args, u_int32_t nargs)
@ -351,11 +362,12 @@ extern void stringfuncs_init();
extern void table_init();
static builtinspec_t builtin_info[] = {
{ "set-syntax", fl_setsyntax },
{ "set-constant!", fl_setconstant },
{ "set-syntax!", fl_setsyntax },
{ "symbol-syntax", fl_symbolsyntax },
{ "syntax-environment", fl_syntax_env },
{ "environment", fl_global_env },
{ "constantp", fl_constantp },
{ "constant?", fl_constantp },
{ "print", fl_print },
{ "princ", fl_princ },

25
femtolisp/color.lsp
View File

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

90
femtolisp/cps.lsp
View File

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

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)
{
if (eq_comparable(a, b))
return (a == b) ? T : NIL;
return (numval(compare_(a,b,1))==0 ? T : NIL);
return (a == b) ? FL_T : FL_F;
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
* constructor notation for nicely printing arbitrary values
* strings
- hash tables
* hash tables
by Jeff Bezanson (C) 2009
Distributed under the BSD License
@ -52,27 +52,28 @@
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "setq", "progn",
"trycatch", "%apply", "set!", "begin",
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
"builtinp", "vectorp", "fixnump", "equal",
"cons", "list", "car", "cdr", "rplaca", "rplacd",
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
"number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
"eval", "eval*", "apply", "prog1", "raise",
"+", "-", "*", "/", "<", "~", "&", "!", "$",
"vector", "aref", "aset", "length", "assoc", "compare",
"for" };
"vector", "aref", "aset", "length", "assq", "compare", "for",
"", "", "" };
#define N_STACK 98304
value_t Stack[N_STACK];
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 IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
value_t defunsym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym;
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
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 *alloc_words(int n);
@ -592,7 +593,7 @@ int isnumber(value_t v)
// eval -----------------------------------------------------------------------
// 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;
@ -602,7 +603,7 @@ static value_t assoc(value_t item, value_t v)
return bind;
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 {
v = cdr_(Stack[SP-1]);
if (!iscons(v)) {
v = NIL; // 1-argument form
v = FL_F; // 1-argument form
}
else {
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;
pv = &vector_elt(*pv, 0);
}
sym = tosymbol(e, "setq");
sym = tosymbol(e, "set!");
if (sym->syntax != TAG_CONST)
sym->binding = v;
break;
@ -809,24 +810,28 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_IF:
if (!iscons(Stack[saveSP])) goto notpair;
v = car_(Stack[saveSP]);
if (eval(v) != NIL) {
if (eval(v) != FL_F) {
v = cdr_(Stack[saveSP]);
if (!iscons(v)) goto notpair;
v = car_(v);
}
else {
v = cdr_(Stack[saveSP]);
if (!iscons(v) || !iscons(v=cdr_(v))) goto notpair;
v = car_(v);
if (!iscons(v)) goto notpair;
if (!iscons(v=cdr_(v))) v = FL_F; // allow 2-arg form
else v = car_(v);
}
tail_eval(v);
break;
case F_COND:
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP]; v = FL_F;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car);
if (v != NIL) {
v = c->car;
// allow last condition to be 'else'
if (iscons(cdr_(*pv)) || v != elsesym)
v = eval(v);
if (v != FL_F) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
@ -842,11 +847,11 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
}
break;
case F_AND:
pv = &Stack[saveSP]; v = T;
pv = &Stack[saveSP]; v = FL_T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) == NIL) {
SP = saveSP; return NIL;
if ((v=eval(car_(*pv))) == FL_F) {
SP = saveSP; return FL_F;
}
*pv = cdr_(*pv);
}
@ -854,10 +859,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
}
break;
case F_OR:
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP]; v = FL_F;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv))) != NIL) {
if ((v=eval(car_(*pv))) != FL_F) {
SP = saveSP; return v;
}
*pv = cdr_(*pv);
@ -871,9 +876,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
PUSH(*body);
Stack[saveSP] = car_(Stack[saveSP]);
value_t *cond = &Stack[saveSP];
PUSH(NIL);
PUSH(FL_F);
pv = &Stack[SP-1];
while (eval(*cond) != NIL) {
while (eval(*cond) != FL_F) {
*body = Stack[SP-2];
while (iscons(*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));
}
v = NIL;
v = FL_F;
break;
case F_TRYCATCH:
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
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
v = (sym->binding == UNBOUND) ? NIL : T;
argcount("bound?", nargs, 1);
sym = tosymbol(Stack[SP-1], "bound?");
v = (sym->binding == UNBOUND) ? FL_F : FL_T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
argcount("eq?", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
break;
case F_CONS:
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;
v = cdr_(v);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
case F_SETCAR:
argcount("set-car!", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
case F_SETCDR:
argcount("set-cdr!", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_VECTOR:
@ -1015,36 +1020,47 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
}
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
argcount("atom?", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? FL_T : FL_F);
break;
case F_CONSP:
argcount("consp", nargs, 1);
v = (iscons(Stack[SP-1]) ? T : NIL);
argcount("pair?", nargs, 1);
v = (iscons(Stack[SP-1]) ? FL_T : FL_F);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
argcount("symbol?", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? FL_T : FL_F);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL);
argcount("number?", nargs, 1);
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? FL_T : FL_F);
break;
case F_FIXNUMP:
argcount("fixnump", nargs, 1);
v = (isfixnum(Stack[SP-1]) ? T : NIL);
argcount("fixnum?", nargs, 1);
v = (isfixnum(Stack[SP-1]) ? FL_T : FL_F);
break;
case F_BUILTINP:
argcount("builtinp", nargs, 1);
v = (isbuiltinish(Stack[SP-1]) ? T : NIL);
argcount("builtin?", nargs, 1);
v = Stack[SP-1];
v = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL)
? FL_T : FL_F);
break;
case F_VECTORP:
argcount("vectorp", nargs, 1);
v = ((isvector(Stack[SP-1])) ? T : NIL);
argcount("vector?", nargs, 1);
v = ((isvector(Stack[SP-1])) ? FL_T : FL_F);
break;
case F_NOT:
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;
case F_ADD:
s = 0;
@ -1157,19 +1173,37 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_LT:
argcount("<", nargs, 2);
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 {
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_EQUAL:
argcount("equal", nargs, 2);
if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
argcount("equal?", nargs, 2);
if (Stack[SP-2] == Stack[SP-1]) {
v = FL_T;
}
else if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
v = FL_F;
}
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;
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");
v = Stack[saveSP+1];
break;
case F_ASSOC:
argcount("assoc", nargs, 2);
v = assoc(Stack[SP-2], Stack[SP-1]);
case F_ASSQ:
argcount("assq", nargs, 2);
v = assq(Stack[SP-2], Stack[SP-1]);
break;
case F_FOR:
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
Stack[SP-4] = fixnum(3); // env size
Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = NIL;
v = FL_F;
for(s=lo; s <= hi; s++) {
f = Stack[SP-5];
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;
goto apply_lambda;
case F_TRUE:
case F_FALSE:
case F_NIL:
goto apply_type_error;
default:
// function pointer tagged as a builtin
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
}
apply_type_error:
type_error("apply", "function", f);
notpair:
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 comparehash_init();
static char *EXEDIR;
static char *EXEDIR = NULL;
void assign_global_builtins(builtinspec_t *b)
{
@ -1393,8 +1432,9 @@ void lisp_init(void)
htable_new(&printconses, 32);
comparehash_init();
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("T"); setc(T, T);
NIL = builtin(F_NIL);
FL_T = builtin(F_TRUE);
FL_F = builtin(F_FALSE);
LAMBDA = symbol("lambda");
QUOTE = symbol("quote");
TRYCATCH = symbol("trycatch");
@ -1417,12 +1457,17 @@ void lisp_init(void)
fixnumsym = symbol("fixnum");
vectorsym = symbol("vector");
builtinsym = symbol("builtin");
defunsym = symbol("defun");
defmacrosym = symbol("defmacro");
booleansym = symbol("boolean");
nullsym = symbol("null");
definesym = symbol("define");
defmacrosym = symbol("define-macro");
forsym = symbol("for");
labelsym = symbol("label");
setqsym = symbol("setq");
set(printprettysym=symbol("*print-pretty*"), T);
setqsym = symbol("set!");
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));
lasterror = NIL;
lerrorbuf[0] = '\0';
@ -1433,7 +1478,7 @@ void lisp_init(void)
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++;
}
for (; i < N_BUILTINS; i++) {
for (; i < F_TRUE; i++) {
setc(symbol(builtin_names[i]), builtin(i));
}
@ -1559,6 +1604,7 @@ int locale_is_utf8;
int main(int argc, char *argv[])
{
value_t v;
char fname_buf[1024];
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;
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; }
printf("; _ \n");
printf("; |_ _ _ |_ _ | . _ _\n");

15
femtolisp/flisp.h
View File

@ -103,18 +103,21 @@ enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN,
// functions
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,
F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL,
F_CONS, F_LIST, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP,
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
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_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR,
N_BUILTINS
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_COMPARE, F_FOR,
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
};
#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 */
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))
(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))
(princ "mexpand: ")
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
(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)))
(path.cwd "ast")
(princ "p-lambda: ")
(load "rpasses.lsp")
(define *input* (load "datetimeR.lsp"))
(time (set! *output* (compile-ish *input*)))
(assert (equal *output* (load "rpasses-out.lsp")))
(path.cwd "..")

2
femtolisp/pisum.lsp
View File

@ -1,4 +1,4 @@
(defun pisum ()
(define (pisum)
(dotimes (j 500)
((label sumloop
(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)
{
// 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)
return 2;
return -1;
@ -200,7 +200,13 @@ static int allsmallp(value_t v)
static int indentafter3(value_t head, value_t v)
{
// 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)));
}
@ -251,6 +257,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
if (!blk) always = indentevery(v);
value_t head = car_(v);
int after3 = indentafter3(head, v);
int after2 = indentafter2(head, v);
int n_unindented = 1;
while (1) {
lastv = VPOS;
@ -287,6 +294,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
(n > 0 && always) ||
(n == 2 && after3) ||
(n == 1 && after2) ||
(n_unindented >= 3 && !nextsmall) ||
@ -328,8 +336,6 @@ void fl_print_child(ios_t *f, value_t v, int princ)
name = symbol_name(v);
if (princ)
outs(name, f);
else if (v == NIL)
outs("()", f);
else if (ismanaged(v)) {
outs("#:", 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);
break;
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)) {
outs("#.", 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)
{
print_pretty = (symbol_value(printprettysym) != NIL);
print_pretty = (symbol_value(printprettysym) != FL_F);
if (print_pretty)
set_print_width();
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);
toktype = TOK_SHARPSYM;
tokval = symbol(buf);
c = nextchar(f);
if (c != '(') {
take();
lerror(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
}
}
else {
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 *pv;
u_int32_t t;
char c;
t = peek(f);
take();
@ -511,8 +506,18 @@ static value_t do_read_sexpr(ios_t *f, value_t label)
read_list(f, &Stack[SP-1], label);
return POP();
case TOK_SHARPSYM:
// constructor notation
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);
read_list(f, &Stack[SP-1], UNBOUND);
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)
{
argcount("streamp", nargs, 1);
return isstream(args[0]) ? T : NIL;
argcount("stream?", nargs, 1);
return isstream(args[0]) ? FL_T : FL_F;
}
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[] = {
{ "streamp", fl_streamp },
{ "stream?", fl_streamp },
{ 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)
{
argcount("stringp", nargs, 1);
return isstring(args[0]) ? T : NIL;
argcount("string?", nargs, 1);
return isstring(args[0]) ? FL_T : FL_F;
}
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;
if (nargs == 2) {
term = (POP() != NIL);
term = (POP() != FL_F);
nargs--;
}
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);
if (p == NULL)
return NIL;
return FL_F;
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]);
}
if (needlesz > len-start)
return NIL;
return FL_F;
else if (needlesz == 1)
return mem_find_byte(s, needle[0], start, len);
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 NIL;
return FL_F;
}
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[] = {
{ "string", fl_string },
{ "stringp", fl_stringp },
{ "string?", fl_stringp },
{ "string.length", fl_string_length },
{ "string.split", fl_string_split },
{ "string.sub", fl_string_sub },

363
femtolisp/system.lsp
View File

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

7
femtolisp/tcolor.lsp
View File

@ -1,11 +1,12 @@
; -*- scheme -*-
; color for performance
(load "color.lsp")
; 100x color 5 queens
(setq Q (generate-5x5-pairs))
(defun ct ()
(setq C (color-pairs Q '(a b c d e)))
(define Q (generate-5x5-pairs))
(define (ct)
(set! C (color-pairs Q '(a b c d e)))
(dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct))
(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
;(defmacro labl (name f)
; (list list ''labl (list 'quote name) f))
(defmacro labl (name f)
`(let (,name) (setq ,name ,f)))
(define-macro (labl name f)
`(let (,name) (set! ,name ,f)))
;(define (reverse lst)
; ((label rev-help (lambda (lst result)
; (if (null lst) result
; (rev-help (cdr lst) (cons (car lst) result)))))
; lst nil))
; lst ()))
(define (append- . lsts)
((label append-h
@ -28,20 +30,20 @@
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;(princ (time (fib 34)) "\n")
;(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))
;(setq a (map-int identity 10000))
;(dotimes (i 200) (rfoldl cons nil a))
;(set! a (map-int identity 10000))
;(dotimes (i 200) (rfoldl cons () a))
; iterative filter
(defun ifilter (pred lst)
(define (ifilter pred lst)
((label f (lambda (accum lst)
(cond ((null lst) (nreverse accum))
((not (pred (car lst))) (f 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
(let* ((piv (car l))
(halves (separate (lambda (x) (< x piv)) (cdr l))))
@ -49,29 +51,29 @@
(list piv)
(sort (cdr halves))))))
(defmacro dotimes (var . body)
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(let ((,v 0))
(while (< ,v ,cnt)
(prog1
,(f-body body)
(setq ,v (+ ,v 1)))))))
(set! ,v (+ ,v 1)))))))
(defun map-int (f n)
(define (map-int f n)
(if (<= n 0)
()
(let ((first (cons (f 0) nil)))
((label map-int-
(lambda (acc i n)
(if (= i n)
first
(progn (rplacd acc (cons (f i) nil))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
(let ((first (cons (f 0) ())))
((label map-int-
(lambda (acc i n)
(if (= i n)
first
(begin (rplacd acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
(defmacro labl (name fn)
`((lambda (,name) (setq ,name ,fn)) nil))
(define-macro (labl name fn)
`((lambda (,name) (set! ,name ,fn)) ()))
(define (square x) (* x x))
(define (evenp x) (= x (* (/ x 2) 2)))
@ -88,43 +90,43 @@
(T (gcd b (- a b)))))
; like eval-when-compile
(defmacro literal (expr)
(define-macro (literal 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
(+ 1 (cardepth (car l)))))
(+ 1 (cardepth (car l)))))
(defun nestlist (f zero n)
(define (nestlist f zero n)
(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-
(lambda (lsts)
(if (null (car lsts)) ()
(progn (apply f lsts) (mapl- (map cdr lsts))))))
(begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts))
; test to see if a symbol begins with :
(defun keywordp (s)
(define (keywordp s)
(and (>= s '|:|) (<= s '|:~|)))
; swap the cars and cdrs of every cons in a structure
(defun swapad (c)
(define (swapad c)
(if (atom c) c
(rplacd c (K (swapad (car c))
(rplaca c (swapad (cdr c)))))))
(rplacd c (K (swapad (car c))
(rplaca c (swapad (cdr c)))))))
(defun without (x l)
(define (without x l)
(filter (lambda (e) (not (eq e x))) l))
(defun conscount (c)
(define (conscount c)
(if (consp c) (+ 1
(conscount (car c))
(conscount (cdr c)))
0))
0))
; _ Welcome to
; (_ _ _ |_ _ | . _ _ 2
@ -135,12 +137,12 @@
;| (/_||||_()|_|_\|)
; |
(defmacro while- (test . forms)
(define-macro (while- test . forms)
`((label -loop- (lambda ()
(if ,test
(progn ,@forms
(begin ,@forms
(-loop-))
nil)))))
())))))
; 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
@ -150,8 +152,8 @@
; (catch (TypeError e) . exprs)
; (catch (IOError e) . exprs)
; (finally . exprs))
(defmacro try (expr . forms)
(let ((final (f-body (cdr (or (assoc 'finally forms) '(())))))
(define-macro (try expr . forms)
(let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
(body (foldr
; create a function to check for and handle one exception
; type, and pass off control to the next when no match
@ -167,7 +169,7 @@
(,next ,var)))))
; 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
(filter (lambda (f) (eq (car f) 'catch)) forms))))
@ -175,10 +177,6 @@
(prog1 (attempt ,expr ,body)
(*_try_finally_thunk_*)))))
(defun map (f lst)
(if (atom lst) lst
(cons (funcall f (car lst)) (map f (cdr lst)))))
(define Y
(lambda (f)
((lambda (h)
@ -191,56 +189,39 @@
(lambda (n)
(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) )))
;(tt)
;(tt)
;(tt)
(let ((g (gensym)))
(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)
(define-macro (accumulate-while cnd what . body)
(let ((first (gensym))
(acc (gensym)))
`(let ((,first nil)
(,acc (list nil)))
(setq ,first ,acc)
`(let ((,first ())
(,acc (list ())))
(set! ,first ,acc)
(while ,cnd
(progn (setq ,acc
(cdr (rplacd ,acc (cons ,what nil))))
,@body))
(begin (set! ,acc
(cdr (rplacd ,acc (cons ,what ()))))
,@body))
(cdr ,first))))
(defmacro accumulate-for (var lo hi what . body)
(define-macro (accumulate-for var lo hi what . body)
(let ((first (gensym))
(acc (gensym)))
`(let ((,first nil)
(,acc (list nil)))
(setq ,first ,acc)
`(let ((,first ())
(,acc (list ())))
(set! ,first ,acc)
(for ,lo ,hi
(lambda (,var)
(progn (setq ,acc
(cdr (rplacd ,acc (cons ,what nil))))
(begin (set! ,acc
(cdr (rplacd ,acc (cons ,what ()))))
,@body)))
(cdr ,first))))
(defun map-indexed (f lst)
(define (map-indexed f lst)
(if (atom lst) lst
(let ((i 0))
(accumulate-while (consp lst) (f (car lst) i)
(progn (setq lst (cdr lst))
(setq i (1+ i)))))))
(begin (set! lst (cdr lst))
(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) ()
(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
; conses in CAR-circular loops
; 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))
(g l)
(prev g))
(dotimes (i (- m 1))
(setq prev g)
(setq g (maplist identity g))
(rplacd (last prev) prev))
(rplacd (last g) g)
(set! prev g)
(set! g (maplist identity g))
(set-cdr! (last prev) prev))
(set-cdr! (last g) g)
(let ((a l)
(b g))
(dotimes (i n)
(rplaca a b)
(setq a (cdr a))
(setq b (cdr b))))
(set-car! a b)
(set! a (cdr a))
(set! b (cdr b))))
l))
(defun cyl (m n)
(define (cyl m n)
(let* ((l (map-int identity n))
(g l))
(dotimes (i (- m 1))
(setq g (maplist identity g)))
(set! g (maplist identity g)))
(let ((a l)
(b g))
(dotimes (i n)
(rplaca a b)
(setq a (cdr a))
(setq b (cdr b))))
(set-car! a b)
(set! a (cdr a))
(set! b (cdr b))))
l))
(time (progn (print (torus 100 100)) nil))
(time (begin (print (torus 100 100)) ()))
;(time (dotimes (i 1) (load "100x100.lsp")))
; with ltable
; printing time: 0.415sec

7
femtolisp/unittest.lsp
View File

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

10
femtolisp/wt.lsp
View File

@ -1,8 +1,8 @@
(setq i 0)
(defmacro while- (test . forms)
(set! i 0)
(define-macro (while- test . forms)
`((label -loop- (lambda ()
(if ,test
(progn ,@forms
(begin ,@forms
(-loop-))
nil)))))
(while (< i 10000000) (setq i (+ i 1)))
nil)))))
(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)
{
int i = n-1;
int b = (int)base;
int neg = (num<0 ? 1 : 0);
int b = (int)base, neg = 0;
char ch;
if (num < 0) {
num = -num;
neg = 1;
}
dest[i--] = '\0';
while (i >= 0) {
ch = (char)(num % b);