ref: 0c9010a117357e14ef92c79e9b892af9202327be
parent: 1f81d56b897746fc8af241f0df38495718b798e5
author: JeffBezanson <[email protected]>
date: Mon Jun 30 21:54:22 EDT 2008
import femtolisp source
--- /dev/null
+++ b/femtolisp/100x100.lsp
@@ -1,0 +1,1 @@
+'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- /dev/null
+++ b/femtolisp/Makefile
@@ -1,0 +1,41 @@
+CC = gcc
+
+NAME = flisp
+SRCS = $(NAME).c builtins.c equal.c
+OBJS = $(SRCS:%.c=%.o)
+DOBJS = $(SRCS:%.c=%.do)
+EXENAME = $(NAME)
+LLT = llt/libllt.a
+
+FLAGS = -Wall -Wextra -Wno-strict-aliasing -I./llt $(CFLAGS)
+LIBS = $(LLT) -lm
+
+DEBUGFLAGS = -g -DDEBUG $(FLAGS)
+SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer $(FLAGS)
+
+default: release test
+
+test:
+ ./flisp unittest.lsp
+
+%.o: %.c
+ $(CC) $(SHIPFLAGS) -c $< -o $@
+%.do: %.c
+ $(CC) $(DEBUGFLAGS) -c $< -o $@
+
+flisp.o: flisp.c cvalues.c flisp.h print.c read.c
+flisp.do: flisp.c cvalues.c flisp.h print.c read.c
+
+$(LLT):
+ cd llt && make
+
+debug: $(DOBJS) $(LIBS)
+ $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
+
+release: $(OBJS) $(LIBS)
+ $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
+
+clean:
+ rm -f *.o
+ rm -f *.do
+ rm -f $(EXENAME)
--- /dev/null
+++ b/femtolisp/ast/asttools.lsp
@@ -1,0 +1,97 @@
+; utilities for AST processing
+
+(define (symconcat s1 s2)
+ (intern (string s1 s2)))
+
+(define (list-adjoin item lst)
+ (if (member item lst)
+ lst
+ (cons item lst)))
+
+(define (index-of item lst start)
+ (cond ((null lst) nil)
+ ((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))
+ (each f (cdr l)))))
+
+(define (maptree-pre f tr)
+ (let ((new-t (f tr)))
+ (if (consp new-t)
+ (map (lambda (e) (maptree-pre f e)) new-t)
+ new-t)))
+
+(define (maptree-post f tr)
+ (if (not (consp tr))
+ (f tr)
+ (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
+ (f new-t))))
+
+; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
+(define (flatten-left-op op e)
+ (maptree-post (lambda (node)
+ (if (and (consp node)
+ (eq (car node) op)
+ (consp (cdr node))
+ (consp (cadr node))
+ (eq (caadr node) op))
+ (cons op
+ (append (cdadr node) (cddr node)))
+ node))
+ e))
+
+; convert all local variable references to (lexref rib slot name)
+; where rib is the nesting level and slot is the stack slot#
+; name is just there for reference
+; this assumes lambda is the only remaining naming form
+(define (lookup-var v env lev)
+ (if (null env) v
+ (let ((i (index-of v (car env) 0)))
+ (if i (list 'lexref lev i v)
+ (lookup-var v (cdr env) (+ lev 1))))))
+(define (lvc- e env)
+ (cond ((symbolp e) (lookup-var e env 0))
+ ((consp e)
+ (if (eq (car e) 'quote)
+ e
+ (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
+ (newenv (if newvs (cons newvs env) env)))
+ (if newvs
+ (cons 'lambda
+ (cons (cadr e)
+ (map (lambda (se) (lvc- se newenv))
+ (cddr e))))
+ (map (lambda (se) (lvc- se env)) e)))))
+ (T e)))
+(define (lexical-var-conversion e)
+ (lvc- e ()))
+
+; convert let to lambda
+(define (let-expand e)
+ (maptree-post (lambda (n)
+ (if (and (consp n) (eq (car n) 'let))
+ `((lambda ,(map car (cadr n)) ,@(cddr n))
+ ,@(map cadr (cadr n)))
+ n))
+ e))
+
+; flatten op with any associativity
+(defmacro 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)
+ (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))))
+ ',args))
+ nil)))))
--- /dev/null
+++ b/femtolisp/ast/asttools.scm
@@ -1,0 +1,88 @@
+; utilities for AST processing
+
+(define (symconcat s1 s2)
+ (string->symbol (string-append (symbol->string s1)
+ (symbol->string s2))))
+
+(define (list-adjoin item lst)
+ (if (memq item lst)
+ lst
+ (cons item lst)))
+
+(define (index-of item lst start)
+ (cond ((null? lst) #f)
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
+
+(define (map! f l)
+ (define (map!- f l start)
+ (if (pair? l)
+ (begin (set-car! l (f (car l)))
+ (map!- f (cdr l) start))
+ start))
+ (map!- f l l))
+
+(define (each f l)
+ (if (null? l) l
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (maptree-pre f t)
+ (let ((new-t (f t)))
+ (if (pair? new-t)
+ (map (lambda (e) (maptree-pre f e)) new-t)
+ new-t)))
+
+(define (maptree-post f t)
+ (if (not (pair? t))
+ (f t)
+ (let ((new-t (map (lambda (e) (maptree-post f e)) t)))
+ (f new-t))))
+
+; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
+(define (flatten-left-op op e)
+ (maptree-post (lambda (node)
+ (if (and (pair? node)
+ (eq? (car node) op)
+ (pair? (cdr node))
+ (pair? (cadr node))
+ (eq? (caadr node) op))
+ (cons op
+ (append (cdadr node) (cddr node)))
+ node))
+ e))
+
+; convert all local variable references to (lexref rib slot name)
+; where rib is the nesting level and slot is the stack slot#
+; name is just there for reference
+; this assumes lambda is the only remaining naming form
+(define (lexical-var-conversion e)
+ (define (lookup-var v env lev)
+ (if (null? env) v
+ (let ((i (index-of v (car env) 0)))
+ (if i (list 'lexref lev i v)
+ (lookup-var v (cdr env) (+ lev 1))))))
+ (define (lvc- e env)
+ (cond ((symbol? e) (lookup-var e env 0))
+ ((pair? e)
+ (if (eq? (car e) 'quote)
+ e
+ (let* ((newvs (and (eq? (car e) 'lambda) (cadr e)))
+ (newenv (if newvs (cons newvs env) env)))
+ (if newvs
+ (cons 'lambda
+ (cons (cadr e)
+ (map (lambda (se) (lvc- se newenv))
+ (cddr e))))
+ (map (lambda (se) (lvc- se env)) e)))))
+ (else e)))
+ (lvc- e ()))
+
+; convert let to lambda
+(define (let-expand e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq? (car n) 'let))
+ `((lambda ,(map car (cadr n)) ,@(cddr n))
+ ,@(map cadr (cadr n)))
+ n))
+ e))
--- /dev/null
+++ b/femtolisp/ast/match.lsp
@@ -1,0 +1,181 @@
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+(define (unique lst)
+ (if (null lst)
+ ()
+ (cons (car lst)
+ (filter (lambda (x) (not (eq x (car lst))))
+ (unique (cdr lst))))))
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbolp p)
+ (cond ((eq p '_) state)
+ (T
+ (let ((capt (assoc p state)))
+ (if capt
+ (and (equal expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((functionp p)
+ (and (p expr) state))
+
+ ((consp p)
+ (cond ((eq (car p) '-/) (and (equal (cadr p) expr) state))
+ ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq (car p) '--)
+ (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))
+ (T
+ (and (consp expr)
+ (equal (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (T
+ (and (equal p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null alt) nil ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) nil)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (T
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+(define (match-star p prest expr state var min max L)
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) nil)
+ ((null p) (if (null expr) state nil))
+ (T
+ (let ((subp (car p))
+ (var nil))
+ (if (and (consp subp)
+ (eq (car subp) '--))
+ (progn (setq var (cadr subp))
+ (setq subp (caddr subp)))
+ nil)
+ (let ((head (if (consp subp) (car subp) ())))
+ (cond ((eq subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (T
+ (and (consp expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs- p)
+ (cond ((and (symbolp p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((consp p)
+ (if (eq (car p) '-/)
+ ()
+ (unique (apply append (map patargs- (cdr p))))))
+
+ (T ())))
+(define (patargs p)
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null plist) expr
+ (if (functionp plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (consp expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/femtolisp/ast/match.scm
@@ -1,0 +1,181 @@
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+(define (unique lst)
+ (if (null? lst)
+ ()
+ (cons (car lst)
+ (filter (lambda (x) (not (eq? x (car lst))))
+ (unique (cdr lst))))))
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbol? p)
+ (cond ((eq? p '_) state)
+ (else
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((procedure? p)
+ (and (p expr) state))
+
+ ((pair? p)
+ (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq? (car p) '--)
+ (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 #f 1))
+ (else
+ (and (pair? expr)
+ (equal? (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (else
+ (and (equal? p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null? alt) #f ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star p prest expr state var min max L)
+ (define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) #f)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (else
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) #f)
+ ((null? p) (if (null? expr) state #f))
+ (else
+ (let ((subp (car p))
+ (var #f))
+ (if (and (pair? subp)
+ (eq? (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ #f)
+ (let ((head (if (pair? subp) (car subp) ())))
+ (cond ((eq? subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq? head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq? head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq? head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq? head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (else
+ (and (pair? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs p)
+ (define (patargs- p)
+ (cond ((and (symbol? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((pair? p)
+ (if (eq? (car p) '-/)
+ ()
+ (unique (apply append (map patargs- (cdr p))))))
+
+ (else ())))
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null? plist) expr
+ (if (procedure? plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (pair? expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq? enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/femtolisp/ast/out.lsp
@@ -1,0 +1,3 @@
+1201386230.6766149997711182
+(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v)))))) (<- is.scalar (lambda (x) (let nil (r-block (&& (|\|\|| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .Primitive "dim") x)) (r-call == (r-call length x) 1)))))) (<- p 1) (r-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (r-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as.
\ No newline at end of file
+1201386230.8069550991058350
--- /dev/null
+++ b/femtolisp/ast/plambda-js.scm
@@ -1,0 +1,23 @@
+; pattern-lambda syntax for jscheme
+
+; pattern-lambda abstraction
+; this is a generalization of lambda:
+;
+; ((pattern-lambda p body) expr)
+; Matches expr against p. If no match, return #null. If match succeeds, evaluate body
+; with variables in p bound to whatever they matched in expr.
+;
+; EXAMPLE: Recognize adding any expression x to itself, replace with 2*x.
+; (define selfadd (pattern-lambda (+ x x) `(* 2 ,x)))
+; Then (selfadd '(+ (foo bar) (foo bar))) returns (* 2 (foo bar))
+;
+(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 (assq var m) '(0 . #f))))
+ ',args))
+ #f)))))
binary files /dev/null b/femtolisp/ast/rpasses.exe differ
--- /dev/null
+++ b/femtolisp/ast/rpasses.lsp
@@ -1,0 +1,121 @@
+(load '|match.lsp|)
+(load '|asttools.lsp|)
+
+(define missing-arg-tag '*r-missing*)
+
+; tree inspection utils
+
+(define (assigned-var e)
+ (and (consp e)
+ (or (eq (car e) '<-) (eq (car e) 'ref=))
+ (symbolp (cadr e))
+ (cadr e)))
+
+(define (func-argnames f)
+ (let ((argl (cadr f)))
+ (if (eq argl '*r-null*) ()
+ (map cadr argl))))
+
+; transformations
+
+(define (dollarsign-transform e)
+ (pattern-expand
+ (pattern-lambda ($ lhs name)
+ (let* ((g (if (not (consp lhs)) lhs (gensym)))
+ (n (if (symbolp name)
+ name ;(symbol->string name)
+ name))
+ (expr `(r-call
+ r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
+ (if (not (consp lhs))
+ expr
+ `(r-block (ref= ,g ,lhs) ,expr))))
+ e))
+
+; lower r expressions of the form f(lhs,...) <- rhs
+; TODO: if there are any special forms that can be f in this expression,
+; they need to be handled separately. For example a$b can be lowered
+; to an index assignment (by dollarsign-transform), after which
+; this transform applies. I don't think there are any others though.
+(define (fancy-assignment-transform e)
+ (pattern-expand
+ (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
+ (<<- (r-call f lhs ...) rhs))
+ (let ((g (if (consp rhs) (gensym) rhs))
+ (op (car __)))
+ `(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
+ (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
+ ,g)))
+ e))
+
+; map an arglist with default values to appropriate init code
+; function(x=blah) { ... } gets+; if (missing(x)) x = blah
+; added to its body
+(define (gen-default-inits arglist)
+ (map (lambda (arg)
+ (let ((name (cadr arg))
+ (default (caddr arg)))
+ `(when (missing ,name)
+ (<- ,name ,default))))
+ (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
+
+; convert r function expressions to lambda
+(define (normalize-r-functions e)
+ (maptree-post (lambda (n)
+ (if (and (consp n) (eq (car n) 'function))
+ `(lambda ,(func-argnames n)
+ (r-block ,@(gen-default-inits (cadr n))
+ ,@(if (and (consp (caddr n))
+ (eq (car (caddr n)) 'r-block))
+ (cdr (caddr n))
+ (list (caddr n)))))
+ n))
+ e))
+
+(define (find-assigned-vars n)
+ (let ((vars ()))
+ (maptree-pre (lambda (s)
+ (if (not (consp s)) s
+ (cond ((eq (car s) 'lambda) nil)
+ ((eq (car s) '<-)
+ (setq vars (list-adjoin (cadr s) vars))
+ (cddr s))
+ (T s))))
+ n)
+ vars))
+
+; introduce let based on assignment statements
+(define (letbind-locals e)
+ (maptree-post (lambda (n)
+ (if (and (consp n) (eq (car n) 'lambda))
+ (let ((vars (find-assigned-vars (cddr n))))
+ `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
+ vars)
+ ,@(cddr n))))
+ n))
+ e))
+
+(define (compile-ish e)
+ (letbind-locals
+ (normalize-r-functions
+ (fancy-assignment-transform
+ (dollarsign-transform
+ (flatten-all-op && (flatten-all-op \|\| e)))))))
+
+;(trace map)
+;(pretty-print (compile-ish *input*))
+; (time-call (lambda () (compile-ish *input*)) 1)
+;)
+(define (main)
+ (progn
+ (define *input* (read))
+ ;(define t0 ((java.util.Date:new):getTime))
+ (clock)
+ (compile-ish *input*)
+ (clock)
+ ;(define t1 ((java.util.Date:new):getTime))
+))
+
+(main)
--- /dev/null
+++ b/femtolisp/ast/rpasses.scm
@@ -1,0 +1,206 @@
+(include "iscutil.scm")
+(include "match.scm")
+(include "asttools.scm")
+;(load "plambda-js.scm")
+;(load "plambda-chez.scm")
+
+;(pretty-print *input*)
+
+#|
+Overall phases:
+I. s-expr output
+II. tree normalization
+ 1. control construct normalization, flattening. various restructuring.
+ 2. transformations that might add variables
+ 3. local variable detection
+III. var/func attribute analysis
+IV. argument normalization
+V. type inference
+ 1. split each function into generic/non-generic versions. the generic
+ one resolves generic funcs to calls to a lookup routine that tries
+ to find stuff like `diag<-.darray`. the other one assumes everything
+ is handled by a builtin R function with a known t-function
+ 2. inference
+VI. code generation
+
+Useful R lowering passes:
+
+- control construct normalization
+ . convert while/repeat/various for forms/break/next to while/break
+ . convert switch to nested if
+
+- local variable detection
+ . classify vars as (1) definitely local, (2) possibly-local, (3) free
+ . collect all local or possibly-local vars and wrap the body with
+ (let ((g0 (upvalue 'var1))
+ (g1 (upvalue 'var2)))
+ <body>)
+
+ where (upvalue x) is either (get-global x) or (captured-var n i)
+ for definitely-local, start as null instead of upvalue
+
+ then we have to rename var1 to g0 everywhere inside that.
+ for the vast majority of functions that don't attempt to modify parent-scope
+ locals, pure-functional closure conversion would work.
+
+ utility for this: fold-along-cfg
+ . after this the tree is ready for typical lexical scope analysis
+
+ (- closure conversion/deBruijn indices)
+
+- argument normalization for call to known function
+ . convert lambda arglist to plain list of symbols
+ . move default initializers into body as `(when (eq? ,argname 'missing) ,assign)
+ . at call site sort args to correct positions, add explicit missing
+ . if call target unknown insert call to match.args or whatever
+
+- r-block, ||, && flattening
+
+- fancy assignment transformation:
+ f(v) <- rhs, (<- (r-call f v) rhs)
+ performs:
+ (begin (<- v (r-call f<- v rhs))
+ rhs)
+
+- (<- a b) becomes (ref= a (lazy-copy b))
+ arguments to functions are wrapped in lazy-copy at the call site, so we can
+ omit the copy (1) for functions marked as pass-by-ref, (2) where user indicated
+ pass-by-ref, (3) for arguments which are strictly-allocating expressions,
+ (4) for user functions proven to be ref-safe and thus marked as case (1)
+
+Useful analyses:
+
+- prove function strictness!!
+ . strict functions need to open with (if (promise? arg) (force arg) arg) for each
+ arg, in case they are called indirectly.
+- prove global variables constant (esp. function names)
+ . prove builtins redefined/constant
+- need dictionary of builtin properties (pure/strict/t-functions/etc.)
+- useful but very general types:
+ single: has length 1 and no attrs (implies simple)
+ simple: has default class attributes
+ array: has dim attribute only
+ distributed: starp array
+ numeric
+|#
+
+
+(define missing-arg-tag '*r-missing*)
+
+; tree inspection utils
+
+(define (assigned-var e)
+ (and (pair? e)
+ (or (eq? (car e) '<-) (eq? (car e) 'ref=))
+ (symbol? (cadr e))
+ (cadr e)))
+
+(define (func-argnames f)
+ (let ((argl (cadr f)))
+ (if (eq? argl '*r-null*) ()
+ (map cadr argl))))
+
+; transformations
+
+(define (dollarsign-transform e)
+ (pattern-expand
+ (pattern-lambda ($ lhs name)
+ (let* ((g (if (not (pair? lhs)) lhs (gensym)))
+ (n (if (symbol? name)
+ (symbol->string name)
+ name))
+ (expr `(r-call
+ r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
+ (if (not (pair? lhs))
+ expr
+ `(r-block (ref= ,g ,lhs) ,expr))))
+ e))
+
+; lower r expressions of the form f(lhs,...) <- rhs
+; TODO: if there are any special forms that can be f in this expression,
+; they need to be handled separately. For example a$b can be lowered
+; to an index assignment (by dollarsign-transform), after which
+; this transform applies. I don't think there are any others though.
+(define (fancy-assignment-transform e)
+ (pattern-expand
+ (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
+ (<<- (r-call f lhs ...) rhs))
+ (let ((g (if (pair? rhs) (gensym) rhs))
+ (op (car __)))
+ `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
+ (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
+ ,g)))
+ e))
+
+; map an arglist with default values to appropriate init code
+; function(x=blah) { ... } gets+; if (missing(x)) x = blah
+; added to its body
+(define (gen-default-inits arglist)
+ (map (lambda (arg)
+ (let ((name (cadr arg))
+ (default (caddr arg)))
+ `(when (missing ,name)
+ (<- ,name ,default))))
+ (filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist)))
+
+; convert r function expressions to lambda
+(define (normalize-r-functions e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq? (car n) 'function))
+ `(lambda ,(func-argnames n)
+ (r-block ,@(gen-default-inits (cadr n))
+ ,@(if (and (pair? (caddr n))
+ (eq? (car (caddr n)) 'r-block))
+ (cdr (caddr n))
+ (list (caddr n)))))
+ n))
+ e))
+
+(define (find-assigned-vars n)
+ (let ((vars ()))
+ (maptree-pre (lambda (s)
+ (if (not (pair? s)) s
+ (cond ((eq? (car s) 'lambda) #f)
+ ((eq? (car s) '<-)
+ (set! vars (list-adjoin (cadr s) vars))
+ (cddr s))
+ (else s))))
+ n)
+ vars))
+
+; introduce let based on assignment statements
+(define (letbind-locals e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq? (car n) 'lambda))
+ (let ((vars (find-assigned-vars (cddr n))))
+ `(lambda ,(cadr n) (let ,(map list
+ vars
+ (map (lambda (x) '()) vars))
+ ,@(cddr n))))
+ n))
+ e))
+
+(define (compile-ish e)
+ (letbind-locals
+ (normalize-r-functions
+ (fancy-assignment-transform
+ (dollarsign-transform
+ (flatten-all-op && (flatten-all-op || e)))))))
+
+;(trace map)
+;(pretty-print (compile-ish *input*))
+; (time-call (lambda () (compile-ish *input*)) 1)
+;)
+(define (main)
+ (begin
+ (define *input* (read))
+ (define t0 ((java.util.Date:new):getTime))
+ (compile-ish *input*)
+ (define t1 ((java.util.Date:new):getTime))
+ (display "milliseconds: ")
+ (display (- t1 t0))
+ (newline)))
+
+(main)
--- /dev/null
+++ b/femtolisp/ast/starpR.lsp
@@ -1,0 +1,120 @@
+(r-expressions
+ (r-call library \M\A\S\S)
+ (r-call dyn.load "starp.so")
+ (<- ppcommand (function ((*named* ... *r-missing*)) (r-call .\Call "ppcommand" (r-call list r-dotdotdot)) ()))
+ (<- ppvcommand (function ((*named* va *r-missing*)) (r-call .\Call "ppcommand" va) ()))
+ (<- ppinvoke ppcommand)
+ (<- pploadconfig (function ((*named* fileName *r-missing*)) (r-call .\Call "pploadconfig" file\Name) ()))
+ (<- ppconnect (function ((*named* numProcs ()) (*named* machines ())) (r-call .\Call "ppconnect" (r-call list num\Procs machines)) ()))
+ (<- ppgetlogpath (function () (r-call .\Call "ppgetlogpath") ()))
+ (<- ppgetlog (function () (r-call .\Call "ppgetlog") ()))
+ (<- ppshowdashboard (function () (r-call .\Call "ppshowdashboard") ()))
+ (<- pphidedashboard (function () (r-call .\Call "pphidedashboard") ()))
+ (<- revealargs (function ((*named* dots *r-missing*)) (r-call .\Call "_revealArgs" dots) ()))
+ (<- listargs (function ((*named* ... *r-missing*)) (r-call revealargs (r-call get "...")) ()))
+ (<- ppping (function () (r-call ppcommand "ppping") ()))
+ (<- ppver (function () (r-call ppcommand "pp_ver") ()))
+ (<- \S\T\A\R\P\D\I\S\T "../../../linkdist")
+ (<- \S\T\A\R\P\P\L\A\T\F\O\R\M "ia32_linux")
+ (r-call .\Call "_setstarpdist" \S\T\A\R\P\D\I\S\T)
+ (r-call .\Call "_setstarpplat" \S\T\A\R\P\P\L\A\T\F\O\R\M)
+ (r-call pploadconfig (r-call paste \S\T\A\R\P\D\I\S\T "/config/starpd.properties" (*named* sep "")))
+ (<- dimdis (function ((*named* v *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v))) ()))
+ (<- is.scalar (function ((*named* x *r-missing*)) (&& (&& (\|\| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .\Primitive "dim") x))) (r-call == (r-call length x) 1)) ()))
+ (<- p 1)
+ (<- (r-call class p) (r-call c "dlayout" "numeric"))
+ (<- darray (function ((*named* id *r-missing*) (*named* shape *r-missing*) (*named* distribution *r-missing*) (*named* isreal *r-missing*)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (<- (r-call class shape) (r-call append "dlayoutn" (r-call to\String distribution) (r-call class shape))) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) () ())) (<- (r-call class d) "darray") d) ()))
+ (<- darraydist (function ((*named* da *r-missing*)) (r-call as.numeric (r-call r-aref (r-call class ($ da shape)) 2)) ()))
+ (<- is.darray (function ((*named* x *r-missing*)) (r-call == (r-call r-index (r-call class x) 1) "darray") ()))
+ (<- is.nd (function ((*named* x *r-missing*)) (r-call != (r-call length (r-call dim x)) 2) ()))
+ (<- is.darraynd (function ((*named* x *r-missing*)) (&& (r-call is.darray x) (r-call is.nd x)) ()))
+ (<- is.dlayout (function ((*named* x *r-missing*)) (r-call any (r-call == (r-call class x) "dlayout")) ()))
+ (<- vdim (function ((*named* x *r-missing*)) (if (r-call is.vector x) (r-call length x) (r-call dim x)) ()))
+ (<- \[\[.dlayoutn (<- \[.dlayoutn (function ((*named* dl *r-missing*) (*named* n *r-missing*)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (<- (r-call class r) (r-call append "dlayoutn" (r-call to\String didi) (r-call class r))) (return r)))) ())))
+ (<- print.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- sh (r-call as.vector ($ d shape))) (<- shs (r-call deparse sh)) (if (r-call > (r-call length sh) 1) (r-block (<- shs (r-call substring shs 2))) (r-block (<- shs (r-call paste "(" shs ")" (*named* sep ""))))) (r-call print.default (r-call paste "<darray id:" ($ d id) " shape:" shs " distribution:" (r-call r-aref (r-call class ($ d shape)) 2) ">" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d)) ()))+ (<- validdist (function ((*named* dims *r-missing*) (*named* dd *r-missing*)) (r-block (if (\|\| (r-call > dd (r-call length dims)) (r-call == (r-call r-aref dims dd) 1)) (return (r-call dimdis (r-call as.vector dims)))) (return dd)) ()))
+ (<- dim.darray (function ((*named* x *r-missing*)) ($ x shape) ()))
+ (<- dim<-.darray (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class value) 1) "dlayoutn") (r-block (<- dd (r-call as.numeric (r-call r-index (r-call class value) 2)))) (<- dd (r-call darraydist x))) (<- dd (r-call validdist value dd)) (if (&& (r-call == (r-call length value) 2) (r-call == (r-call length ($ x shape)) 2)) (r-block (r-call ppcommand "ppdense_reshape" x (r-call r-aref value 1) (r-call - dd 1))) (r-block (<- d (r-call ppcommand "ppdensend_reshape" x (r-call length value) (r-call as.real value) (r-call - dd 1))) (if (r-call == (r-call length ($ d shape)) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d))) ()))
+ (<- length.darray (function ((*named* d *r-missing*)) (r-call prod ($ d shape)) ()))
+ (<- ppzeros (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_zeros" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "zeros"))) ()))
+ (<- ppones (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_ones" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims) 1) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "ones"))) ()))
+ (<- pprand (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_rand" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "rand"))) ()))
+ (<- ppback (function ((*named* m *r-missing*) (*named* dist (r-call dimdis (r-call dim m))) (*named* allowScalar *r-false*)) (r-block (if (\|\| (r-call is.darray m) (r-call == (r-call length m) 0)) (return m)) (<- lg (r-call is.logical m)) (if (&& (r-call ! (r-call is.complex m)) (r-call ! (r-call is.real m))) (r-block (if (r-call is.vector m) (<- m (r-call as.real m)) (<- m (r-call dim<- (r-call as.real m) (r-call dim m)))))) (if (r-call is.scalar m) (r-block (if allow\Scalar (return (r-call ppcommand "ppdensend_ppback_scalar" m))) (return m))) (if (r-call ! (missing dist)) (<- dist (r-call validdist dist))) (if (&& (r-call ! (r-call is.vector m)) (r-call == (r-call length (r-call dim m)) 2)) (<- d (r-call ppcommand "pp_dense_ppback" m (r-call r-index (r-call dim m) 1) (r-call r-index (r-call dim m) 2) dist)) (<- d (r-call ppcommand "ppdensend_ppback" (r-call - dist 1) (r-call as.real (r-call vdim m)) (r-call is.real m) m))) (if lg (<- ($ d logical) *r-true*)) d) ()))
+ (<- ppfront (function ((*named* da *r-missing*)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length ($ da shape)) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (<- (r-call dim m) (r-call c (r-call r-aref l 2) (r-call r-aref l 3)))) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical m))) (<- (r-call dim m) (r-call as.vector ($ da shape))))) m) ()))
+ (<- vector (function ((*named* mode "logical") (*named* length 0)) (r-call \Use\Method "vector" length) ()))
+ (<- vector.default (r-call .\Primitive "vector"))
+ (<- vector.dlayout (function ((*named* mode "logical") (*named* length 0)) (r-block (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (<- ($ d logical) *r-true*)) d) ()))
+ (<- double (function ((*named* length 0)) (r-call vector "double" length) ()))
+ (<- logical (function ((*named* length 0)) (r-call vector "logical" length) ()))
+ (<- c (function ((*named* ... *r-missing*)) (r-block (<- args (r-call list r-dotdotdot)) (<- v (r-call (r-call .\Primitive "c") r-dotdotdot)) (<- l (r-call length args)) (if (r-call == l 0) (return v)) (for i (r-call : 1 l) (if (r-call is.dlayout (r-call r-aref args i)) (r-block (<- (r-call class v) (r-call append "dlayoutn" (r-call to\String i) (r-call class v))) (return v)))) v) ()))
+ (<- rep (function ((*named* x *r-missing*) (*named* times 1) (*named* length.out \N\A) (*named* each 1)) (r-block (if (r-call is.darray x) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (if (\|\| (&& (missing length.out) (r-call > (r-call length times) 1)) (r-call > each 1)) (<- x (r-call ppfront x)))) (if (r-call ! (\|\| (r-call is.dlayout times) (&& (r-call ! (missing length.out)) (r-call is.dlayout length.out)))) (r-block (return (r-call (r-call .\Primitive "rep") x (*named* times times) (*named* length.out length.out) (*named* each each)))))) (if (r-call > each 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* each each))))) (if (missing length.out) (r-block (if (r-call > (r-call length times) 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* times times))) (<- times 1)))) (r-block (<- times (r-call ceiling (r-call / length.out (r-call length x)))))) (if (r-call == (r-call length x) 1) (r-block (return (r-call * (r-call ppones (r-call r-aref times 1)) (r-call r-aref x 1))))) (<- x (r-call ppback (r-call as.2d x))) (<- out (r-call ppcommand "ppdense_repmat" x 1 (r-call r-aref times 1) 1)) (if (&& (r-call ! (missing length.out)) (r-call != (r-call r-aref (r-call dim out) 2) length.out)) (r-block (<- out (r-call ppcommand "ppdense_subsref_col" out (r-call as.realarray (r-call : 1 length.out)))))) (<- (r-call dim out) (r-call length out)) (return out)) ()))
+ (<- globalbinding (function ((*named* sym *r-missing*)) (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))) ()))
+ (<- boundp (function ((*named* sym *r-missing*)) (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")) ()))
+ (<- redefining (function ((*named* sym *r-missing*)) (r-block (<- name (r-call deparse (substitute sym))) (<- rname (r-call paste "R" name (*named* sep ""))) (if (r-call ! (r-call boundp rname)) (r-call assign rname (r-call globalbinding name) (*named* envir (r-call globalenv))))) ()))
+ (r-call redefining array)
+ (<- array (function ((*named* data \N\A) (*named* dim (r-call length data)) (*named* dimnames ())) (r-block (<- dd *r-false*) (if (r-call == (r-call r-index (r-call class dim) 1) "dlayoutn") (<- dd (r-call as.numeric (r-call r-index (r-call class dim) 2)))) (if (r-call is.darray data) (r-block (if (r-call != (r-call length data) (r-call prod dim)) (r-block (<- data (r-call rep data (*named* length.out (r-call prod dim)))))) (if (r-call all (r-call == dim (r-call as.vector ($ data shape)))) (return data)) (return (r-call dim<-.darray data dim))) (r-block (if dd (r-block (<- data (r-call rep data (*named* length.out (r-call * (r-call prod dim) p)))) (return (r-call dim<-.darray data dim))) (r-block (r-call \Rarray data dim dimnames)))))) ()))
+ (r-call redefining matrix)
+ (<- matrix (function ((*named* data \N\A) (*named* nrow 1) (*named* ncol 1) (*named* byrow *r-false*) (*named* dimnames ())) (r-block (<- l (r-call length data)) (if (missing nrow) (r-block (if (r-call ! (missing ncol)) (<- nrow (r-call / l ncol)) (r-block (<- nrow l) (<- ncol 1)))) (if (missing ncol) (<- ncol (r-call / l nrow)))) (<- m (r-call array data (r-call c nrow ncol) dimnames)) (if byrow (r-call t m) m)) ()))
+ (<- t.darray (function ((*named* da *r-missing*)) (r-block (if (\|\| (r-call == (r-call darraydist da) 1) (r-call == (r-call darraydist da) 2)) (r-call ppcommand "ppdense_transpose" da 0) (r-call ppcommand "pppblas_trans" da))) ()))
+ (<- runif (function ((*named* n *r-missing*) (*named* min 0) (*named* max 1)) (r-block (if (r-call is.dlayout n) (r-call pprand n) (r-call .\Internal (r-call runif n min max)))) ()))
+ (r-call redefining diag)
+ (<- diag (function ((*named* da *r-missing*) (*named* nrow *r-missing*) (*named* ncol n)) (r-block (if (r-call is.darray da) (r-block (if (r-call == (r-call length ($ da shape)) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call == (r-call r-index ($ da shape) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index ($ da shape) 2) 1) (return (r-call ppcommand "ppdense_diagv" (r-call t da) 0)))))) (r-call t (r-call ppcommand "ppdense_diag" da 0))) (r-call \Rdiag da))) ()))
+ (<- dbinaryop (function ((*named* code *r-missing*) (*named* scalarcode *r-missing*) (*named* bscalarcode *r-missing*) (*named* ndcode *r-missing*) (*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.scalar a) (r-block (if (r-call is.nd b) (r-call ppcommand "ppdensend_s_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" scalarcode a b))) (if (r-call is.scalar b) (r-block (if (r-call is.nd a) (r-call ppcommand "ppdensend_binary_operator_s" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" bscalarcode b a))) (r-block (if (r-call ! (r-call is.darray a)) (<- a (r-call ppback a))) (if (r-call ! (r-call is.darray b)) (<- b (r-call ppback b))) (if (\|\| (r-call is.nd a) (r-call is.nd b)) (r-call ppcommand "ppdensend_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_binary_op" code a b)))))) ()))
+ (<- +.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 1 1 1 2 a b) ()))
+ (<- *.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 3 3 3 3 a b) ()))
+ (<- /.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 4 4 5 6 a b) ()))
+ (<- ^.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 7 10 11 19 a b) ()))
+ (<- mkdlogicalop (function ((*named* c *r-missing*) (*named* sc *r-missing*) (*named* bsc *r-missing*) (*named* ndcode *r-missing*)) (r-block (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (<- ($ da logical) *r-true*) da) ())) ()))
+ (<- <.darray (r-call mkdlogicalop 14 16 17 15))
+ (<- >.darray (r-call mkdlogicalop 15 17 16 17))
+ (<- ==.darray (r-call mkdlogicalop 18 20 20 13))
+ (<- !=.darray (r-call mkdlogicalop 19 21 21 14))
+ (<- <=.darray (r-call mkdlogicalop 16 18 19 18))
+ (<- >=.darray (r-call mkdlogicalop 17 19 18 16))
+ (<- &.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppcopy a)) (return (r-call ppzeros (r-call dim a)))))) (<- da (r-call dbinaryop 11 (r-call - 1) (r-call - 1) 9 a b)) (<- ($ da logical) *r-true*) da) ()))
+ (<- \|.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppones (r-call dim a))) (return (r-call ppcopy a))))) (<- da (r-call dbinaryop 12 (r-call - 1) (r-call - 1) 10 a b)) (<- ($ da logical) *r-true*) da) ()))
+ (<- !.darray (function ((*named* a *r-missing*)) (r-block (if (r-call is.nd a) (r-block (<- da (r-call ppcommand "ppdensend_not" a))) (r-block (<- da (r-call ppcommand "ppdense_unary_op" 2 a)))) (<- ($ da logical) *r-true*) da) ()))
+ (<- %*% (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (r-block (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" a b)) (r-block (r-call ppcommand "pppblas_gemm" a (r-call ppback b))))) (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" (r-call ppback a) b)) (r-call (r-call .\Primitive "%*%") a b)))) ()))
+ (<- -.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (missing b) (if (r-call is.nd a) (r-block (<- b a) (<- a 0)) (r-block (return (r-call ppcommand "ppdense_unary_op" 13 a))))) (if (r-call is.scalar b) (r-call dbinaryop 1 1 1 4 (r-call - b) a) (r-call dbinaryop 2 2 2 4 a b))) ()))
+ (<- ppreduce (function ((*named* da *r-missing*) (*named* axis *r-missing*) (*named* allfunc *r-missing*) (*named* axisfunc *r-missing*) (*named* ndcode *r-missing*) (*named* islogical *r-false*)) (r-block (<- nd (r-call length ($ da shape))) (if (r-call == nd 2) (r-block (if (r-call ! axis) (r-call ppcommand allfunc da) (r-block (<- res (r-call ppcommand axisfunc da axis)) (if (r-call is.list res) (<- res (r-call r-aref res 1))) (return res)))) (r-block (if (r-call ! axis) (r-block (<- (r-call dim da) (r-call length da)) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (<- ($ res logical) *r-true*)) (return res)))) ()))
+ (<- any.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call > (r-call ppcommand "ppbase_nnz" da) 0))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*)))) ()))
+ (<- all.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call == (r-call ppcommand "ppbase_nnz" da) (r-call length da)))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*)))) ()))
+ (<- sum (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 0)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_sumv" "ppdense_sum" 2) (r-call (r-call .\Primitive "sum") r-dotdotdot (*named* na.rm na.rm)))) ()))
+ (<- prod (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 1)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_prodv" "ppdense_prod" 3) (r-call (r-call .\Primitive "prod") r-dotdotdot (*named* na.rm na.rm)))) ()))
+ (<- min (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return \Inf)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_minv" "ppdense_min" 8) (r-call (r-call .\Primitive "min") r-dotdotdot (*named* na.rm na.rm)))) ()))
+ (<- max (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return (r-call - \Inf))) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_maxv" "ppdense_max" 7) (r-call (r-call .\Primitive "max") r-dotdotdot (*named* na.rm na.rm)))) ()))
+ (<- ppcopy (function ((*named* d *r-missing*) (*named* dist 2)) (r-block (if (\|\| (missing dist) (r-call == dist (r-call darraydist d))) (return (r-call ppcommand "ppbase_createMatrixCopy" d)) (return (r-call ppcommand "ppbase_createMatrixCopyRedist" d dist)))) ()))
+ (<- as.realarray (function ((*named* x *r-missing*)) (r-call as.array (r-call as.real x)) ()))
+ (<- as.1d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call length x)) (return x)) ()))
+ (<- as.2d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ()))
+ (<- as.real2d (function ((*named* x *r-missing*)) (r-block (<- x (r-call as.real x)) (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ()))
+ (<- to\Index\Vec2d (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdense_zeros" 1 0 1)))) (return (r-call ppback (r-call as.2d i) (*named* allowScalar *r-true*)))) ()))
+ (<- to\Index\Vec (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdensend_add" 0 0 1 "zeros")))) (return (r-call ppback i (*named* allowScalar *r-true*)))) ()))
+ (<- to\Num\Index (function ((*named* i *r-missing*)) (r-block (if (r-call ! (r-call is.darray i)) (r-block (if (r-call is.logical i) (r-block (<- \N (r-call : 1 (r-call length i))) (<- i (r-call r-index \N i)))) (return i)) (if (r-call ! ($ i logical)) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (<- (r-call dim i) (r-call c 1 (r-call length i)))) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (<- (r-call dim i) (r-call length i)) i) ()))
+ (<- expand\Linear\Index (function ((*named* shape *r-missing*) (*named* i *r-missing*)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (<- (r-call r-aref out n) (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out) ()))
+ (<- to\Linear\Index (function ((*named* shape *r-missing*) (*named* iv *r-missing*)) (r-call + (r-call sum (r-call * (r-call - iv 1) (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))))) 1) ()))
+ (<- to\Linear\Indexes (function ((*named* shape *r-missing*) (*named* im *r-missing*)) (r-block (<- ds (r-call t (r-call array (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))) (r-call rev (r-call dim im))))) (r-call as.1d (r-call + (r-call apply (r-call * (r-call - im 1) ds) 1 sum) 1))) ()))
+ (<- starpcolon (quote :missingarg:))
+ (<- is.colon (function ((*named* x *r-missing*)) (r-call identical x starpcolon) ()))
+ (<- normalize\Indexes (function ((*named* shape *r-missing*) (*named* idxs *r-missing*)) (r-block (<- li (r-call length idxs)) (<- out (r-call vector "list" li)) (if (r-call == li 0) (return out) (if (&& (r-call > li 1) (r-call != li (r-call length shape))) (r-call stop "wrong number of subscripts"))) (for n (r-call : 1 li) (r-block (<- i (r-call r-aref idxs n)) (if (r-call == (r-call length (r-call dim i)) 2) (r-block (<- i (r-call to\Linear\Indexes shape i)) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i)))))) (if (r-call ! (r-call is.colon i)) (r-block (if (r-call > (r-call length (r-call dim i)) 2) (r-block (<- i (r-call as.1d i)))) (<- lg (\|\| (r-call is.logical i) (&& (r-call is.darray i) ($ i logical)))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call to\Num\Index i)) (if (r-call ! lg) (r-block (<- nonz (r-call != i 0)) (if (r-call ! (r-call is.darray nonz)) (r-block (<- i (r-call r-index i nonz))) (r-block (<- where (r-call r-aref (r-call ppcommand "ppdense_find" (r-call as.2d i) 1 0 0) 1)) (<- i (r-call ppcommand "ppdense_subsref_dcol" i where)))))) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i))))) (if (&& (r-call is.scalar i) (r-call < i 0)) (r-block (<- i (r-call r-index (r-call : 1 (r-call r-index shape n)) i))))))) (<- (r-call r-aref out n) i))) out) ()))
+ (<- index\Sizes (function ((*named* d *r-missing*) (*named* idxs *r-missing*)) (r-block (<- n (r-call length idxs)) (<- whichcolons (r-call logical n)) (<- lens (r-call numeric n)) (for i (r-call : 1 n) (r-block (if (r-call is.colon (r-call r-aref idxs i)) (r-block (<- (r-call r-index whichcolons i) *r-true*) (<- (r-call r-index lens i) (r-call r-index (r-call dim d) i))) (<- (r-call r-index lens i) (r-call length (r-call r-aref idxs i)))))) (r-call list lens whichcolons)) ()))
+ (<- \[.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return (r-call array 0 (r-call r-index lens (r-call != lens 1)))))) (if (r-call all whichcolons) (return (r-call ppcopy d))) (if (r-call == n 2) (r-block (if (r-call == (r-call length (r-call dim d)) 2) (<- x (r-call ppcommand "ppdense_subsref_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))))) (<- x (r-call ppcommand "ppdensend_subsref_idx_dist" d (r-call ppback (r-call r-aref idxs 1) (*named* allowScalar *r-true*))))) (if (r-call == (r-call length (r-call r-aref idxs 1)) 1) (return (r-call ppfront x)) (return x))) (if (r-call == n 3) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (return (r-call ppcommand "ppdense_viewelement" d r c)))) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (<- a (r-call ppcommand "ppdense_subsref_dcol" d c)) (<- a (r-call ppcommand "ppdense_subsref_col" d (r-call as.realarray c))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (<- a (r-call ppcommand "ppdense_subsref_drow" d r)) (<- a (r-call ppcommand "ppdense_subsref_row" d (r-call as.realarray r))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (<- a (r-call ppcommand "ppdense_subsref_rowcol" d r c))))) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d a))) (return a)))) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (return (r-call ppcommand "ppdensend_subsref_scalar" d (r-call as.numeric idxs))))) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (if (r-call == slicepos (r-call darraydist d)) (r-block (if (r-call > (r-call length slice) 1) (r-block (<- (r-call dim slice) (r-call c (r-call length slice) 1)) (<- slice (r-call ppback slice)))) (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_dist" d slice))) (r-block (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_local" d (r-call - slicepos 1) slice))))) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsref_element_list" (r-call append 0 idxs))) (<- (r-call r-aref al 2) d) (<- result (r-call ppvcommand al)) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d result))))) (return result)) ()))
+ (<- \[<-.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (<- arglist (r-call revealargs (r-call get "..."))) (<- rhs (r-call r-aref arglist (r-call - n 1))) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call r-index arglist (r-call + (r-call - n) 1)))) (if (&& (r-call == (r-call length idxs) 1) (r-call is.colon (r-call r-aref idxs 1))) (r-block (<- idxs (r-call rep (r-call list starpcolon) (*named* length.out (r-call length (r-call dim d))))) (<- n (r-call + 2 (r-call length (r-call dim d)))))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return d))) (if (r-call ! (r-call is.scalar rhs)) (r-block (if (&& (r-call != (r-call length rhs) (r-call prod lens)) (r-call > (r-call prod lens) 1)) (r-block (<- rhs (r-call rep rhs (*named* length.out (r-call prod lens)))))) (if (r-call is.darray rhs) (r-block (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs)))) (r-block (<- rhs (r-call as.array rhs)) (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs))) (<- rhs (r-call ppback rhs)))))) (if (r-call == (r-call length (r-call dim d)) 2) (r-block (if (r-call all whichcolons) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_setall" d rhs) (r-call ppcommand "ppdense_copyall" rhs d)) (if (r-call == n 3) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_idx_s" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (r-call ppcommand "ppdense_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) (r-call ppback rhs)))) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (if (r-call ! (r-call is.scalar rhs)) (r-call stop "expected scalar value")) (r-call ppcommand "ppdense_setelement" d r c rhs)) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_dcol_s" d c rhs) (r-call ppcommand "ppdense_subsasgn_dcol" d c rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_col_s" d (r-call as.real2d c) rhs) (r-call ppcommand "ppdense_subsasgn_col" d (r-call as.real2d c) rhs))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_drow_s" d r rhs) (r-call ppcommand "ppdense_subsasgn_drow" d r rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_row_s" d (r-call as.real2d r) rhs) (r-call ppcommand "ppdense_subsasgn_row" d (r-call as.real2d r) rhs))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_rowcol_s" d r c rhs) (r-call ppcommand "ppdense_subsasgn_rowcol" d r c rhs))))))))) (return d)) (r-block (if (r-call == n 3) (r-call ppcommand "ppdensend_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (r-call ppcommand "ppdensend_subsasgn_scalar" d (r-call as.numeric idxs) rhs)) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (r-call ppcommand "ppdensend_subsasgn_slice" d (r-call - slicepos 1) slice rhs)) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsasgn_tuple" (r-call append 0 (r-call append idxs 0)))) (<- (r-call r-aref al 2) d) (<- (r-call r-aref al (r-call length al)) rhs) (r-call ppvcommand al))))))) d) ()))
+ (<- unaryops (r-call list (r-call list "ceiling" 9 "ceil") (r-call list "round" 10) (r-call list "floor" 11) (r-call list "sign" 14) (r-call list "abs" 15) (r-call list "sqrt" 16 *r-false*) (r-call list "exp" 17) (r-call list "log10" 19) (r-call list "log2" 20) (r-call list "Conj" 8 *r-false*) (r-call list "sin" 21) (r-call list "cos" 22) (r-call list "tan" 23)))
+ (<- mkunaryop (function ((*named* code *r-missing*) (*named* oldf *r-missing*) (*named* ndname *r-missing*)) (r-block (r-call force code) (r-call force oldf) (if (r-call is.character ndname) (r-block (<- ndname (r-call paste "ppdensend_" ndname (*named* sep ""))) (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length ($ x shape)) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x))) ())) (r-block (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-call ppcommand "ppdense_unary_op" code x) (r-call oldf x))) ())))) ()))
+ (for i unaryops (r-block (<- ppname (r-call as.name (r-call r-aref i 1))) (<- \Rf (r-call eval ppname)) (if (r-call == (r-call length i) 2) (<- ndn (r-call r-aref i 1)) (<- ndn (r-call r-aref i 3))) (r-call assign (r-call as.character ppname) (r-call mkunaryop (r-call r-aref i 2) \Rf ndn) (*named* envir (r-call globalenv)))))
+ (r-call redefining chol)
+ (<- chol (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_chol" m)) (if (r-call > (r-call r-aref l 1) 0) (r-call stop "chol: not positive definite.")) (return (r-call r-aref l 2)))) (r-call \Rchol m)) ()))
+ (r-call redefining ginv)
+ (<- ginv (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_inv" m)) (return (r-call r-aref l 1)))) (r-call \Rginv m)) ()))
+ (r-call redefining eigen)
+ (<- eigen (function ((*named* x *r-missing*) (*named* symmetric *r-missing*) (*named* only.values *r-false*) (*named* EISPACK *r-false*)) (r-block (if (r-call ! (r-call is.darray x)) (return (r-call \Reigen x symmetric only.values \E\I\S\P\A\C\K))) (if only.values (<- vl 0) (<- vl 1)) (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- res (r-call ppcommand "ppscalapack_eig_sym" x vl))) (r-block (<- res (r-call ppcommand "ppscalapack_eig" x vl)))) (<- out (r-call list (*named* values ()) (*named* vectors ()))) (if only.values (r-block (<- ($ out values) (r-call t res))) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- ($ out values) (r-call t (r-call r-aref res 2)))) (r-block (<- ($ out values) (r-call diag (r-call r-aref res 2))))) (<- ($ out vectors) (r-call r-aref res 1)))) out) ()))
+ (r-call redefining apply)
+ (<- apply (function ((*named* d *r-missing*) (*named* axis *r-missing*) (*named* f *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (return (r-call \Rapply d axis f))) (<- axis (r-call + axis 1)) (if (r-call identical f sum) (r-call t (r-call ppcommand "ppdense_sum" d axis)) (r-call stop "starp: unsupported operation"))) ()))
+ (r-call redefining diag<-)
+ (<- diag<- (function ((*named* d *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (r-block (if (r-call is.darray value) (<- value (r-call ppfront value))) (return (r-call \Rdiag<- d value)))) (if (r-call != (r-call length (r-call dim d)) 2) (r-call stop "starp diag<-: only supported for 2d")) (<- n (r-call min (r-call dim d))) (<- idxs (r-call ppcommand "ppdense_makeRange" 1 (r-call + (r-call r-index (r-call dim d) 1) 1) (r-call + (r-call * (r-call - n 1) (r-call r-index (r-call dim d) 1)) n))) (if (r-call is.scalar value) (r-block (r-call ppcommand "ppdense_subsasgn_idx_s" d idxs value)) (if (r-call != (r-call length value) n) (r-block (r-call stop "diag<-: replacement diagonal has wrong length")) (r-block (r-call ppcommand "ppdense_subsasgn_idx" d idxs (r-call ppback (r-call as.2d value)))))) d) ()))
+ (<- engine\Arg (function ((*named* arg *r-missing*)) (r-block (<- arg (r-call tolower arg)) (if (r-call != arg "") (r-block (if (r-call != arg "c") (r-call stop "unknown engine specified")))) (return arg)) ()))
+ (<- pploadcenginemodule (function ((*named* filename *r-missing*) (*named* name "")) (r-block (<- res (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:load_module" 1 0 filename name)) (return (r-call r-aref (r-call ppcommand "ppemode2_getelement" (r-call r-index (r-call r-aref res 1) 1) 0) 2))) ()))
+ (<- ppunloadcenginemodule (function ((*named* name *r-missing*)) (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*) ()))
+ (<- pploadpackage (function ((*named* filename *r-missing*) (*named* name "") (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call pploadcenginemodule filename (*named* name name)) (r-block (<- out (r-call ppcommand "ppbase_loadUserPackage" filename name)) (if (r-call > (r-call length out) 1) (r-block (r-call warning (r-call r-index out 2)) (return (r-call r-index out 1)))) (return out)))) ()))
+ (<- ppunloadpackage (function ((*named* name *r-missing*) (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*) ())))
--- /dev/null
+++ b/femtolisp/ast/system.lsp
@@ -1,0 +1,511 @@
+; femtoLisp standard library
+; by Jeff Bezanson
+; Public Domain
+
+(set 'list (lambda args args))
+
+(set 'setq (macro (name val)
+ (list set (list 'quote name) val)))
+
+(setq sp '| |)
+(setq nl '|
+|)
+
+; 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)
+ (cond ((atom e) e)
+ ((eq (cdr e) ()) (car e))
+ (T (cons 'progn e)))))
+
+(setq defmacro
+ (macro (name args . body)
+ (list 'setq name (list 'macro args (f-body body)))))
+
+; support both CL defun and Scheme-style define
+(defmacro defun (name args . body)
+ (list 'setq name (list 'lambda args (f-body body))))
+
+(defmacro define (name . body)
+ (if (symbolp name)
+ (list 'setq name (car body))
+ (cons 'defun (cons (car name) (cons (cdr name) body)))))
+
+(defun identity (x) x)
+(setq null not)
+(defun consp (x) (not (atom x)))
+
+(defun map (f lst)
+ (if (atom lst) lst
+ (cons (f (car lst)) (map f (cdr lst)))))
+
+(defmacro 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)))
+
+(defun nconc lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (T ((lambda (l d) (if (null l) d
+ (prog1 l
+ (while (consp (cdr l)) (set 'l (cdr l)))
+ (rplacd l d))))
+ (car lsts) (apply nconc (cdr lsts))))))
+
+(defun append lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (T ((label append2 (lambda (l d)
+ (if (null l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (apply append (cdr lsts))))))
+
+(defun member (item lst)
+ (cond ((atom lst) ())
+ ((equal (car lst) item) lst)
+ (T (member item (cdr lst)))))
+
+(defun macrop (e) (and (consp e) (eq (car e) 'macro) e))
+(defun macrocallp (e) (and (symbolp (car e))
+ (boundp (car e))
+ (macrop (eval (car e)))))
+(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args))
+
+(defun macroexpand-1 (e)
+ (if (atom e) e
+ (let ((f (macrocallp e)))
+ (if f (macroapply f (cdr e))
+ e))))
+
+; convert to proper list, i.e. remove "dots", and append
+(defun 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)))
+
+(defun macroexpand (e)
+ ((label mexpand
+ (lambda (e env f)
+ (progn
+ (while (and (consp e)
+ (not (member (car e) env))
+ (set 'f (macrocallp e)))
+ (set 'e (macroapply f (cdr e))))
+ (if (and (consp e)
+ (not (eq (car e) 'quote)))
+ (let ((newenv
+ (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro))
+ (consp (cdr e)))
+ (append.2 (cadr e) env)
+ env)))
+ (map (lambda (x) (mexpand x newenv nil)) e))
+ e))))
+ e nil nil))
+
+; 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 (list 'lambda args (macroexpand (f-body body)))))
+
+; same thing for macros. enabled by default because macros are usually
+; defined at the top level.
+(defmacro defmacro (name args . body)
+ (list 'setq name (list 'macro args (macroexpand (f-body body)))))
+
+(setq = eq)
+(setq eql eq)
+(define (/= a b) (not (eq a b)))
+(define != /=)
+(define (> a b) (< b a))
+(define (<= a b) (not (< b a)))
+(define (>= a b) (not (< a b)))
+(define (1+ n) (+ n 1))
+(define (1- n) (- n 1))
+(define (mod x y) (- x (* (/ x y) y)))
+(define (abs x) (if (< x 0) (- x) x))
+(define (truncate x) x)
+(setq K prog1) ; K combinator ;)
+(define (funcall f . args) (apply f args))
+(define (symbol-function sym) (eval sym))
+(define (symbol-value sym) (eval sym))
+
+(define (caar x) (car (car x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+
+(define (equal a b)
+ (if (and (consp a) (consp b))
+ (and (equal (car a) (car b))
+ (equal (cdr a) (cdr b)))
+ (eq a b)))
+
+; compare imposes an ordering on all values. yields -1 for a<b,
+; 0 for a==b, and 1 for a>b. lists are compared up to the first
+; point of difference.
+(defun compare (a b)
+ (cond ((eq a b) 0)
+ ((or (atom a) (atom b)) (if (< a b) -1 1))
+ (T (let ((c (compare (car a) (car b))))
+ (if (not (eq c 0))
+ c
+ (compare (cdr a) (cdr b)))))))
+
+(defun every (pred lst)
+ (or (atom lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(defun any (pred lst)
+ (and (consp lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(defun listp (a) (or (eq a ()) (consp a)))
+
+(defun length (l)
+ (if (null l) 0
+ (+ 1 (length (cdr l)))))
+
+(defun nthcdr (n lst)
+ (if (<= n 0) lst
+ (nthcdr (- n 1) (cdr lst))))
+
+(defun list-ref (lst n)
+ (car (nthcdr n lst)))
+
+(defun list* l
+ (if (atom (cdr l))
+ (car l)
+ (cons (car l) (apply list* (cdr l)))))
+
+(defun nlist* l
+ (if (atom (cdr l))
+ (car l)
+ (rplacd l (apply nlist* (cdr l)))))
+
+(defun lastcdr (l)
+ (if (atom l) l
+ (lastcdr (cdr l))))
+
+(defun last (l)
+ (cond ((atom l) l)
+ ((atom (cdr l)) l)
+ (T (last (cdr l)))))
+
+(defun map! (f lst)
+ (prog1 lst
+ (while (consp lst)
+ (rplaca lst (f (car lst)))
+ (set 'lst (cdr lst)))))
+
+(defun mapcar (f . lsts)
+ ((label mapcar-
+ (lambda (lsts)
+ (cond ((null lsts) (f))
+ ((atom (car lsts)) (car lsts))
+ (T (cons (apply f (map car lsts))
+ (mapcar- (map cdr lsts)))))))
+ lsts))
+
+(defun transpose (M) (apply mapcar (cons list M)))
+
+(defun filter (pred lst)
+ (cond ((null lst) ())
+ ((not (pred (car lst))) (filter pred (cdr lst)))
+ (T (cons (car lst) (filter pred (cdr lst))))))
+
+(define (foldr f zero lst)
+ (if (null lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (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 (copy-list l)
+ (if (atom l) l
+ (cons (car l)
+ (copy-list (cdr l)))))
+(define (copy-tree l)
+ (if (atom l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (assoc item lst)
+ (cond ((atom lst) ())
+ ((eq (caar lst) item) (car lst))
+ (T (assoc item (cdr lst)))))
+
+(define (nreverse l)
+ (let ((prev nil))
+ (while (consp l)
+ (set 'l (prog1 (cdr l)
+ (rplacd l (prog1 prev
+ (set 'prev l))))))
+ prev))
+
+(defmacro let* (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons 'progn
+ (nconc (map (lambda (b) (cons 'setq b)) binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro labels (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons 'progn
+ (nconc (map (lambda (b)
+ (list 'setq (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro when (c . body) (list if c (f-body body) nil))
+(defmacro unless (c . body) (list if c nil (f-body body)))
+
+(defmacro dotimes (var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ (list 'let (list (list v 0))
+ (list 'while (list < v cnt)
+ (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
+
+(defun map-int (f n)
+ (let ((acc nil))
+ (dotimes (i n)
+ (setq acc (cons (f i) acc)))
+ (nreverse acc)))
+
+(defun error args (raise (cons 'error args)))
+
+(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value)))
+(defmacro 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))))))
+
+(defmacro unwind-protect (expr finally)
+ (let ((e (gensym)))
+ `(prog1 (trycatch ,expr
+ (lambda (,e) (progn ,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)
+ (let* ((e (gensym))
+ (reraised (gensym))
+ (final (f-body (cdr (or (assoc 'finally forms) '(())))))
+ (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
+ (catchblock `(cond
+ ,.(map (lambda (catc)
+ (let* ((specific (cdr (cadr catc)))
+ (extype (caadr catc))
+ (var (if specific (car specific)
+ extype))
+ (todo (cddr catc)))
+ `(,(if specific
+ ; exception matching logic
+ `(or (eq ,e ',extype)
+ (and (consp ,e)
+ (eq (car ,e)
+ ',extype)))
+ T); (catch (e) ...), match anything
+ (let ((,var ,e)) ,@todo))))
+ catches)
+ (T (raise ,e))))) ; no matches, reraise
+ (if final
+ (if catches
+ ; form with both catch and finally
+ `(prog1 (trycatch ,expr
+ (lambda (,e)
+ (trycatch ,catchblock
+ (lambda (,reraised)
+ (progn ,final
+ (raise ,reraised))))))
+ ,final)
+ ; finally only; same as unwind-protect
+ `(prog1 (trycatch ,expr (lambda (,e)
+ (progn ,final (raise ,e))))
+ ,final))
+ ; catch, no finally
+ `(trycatch ,expr (lambda (,e) ,catchblock)))))
+
+; property lists
+(setq *plists* nil)
+
+(defun symbol-plist (sym)
+ (cdr (or (assoc sym *plists*) '(()))))
+
+(defun set-symbol-plist (sym lst)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (cons sym lst) *plists*))
+ (rplacd p lst))))
+
+(defun get (sym prop)
+ (let ((pl (symbol-plist sym)))
+ (if pl
+ (let ((pr (member prop pl)))
+ (if pr (cadr pr) nil))
+ nil)))
+
+(defun put (sym prop val)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (list sym prop val) *plists*))
+ (let ((pr (member prop p)))
+ (if (null pr) ; sym doesn't have this property yet
+ (rplacd p (cons prop (cons val (cdr p))))
+ (rplaca (cdr pr) val)))))
+ val)
+
+; 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*
+ ; place mutator f
+ '((car rplaca identity)
+ (cdr rplacd identity)
+ (caar rplaca car)
+ (cadr rplaca cdr)
+ (cdar rplacd car)
+ (cddr rplacd cdr)
+ (caaar rplaca caar)
+ (caadr rplaca cadr)
+ (cadar rplaca cdar)
+ (caddr rplaca cddr)
+ (cdaar rplacd caar)
+ (cdadr rplacd cadr)
+ (cddar rplacd cdar)
+ (cdddr rplacd cddr)
+ (get put identity)
+ (aref aset identity)
+ (symbol-function set identity)
+ (symbol-value set identity)
+ (symbol-plist set-symbol-plist identity)))
+
+(defun setf-place-mutator (place val)
+ (if (symbolp place)
+ (list 'setq place val)
+ (let ((mutator (assoc (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))))))
+
+(defmacro 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))
+
+(defun list-to-vector (l) (apply vector l))
+(defun vector-to-list (v)
+ (let ((i (- (length v) 1))
+ (l nil))
+ (while (>= i 0)
+ (setq l (cons (aref v i) l))
+ (setq i (- i 1)))
+ l))
+
+(defun self-evaluating-p (x)
+ (or (eq x nil)
+ (eq x T)
+ (and (atom x)
+ (not (symbolp x)))))
+
+(defun functionp (x)
+ (or (builtinp x)
+ (and (consp x) (eq (car x) 'lambda))))
+
+; backquote
+(defmacro backquote (x) (bq-process x))
+
+(defun splice-form-p (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)
+ (if (vectorp x)
+ (let ((body (bq-process (vector-to-list x))))
+ (if (eq (car body) 'list)
+ (cons vector (cdr body))
+ (list apply vector body)))
+ x))
+ ((atom x) (list 'quote x))
+ ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
+ ((eq (car x) '*comma*) (cadr x))
+ ((not (any splice-form-p x))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null lc)
+ (cons 'list forms)
+ (nconc (cons 'nlist* forms) (list (bq-process lc))))))
+ (T (let ((p x) (q ()))
+ (while (and (consp p)
+ (not (eq (car p) '*comma*)))
+ (setq q (cons (bq-bracket (car p)) q))
+ (setq p (cdr p)))
+ (let ((forms
+ (cond ((consp p) (nreconc q (list (cadr p))))
+ ((null p) (nreverse q))
+ (T (nreconc q (list (bq-process p)))))))
+ (if (null (cdr forms))
+ (car forms)
+ (cons 'nconc forms)))))))
+
+(defun bq-bracket (x)
+ (cond ((atom x) (list cons (bq-process x) nil))
+ ((eq (car x) '*comma*) (list cons (cadr x) nil))
+ ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
+ ((eq (car x) '*comma-dot*) (cadr x))
+ (T (list cons (bq-process x) nil))))
+
+; bracket without splicing
+(defun bq-bracket1 (x)
+ (if (and (consp x) (eq (car x) '*comma*))
+ (cadr x)
+ (bq-process x)))
+
+(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr))))
--- /dev/null
+++ b/femtolisp/attic/flutils.c
@@ -1,0 +1,59 @@
+typedef struct {+ size_t n, maxsize;
+ unsigned long *items;
+} ltable_t;
+
+void ltable_init(ltable_t *t, size_t n)
+{+ t->n = 0;
+ t->maxsize = n;
+ t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
+}
+
+void ltable_clear(ltable_t *t)
+{+ t->n = 0;
+}
+
+void ltable_insert(ltable_t *t, unsigned long item)
+{+ unsigned long *p;
+
+ if (t->n == t->maxsize) {+ p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
+ if (p == NULL) return;
+ t->items = p;
+ t->maxsize *= 2;
+ }
+ t->items[t->n++] = item;
+}
+
+#define LT_NOTFOUND ((int)-1)
+
+int ltable_lookup(ltable_t *t, unsigned long item)
+{+ int i;
+ for(i=0; i < (int)t->n; i++)
+ if (t->items[i] == item)
+ return i;
+ return LT_NOTFOUND;
+}
+
+void ltable_adjoin(ltable_t *t, unsigned long item)
+{+ if (ltable_lookup(t, item) == LT_NOTFOUND)
+ ltable_insert(t, item);
+}
+
+char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
+{+ size_t i=n-1;
+
+ nbuf[i--] = '\0';
+ do {+ nbuf[i--] = '0' + g%10;
+ g/=10;
+ } while (g && i);
+ nbuf[i] = 'g';
+ return &nbuf[i];
+}
--- /dev/null
+++ b/femtolisp/attic/plists.lsp
@@ -1,0 +1,28 @@
+; property lists. they really suck.
+(setq *plists* nil)
+
+(defun symbol-plist (sym)
+ (cdr (or (assoc sym *plists*) '(()))))
+
+(defun set-symbol-plist (sym lst)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (cons sym lst) *plists*))
+ (rplacd p lst))))
+
+(defun get (sym prop)
+ (let ((pl (symbol-plist sym)))
+ (if pl
+ (let ((pr (member prop pl)))
+ (if pr (cadr pr) nil))
+ nil)))
+
+(defun put (sym prop val)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (list sym prop val) *plists*))
+ (let ((pr (member prop p)))
+ (if (null pr) ; sym doesn't have this property yet
+ (rplacd p (cons prop (cons val (cdr p))))
+ (rplaca (cdr pr) val)))))
+ val)
--- /dev/null
+++ b/femtolisp/attic/s.c
@@ -1,0 +1,212 @@
+#include <stdio.h>
+
+struct _b {+ char a;
+ short b:9;
+};
+
+struct _bb {+ char a;
+ int :0;
+ int b:10;
+ int :0;
+ int b0:10;
+ int :0;
+ int b1:10;
+ int :0;
+ int b2:10;
+ int :0;
+ int b4:30;
+ char c;
+};
+
+union _cc {+ struct {+ char a;
+ int b:1; // bit 8
+ int b1:1; // bit 9
+ int b2:24; // bits 32..55
+ char c;
+ };
+ unsigned long long ull;
+};
+
+union _cc2 {+ struct {+ char a;
+ int b:24; // bit 8
+ int b1:1;
+ int b2:1;
+ char c;
+ };
+ unsigned long long ull;
+};
+
+union _dd {+ struct {+ int a0:10;
+ int a1:10;
+ int a2:10;
+ int a3:10;
+ int a4:10;
+ };
+ struct {+ unsigned long long ull;
+ };
+};
+
+struct _ee {+ short s:9;
+ short j:9;
+ char c;
+};
+
+typedef long long int int64_t;
+typedef unsigned long long int uint64_t;
+typedef int int32_t;
+typedef unsigned int uint32_t;
+typedef short int16_t;
+typedef unsigned short uint16_t;
+typedef char int8_t;
+typedef unsigned char uint8_t;
+
+#define lomask(type,n) (type)((((type)1)<<(n))-1)
+
+uint64_t get_u_bitfield(char *ptr, int typesz, int boffs, int blen)
+{+ uint64_t i8;
+ uint32_t i4;
+ uint16_t i2;
+ uint8_t i1;
+
+ switch (typesz) {+ case 8:
+ i8 = *(uint64_t*)ptr;
+ return (i8>>boffs) & lomask(uint64_t,blen);
+ case 4:
+ i4 = *(uint32_t*)ptr;
+ return (i4>>boffs) & lomask(uint32_t,blen);
+ case 2:
+ i2 = *(uint16_t*)ptr;
+ return (i2>>boffs) & lomask(uint16_t,blen);
+ case 1:
+ i1 = *(uint8_t*)ptr;
+ return (i1>>boffs) & lomask(uint8_t,blen);
+ }
+ //error
+ return 0;
+}
+
+int64_t get_s_bitfield(char *ptr, int typesz, int boffs, int blen)
+{+ int64_t i8;
+ int32_t i4;
+ int16_t i2;
+ int8_t i1;
+
+ switch (typesz) {+ case 8:
+ i8 = *(int64_t*)ptr;
+ return (i8<<(64-boffs-blen))>>(64-blen);
+ case 4:
+ i4 = *(int32_t*)ptr;
+ return (i4<<(32-boffs-blen))>>(32-blen);
+ case 2:
+ i2 = *(int16_t*)ptr;
+ return (i2<<(16-boffs-blen))>>(16-blen);
+ case 1:
+ i1 = *(int8_t*)ptr;
+ return (i1<<(8-boffs-blen))>>(8-blen);
+ }
+ //error
+ return 0;
+}
+
+void set_bitfield(char *ptr, int typesz, int boffs, int blen, uint64_t v)
+{+ uint64_t i8, m8;
+ uint32_t i4, m4;
+ uint16_t i2, m2;
+ uint8_t i1, m1;
+
+ switch (typesz) {+ case 8:
+ m8 = lomask(uint64_t,blen)<<boffs;
+ i8 = *(uint64_t*)ptr;
+ *(uint64_t*)ptr = (i8&~m8) | ((v<<boffs)&m8);
+ break;
+ case 4:
+ m4 = lomask(uint32_t,blen)<<boffs;
+ i4 = *(uint32_t*)ptr;
+ *(uint32_t*)ptr = (i4&~m4) | ((v<<boffs)&m4);
+ break;
+ case 2:
+ m2 = lomask(uint16_t,blen)<<boffs;
+ i2 = *(uint16_t*)ptr;
+ *(uint16_t*)ptr = (i2&~m2) | ((v<<boffs)&m2);
+ break;
+ case 1:
+ m1 = lomask(uint8_t,blen)<<boffs;
+ i1 = *(uint8_t*)ptr;
+ *(uint8_t*)ptr = (i1&~m1) | ((v<<boffs)&m1);
+ break;
+ }
+}
+
+int main()
+{+ union _cc2 c;
+ union _dd d;
+ printf("%d\n", sizeof(struct _b));+
+ printf("%d\n", sizeof(d));+ //printf("%d\n\n", sizeof(struct _bb));+
+ //printf("%d\n", (char*)&b.b - (char*)&b);+ //printf("%d\n", (char*)&b.c - (char*)&b);+ //printf("%d\n", (char*)&b.e - (char*)&b);+
+ c.ull = 0;
+ d.ull = 0;
+ //d.ull2 = 0;
+
+ d.a0 = d.a1 = d.a2 = d.a3 = d.a4 = 1;
+ printf("0x%016llx\n", d.ull);+ unsigned long long m = 1;
+ int bn = 0;
+ while (m) {+ if (d.ull & m)
+ printf("bit %d set\n", bn);+ bn++;
+ m<<=1;
+ }
+ //printf("%016x\n", d.ull2);+
+
+ c.a = 1;
+ c.b = 1;
+ c.c = 1;
+ printf("0x%016llx\n", c.ull);+ bn=0;m=1;
+ while (m) {+ if (c.ull & m)
+ printf("bit %d set\n", bn);+ bn++;
+ m<<=1;
+ }
+
+ return 0;
+}
+
+/*
+ offset/alignment rules for bit fields:
+
+ - alignment for whole struct is still the most strict of any of the
+ named types, regardless of bit fields. (i.e. just take the bit field
+ widths away and compute struct alignment normally)
+
+ - a bit field cannot cross a word boundary of its declared type
+
+ - otherwise pack bit fields as tightly as possible
+
+ */
--- /dev/null
+++ b/femtolisp/attic/system-old.lsp
@@ -1,0 +1,25 @@
+(define (equal a b)
+ (if (and (consp a) (consp b))
+ (and (equal (car a) (car b))
+ (equal (cdr a) (cdr b)))
+ (eq a b)))
+
+; compare imposes an ordering on all values. yields -1 for a<b,
+; 0 for a==b, and 1 for a>b. lists are compared up to the first
+; point of difference.
+(defun compare (a b)
+ (cond ((eq a b) 0)
+ ((or (atom a) (atom b)) (if (< a b) -1 1))
+ (T (let ((c (compare (car a) (car b))))
+ (if (not (eq c 0))
+ c
+ (compare (cdr a) (cdr b)))))))
+
+(defun length (l)
+ (if (null l) 0
+ (+ 1 (length (cdr l)))))
+
+(define (assoc item lst)
+ (cond ((atom lst) ())
+ ((eq (caar lst) item) (car lst))
+ (T (assoc item (cdr lst)))))
--- /dev/null
+++ b/femtolisp/attic/trash.c
@@ -1,0 +1,117 @@
+value_t prim_types[32];
+value_t *prim_sym_addrs[] = {+ &int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym,
+ &int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym,
+ &intsym, &uintsym, &longsym, &ulongsym,
+ &lispvaluesym };
+#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*))
+
+static value_t cv_type(cvalue_t *cv)
+{+ if (cv->flags.prim) {+ return prim_types[cv->flags.primtype];
+ }
+ return cv->type;
+}
+
+
+ double t0,t1;
+ int i;
+ int32_t i32;
+ char s8;
+ ulong_t c8=3;
+ t0 = clock(); //0.058125017
+ set_secret_symtag(ulongsym,TAG_UINT32);
+ set_secret_symtag(int8sym,TAG_INT8);
+ for(i=0; i < 8000000; i++) {+ cnvt_to_int32(&i32, &s8, int8sym);
+ c8+=c8;
+ s8+=s8;
+ }
+ t1 = clock();
+ printf("%d. that took %.16f\n", i32, t1-t0);+
+
+#define int_converter(type) \
+static int cnvt_to_##type(type##_t *i, void *data, value_t type) \
+{ \+ if (type==int32sym) *i = *(int32_t*)data; \
+ else if (type==charsym) *i = *(char*)data; \
+ else if (type==ulongsym) *i = *(ulong*)data; \
+ else if (type==uint32sym) *i = *(uint32_t*)data; \
+ else if (type==int8sym) *i = *(int8_t*)data; \
+ else if (type==uint8sym) *i = *(uint8_t*)data; \
+ else if (type==int64sym) *i = *(int64_t*)data; \
+ else if (type==uint64sym) *i = *(uint64_t*)data; \
+ else if (type==wcharsym) *i = *(wchar_t*)data; \
+ else if (type==longsym) *i = *(long*)data; \
+ else if (type==int16sym) *i = *(int16_t*)data; \
+ else if (type==uint16sym) *i = *(uint16_t*)data; \
+ else \
+ return 1; \
+ return 0; \
+}
+int_converter(int32)
+int_converter(uint32)
+int_converter(int64)
+int_converter(uint64)
+
+#ifdef BITS64
+#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t)
+#else
+#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t)
+#endif
+
+long intabs(long n)
+{+ long s = n>>(NBITS-1); // either -1 or 0
+ return (n^s) - s;
+}
+
+value_t fl_inv(value_t b)
+{+ int_t bi;
+ int tb;
+ void *bptr=NULL;
+ cvalue_t *cv;
+
+ if (isfixnum(b)) {+ bi = numval(b);
+ if (bi == 0)
+ goto inv_error;
+ else if (bi == 1)
+ return fixnum(1);
+ else if (bi == -1)
+ return fixnum(-1);
+ return fixnum(0);
+ }
+ else if (iscvalue(b)) {+ cv = (cvalue_t*)ptr(b);
+ tb = cv_numtype(cv);
+ if (tb <= T_DOUBLE)
+ bptr = cv_data(cv);
+ }
+ if (bptr == NULL)
+ type_error("/", "number", b);+
+ if (tb == T_FLOAT)
+ return mk_double(1.0/(double)*(float*)bptr);
+ if (tb == T_DOUBLE)
+ return mk_double(1.0 / *(double*)bptr);
+
+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr > 1)
+ return fixnum(0);
+ else if (*(uint64_t*)bptr == 1)
+ return fixnum(1);
+ goto inv_error;
+ }
+ int64_t b64 = conv_to_int64(bptr, tb);
+ if (b64 == 0) goto inv_error;
+ else if (b64 == 1) return fixnum(1);
+ else if (b64 == -1) return fixnum(-1);
+
+ return fixnum(0);
+ inv_error:
+ lerror(DivideError, "/: division by zero");
+}
--- /dev/null
+++ b/femtolisp/builtins.c
@@ -1,0 +1,582 @@
+/*
+ Extra femtoLisp builtin functions
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <errno.h>
+#include "llt.h"
+#include "flisp.h"
+
+size_t llength(value_t v)
+{+ size_t n = 0;
+ while (iscons(v)) {+ n++;
+ v = cdr_(v);
+ }
+ return n;
+}
+
+value_t list_nth(value_t l, size_t n)
+{+ while (n && iscons(l)) {+ l = cdr_(l);
+ n--;
+ }
+ if (iscons(l)) return car_(l);
+ return NIL;
+}
+
+value_t fl_print(value_t *args, u_int32_t nargs)
+{+ unsigned i;
+ for (i=0; i < nargs; i++)
+ print(stdout, args[i], 0);
+ fputc('\n', stdout);+ return nargs ? args[nargs-1] : NIL;
+}
+
+value_t fl_princ(value_t *args, u_int32_t nargs)
+{+ unsigned i;
+ for (i=0; i < nargs; i++)
+ print(stdout, args[i], 1);
+ return nargs ? args[nargs-1] : NIL;
+}
+
+value_t fl_read(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ argcount("read", nargs, 0);+ return read_sexpr(stdin);
+}
+
+value_t fl_load(value_t *args, u_int32_t nargs)
+{+ argcount("load", nargs, 1);+ return load_file(tostring(args[0], "load"));
+}
+
+value_t fl_exit(value_t *args, u_int32_t nargs)
+{+ if (nargs > 0)
+ exit(tofixnum(args[0], "exit"));
+ exit(0);
+ return NIL;
+}
+
+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");
+ if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax)))
+ lerror(ArgError, "set-syntax: cannot define syntax for %s",
+ symbol_name(args[0]));
+ if (args[1] == NIL) {+ sym->syntax = 0;
+ }
+ else {+ if (!iscons(args[1]) || car_(args[1])!=LAMBDA)
+ type_error("set-syntax", "function", args[1]);+ sym->syntax = args[1];
+ }
+ return args[1];
+}
+
+value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
+{+ argcount("symbol-syntax", nargs, 1);+ symbol_t *sym = tosymbol(args[0], "symbol-syntax");
+ // must avoid returning built-in syntax expanders, because they
+ // 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 sym->syntax;
+}
+
+static void syntax_env_assoc_list(symbol_t *root, value_t *pv)
+{+ while (root != NULL) {+ if (root->syntax && root->syntax != TAG_CONST &&
+ !isspecial(root->syntax)) {+ PUSH(fl_cons(tagptr(root,TAG_SYM), root->syntax));
+ *pv = fl_cons(POP(), *pv);
+ }
+ syntax_env_assoc_list(root->left, pv);
+ root = root->right;
+ }
+}
+static void global_env_assoc_list(symbol_t *root, value_t *pv)
+{+ while (root != NULL) {+ if (root->binding != UNBOUND) {+ PUSH(fl_cons(tagptr(root,TAG_SYM), root->binding));
+ *pv = fl_cons(POP(), *pv);
+ }
+ global_env_assoc_list(root->left, pv);
+ root = root->right;
+ }
+}
+
+extern symbol_t *symtab;
+
+value_t fl_syntax_env(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ argcount("syntax-environment", nargs, 0);+ PUSH(NIL);
+ syntax_env_assoc_list(symtab, &Stack[SP-1]);
+ return POP();
+}
+value_t fl_global_env(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ argcount("environment", nargs, 0);+ PUSH(NIL);
+ global_env_assoc_list(symtab, &Stack[SP-1]);
+ return POP();
+}
+
+value_t fl_constantp(value_t *args, u_int32_t nargs)
+{+ argcount("constantp", nargs, 1);+ if (issymbol(args[0]))
+ return (isconstant(args[0]) ? T : NIL);
+ if (iscons(args[0]))
+ return NIL;
+ return T;
+}
+
+value_t fl_fixnum(value_t *args, u_int32_t nargs)
+{+ argcount("fixnum", nargs, 1);+ if (isfixnum(args[0]))
+ return args[0];
+ if (iscvalue(args[0])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ long i;
+ if (cv->flags.cstring) {+ char *pend;
+ errno = 0;
+ i = strtol(cv_data(cv), &pend, 0);
+ if (*pend != '\0' || errno!=0)
+ lerror(ArgError, "fixnum: invalid string");
+ return fixnum(i);
+ }
+ else if (valid_numtype(cv_numtype(cv))) {+ i = conv_to_long(cv_data(cv), cv_numtype(cv));
+ return fixnum(i);
+ }
+ }
+ lerror(ArgError, "fixnum: cannot convert argument");
+}
+
+value_t fl_truncate(value_t *args, u_int32_t nargs)
+{+ argcount("truncate", nargs, 1);+ if (isfixnum(args[0]))
+ return args[0];
+ if (iscvalue(args[0])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ void *data = cv_data(cv);
+ numerictype_t nt = cv_numtype(cv);
+ if (valid_numtype(nt)) {+ double d;
+ if (nt == T_FLOAT)
+ d = (double)*(float*)data;
+ else if (nt == T_DOUBLE)
+ d = *(double*)data;
+ else
+ return args[0];
+ if (d > 0)
+ return return_from_uint64((uint64_t)d);
+ return return_from_int64((int64_t)d);
+ }
+ }
+ type_error("truncate", "number", args[0]);+}
+
+value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
+{+ fixnum_t i;
+ value_t f, v;
+ if (nargs == 0)
+ lerror(ArgError, "vector.alloc: too few arguments");
+ i = tofixnum(args[0], "vector.alloc");
+ if (i < 0)
+ lerror(ArgError, "vector.alloc: invalid size");
+ if (nargs == 2)
+ f = args[1];
+ else
+ f = NIL;
+ v = alloc_vector((unsigned)i, f==NIL);
+ if (f != NIL) {+ int k;
+ for(k=0; k < i; k++)
+ vector_elt(v,k) = f;
+ }
+ return v;
+}
+
+int isstring(value_t v)
+{+ return (iscvalue(v) && ((cvalue_t*)ptr(v))->flags.cstring);
+}
+
+value_t fl_intern(value_t *args, u_int32_t nargs)
+{+ argcount("intern", nargs, 1);+ if (!isstring(args[0]))
+ type_error("intern", "string", args[0]);+ return symbol(cvalue_data(args[0]));
+}
+
+value_t fl_stringp(value_t *args, u_int32_t nargs)
+{+ argcount("stringp", nargs, 1);+ return isstring(args[0]) ? T : NIL;
+}
+
+value_t fl_string_length(value_t *args, u_int32_t nargs)
+{+ argcount("string.length", nargs, 1);+ if (!isstring(args[0]))
+ type_error("string.length", "string", args[0]);+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ return size_wrap(u8_charnum(cvalue_data(args[0]), len));
+}
+
+value_t fl_string_reverse(value_t *args, u_int32_t nargs)
+{+ argcount("string.reverse", nargs, 1);+ if (!isstring(args[0]))
+ type_error("string.reverse", "string", args[0]);+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ value_t ns = cvalue_string(len);
+ u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
+ return ns;
+}
+
+value_t fl_string_encode(value_t *args, u_int32_t nargs)
+{+ argcount("string.encode", nargs, 1);+ if (iscvalue(args[0])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ value_t t = cv_type(cv);
+ if (iscons(t) && car_(t) == arraysym &&
+ iscons(cdr_(t)) && car_(cdr_(t)) == wcharsym) {+ size_t nc = cv_len(cv) / sizeof(uint32_t);
+ uint32_t *ptr = (uint32_t*)cv_data(cv);
+ size_t nbytes = u8_codingsize(ptr, nc);
+ value_t str = cvalue_string(nbytes);
+ ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
+ u8_toutf8(cvalue_data(str), nbytes, ptr, nc);
+ return str;
+ }
+ }
+ type_error("string.encode", "wide character array", args[0]);+}
+
+value_t fl_string_decode(value_t *args, u_int32_t nargs)
+{+ int term=0;
+ if (nargs == 2) {+ term = (POP() != NIL);
+ nargs--;
+ }
+ argcount("string.decode", nargs, 1);+ if (!isstring(args[0]))
+ type_error("string.decode", "string", args[0]);+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ char *ptr = (char*)cv_data(cv);
+ size_t nb = cv_len(cv);
+ size_t nc = u8_charnum(ptr, nb);
+ size_t newsz = nc*sizeof(uint32_t);
+ if (term) newsz += sizeof(uint32_t);
+ value_t wcstr = cvalue(symbol_value(wcstringtypesym), newsz);
+ ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
+ uint32_t *pwc = cvalue_data(wcstr);
+ u8_toucs(pwc, nc, ptr, nb);
+ if (term) pwc[nc] = 0;
+ return wcstr;
+}
+
+value_t fl_string(value_t *args, u_int32_t nargs)
+{+ value_t cv, t;
+ u_int32_t i;
+ size_t len, sz = 0;
+ cvalue_t *temp;
+ char *data;
+ wchar_t wc;
+
+ for(i=0; i < nargs; i++) {+ if (issymbol(args[i])) {+ sz += strlen(symbol_name(args[i]));
+ continue;
+ }
+ else if (iscvalue(args[i])) {+ temp = (cvalue_t*)ptr(args[i]);
+ t = cv_type(temp);
+ if (t == charsym) {+ sz++;
+ continue;
+ }
+ else if (t == wcharsym) {+ wc = *(wchar_t*)cv_data(temp);
+ sz += u8_charlen(wc);
+ continue;
+ }
+ else if (temp->flags.cstring) {+ sz += cv_len(temp);
+ continue;
+ }
+ }
+ lerror(ArgError, "string: expected string, symbol or character");
+ }
+ cv = cvalue_string(sz);
+ char *ptr = cvalue_data(cv);
+ for(i=0; i < nargs; i++) {+ if (issymbol(args[i])) {+ char *name = symbol_name(args[i]);
+ while (*name) *ptr++ = *name++;
+ }
+ else {+ temp = (cvalue_t*)ptr(args[i]);
+ t = cv_type(temp);
+ data = cvalue_data(args[i]);
+ if (t == charsym) {+ *ptr++ = *(char*)data;
+ }
+ else if (t == wcharsym) {+ ptr += u8_wc_toutf8(ptr, *(wchar_t*)data);
+ }
+ else {+ len = cv_len(temp);
+ memcpy(ptr, data, len);
+ ptr += len;
+ }
+ }
+ }
+ return cv;
+}
+
+value_t fl_string_split(value_t *args, u_int32_t nargs)
+{+ argcount("string.split", nargs, 2);+ char *s = tostring(args[0], "string.split");
+ char *delim = tostring(args[1], "string.split");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
+ PUSH(NIL);
+ size_t ssz, tokend=0, tokstart=0, i=0;
+ value_t c=NIL;
+ size_t junk;
+ do {+ // find and allocate next token
+ tokstart = tokend = i;
+ while (i < len &&
+ !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
+ tokend = i;
+ ssz = tokend - tokstart;
+ PUSH(c); // save previous cons cell
+ c = fl_cons(cvalue_string(ssz), NIL);
+
+ // we've done allocation; reload movable pointers
+ s = cv_data((cvalue_t*)ptr(args[0]));
+ delim = cv_data((cvalue_t*)ptr(args[1]));
+
+ if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
+
+ // link new cell
+ if (Stack[SP-1] == NIL) {+ Stack[SP-2] = c; // first time, save first cons
+ (void)POP();
+ }
+ else {+ ((cons_t*)ptr(POP()))->cdr = c;
+ }
+
+ // note this tricky condition: if the string ends with a
+ // delimiter, we need to go around one more time to add an
+ // empty string. this happens when (i==len && tokend<i)
+ } while (i < len || (i==len && (tokend!=i)));
+ return POP();
+}
+
+value_t fl_string_sub(value_t *args, u_int32_t nargs)
+{+ argcount("string.sub", nargs, 3);+ char *s = tostring(args[0], "string.sub");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t i1, i2;
+ i1 = toulong(args[1], "string.sub");
+ if (i1 > len)
+ bounds_error("string.sub", args[0], args[1]);+ i2 = toulong(args[2], "string.sub");
+ if (i2 > len)
+ bounds_error("string.sub", args[0], args[2]);+ if (i2 <= i1)
+ return cvalue_string(0);
+ value_t ns = cvalue_string(i2-i1);
+ memcpy(cv_data((cvalue_t*)ptr(ns)), &s[i1], i2-i1);
+ return ns;
+}
+
+value_t fl_time_now(value_t *args, u_int32_t nargs)
+{+ argcount("time.now", nargs, 0);+ (void)args;
+ return mk_double(clock_now());
+}
+
+static double value_to_double(value_t a, char *fname)
+{+ if (isfixnum(a))
+ return (double)numval(a);
+ if (iscvalue(a)) {+ cvalue_t *cv = (cvalue_t*)ptr(a);
+ numerictype_t nt = cv_numtype(cv);
+ if (valid_numtype(nt))
+ return conv_to_double(cv_data(cv), nt);
+ }
+ type_error(fname, "number", a);
+}
+
+static value_t return_from_cstr(char *str)
+{+ size_t n = strlen(str);
+ value_t v = cvalue_string(n);
+ memcpy(cvalue_data(v), str, n);
+ return v;
+}
+
+value_t fl_time_string(value_t *args, uint32_t nargs)
+{+ argcount("time.string", nargs, 1);+ double t = value_to_double(args[0], "time.string");
+ char buf[64];
+ timestring(t, buf, sizeof(buf));
+ return return_from_cstr(buf);
+}
+
+value_t fl_path_cwd(value_t *args, uint32_t nargs)
+{+ if (nargs > 1)
+ argcount("path.cwd", nargs, 1);+ if (nargs == 0) {+ char buf[1024];
+ get_cwd(buf, sizeof(buf));
+ return return_from_cstr(buf);
+ }
+ char *ptr = tostring(args[0], "path.cwd");
+ if (set_cwd(ptr))
+ lerror(IOError, "could not cd to %s", ptr);
+ return T;
+}
+
+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 == 0)
+ return symbol_value(emptystringsym);
+ return cvalue_pinned_cstring(val);
+}
+
+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) {+ result = unsetenv(name);
+ }
+ else {+ char *val = tostring(args[1], "os.setenv");
+ result = setenv(name, val, 1);
+ }
+ if (result != 0)
+ lerror(ArgError, "os.setenv: invalid environment variable");
+ return T;
+}
+
+value_t fl_rand(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ (void)nargs;
+ return fixnum(random()&0x1fffffff);
+}
+value_t fl_rand32(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ (void)nargs;
+ return mk_uint32(random());
+}
+value_t fl_rand64(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ (void)nargs;
+ return mk_uint64(((uint64_t)random())<<32 | ((uint64_t)random()));
+}
+value_t fl_randd(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ (void)nargs;
+ return mk_double(rand_double());
+}
+
+void builtins_init()
+{+ set(symbol("set-syntax"), guestfunc(fl_setsyntax));+ set(symbol("symbol-syntax"), guestfunc(fl_symbolsyntax));+ set(symbol("syntax-environment"), guestfunc(fl_syntax_env));+ set(symbol("environment"), guestfunc(fl_global_env));+ set(symbol("constantp"), guestfunc(fl_constantp));+
+ set(symbol("print"), guestfunc(fl_print));+ set(symbol("princ"), guestfunc(fl_princ));+ set(symbol("read"), guestfunc(fl_read));+ set(symbol("load"), guestfunc(fl_load));+ set(symbol("exit"), guestfunc(fl_exit));+ set(symbol("intern"), guestfunc(fl_intern));+ set(symbol("fixnum"), guestfunc(fl_fixnum));+ set(symbol("truncate"), guestfunc(fl_truncate));+
+ set(symbol("vector.alloc"), guestfunc(fl_vector_alloc));+
+ set(symbol("string"), guestfunc(fl_string));+ set(symbol("stringp"), guestfunc(fl_stringp));+ set(symbol("string.length"), guestfunc(fl_string_length));+ set(symbol("string.split"), guestfunc(fl_string_split));+ set(symbol("string.sub"), guestfunc(fl_string_sub));+ set(symbol("string.reverse"), guestfunc(fl_string_reverse));+ set(symbol("string.encode"), guestfunc(fl_string_encode));+ set(symbol("string.decode"), guestfunc(fl_string_decode));+
+ set(symbol("time.now"), guestfunc(fl_time_now));+ set(symbol("time.string"), guestfunc(fl_time_string));+
+ set(symbol("rand"), guestfunc(fl_rand));+ set(symbol("rand.uint32"), guestfunc(fl_rand32));+ set(symbol("rand.uint64"), guestfunc(fl_rand64));+ set(symbol("rand.double"), guestfunc(fl_randd));+
+ set(symbol("path.cwd"), guestfunc(fl_path_cwd));+
+ set(symbol("os.getenv"), guestfunc(fl_os_getenv));+ set(symbol("os.setenv"), guestfunc(fl_os_setenv));+}
--- /dev/null
+++ b/femtolisp/color.lsp
@@ -1,0 +1,94 @@
+; uncomment for compatibility with CL
+;(defun mapp (f l) (mapcar f l))
+;(defmacro define (name &rest body)
+; (if (symbolp name)
+; (list 'setq name (car body))
+; (list 'defun (car name) (cdr name) (cons 'progn body))))
+
+; dictionaries ----------------------------------------------------------------
+(define (dict-new) ())
+
+(define (dict-extend dl key value)
+ (cond ((null dl) (list (cons key value)))
+ ((equal key (caar dl)) (cons (cons key value) (cdr dl)))
+ (T (cons (car dl) (dict-extend (cdr dl) key value)))))
+
+(define (dict-lookup dl key)
+ (cond ((null dl) ())
+ ((equal key (caar dl)) (cdar dl))
+ (T (dict-lookup (cdr dl) key))))
+
+(define (dict-keys dl) (map (symbol-function 'car) dl))
+
+; graphs ----------------------------------------------------------------------
+(define (graph-empty) (dict-new))
+
+(define (graph-connect g n1 n2)
+ (dict-extend
+ (dict-extend g n2 (cons n1 (dict-lookup g n2)))
+ n1
+ (cons n2 (dict-lookup g n1))))
+
+(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+
+(define (graph-neighbors g n) (dict-lookup g n))
+
+(define (graph-nodes g) (dict-keys g))
+
+(define (graph-add-node g n1) (dict-extend g n1 ()))
+
+(define (graph-from-edges edge-list)
+ (if (null edge-list)
+ (graph-empty)
+ (graph-connect (graph-from-edges (cdr edge-list))
+ (caar edge-list)
+ (cdar edge-list))))
+
+; graph coloring --------------------------------------------------------------
+(define (node-colorable? g coloring node-to-color color-of-node)
+ (not (member
+ color-of-node
+ (map
+ (lambda (n)
+ (let ((color-pair (assoc n coloring)))
+ (if (consp color-pair) (cdr color-pair) nil)))
+ (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))))))
+
+(define (color-node g coloring colors uncolored-nodes color)
+ (cond
+ ((null uncolored-nodes) coloring)
+ ((node-colorable? g coloring (car uncolored-nodes) color)
+ (let ((new-coloring
+ (cons (cons (car uncolored-nodes) color) coloring)))
+ (try-each (lambda (c)
+ (color-node g new-coloring colors (cdr uncolored-nodes) c))
+ colors)))))
+
+(define (color-graph g colors)
+ (if (null colors)
+ (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)
+ (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))
+ (dotimes (x 25)
+ (dotimes (y 25)
+ (if (and (/= x y) (can-attack x y))
+ (setq result (cons (cons x y) result)) nil)))
+ result))
--- /dev/null
+++ b/femtolisp/cvalues.c
@@ -1,0 +1,1368 @@
+#define MAX_INL_SIZE 96
+#ifdef BITS64
+#define NWORDS(sz) (((sz)+7)>>3)
+#else
+#define NWORDS(sz) (((sz)+3)>>2)
+#endif
+
+static int struct_aligns[8] = {+ sizeof(struct { char a; int8_t i; }),+ sizeof(struct { char a; int16_t i; }),+ sizeof(struct { char a; char i[3]; }),+ sizeof(struct { char a; int32_t i; }),+ sizeof(struct { char a; char i[5]; }),+ sizeof(struct { char a; char i[6]; }),+ sizeof(struct { char a; char i[7]; }),+ sizeof(struct { char a; int64_t i; }) };+static int ALIGN2, ALIGN4, ALIGN8;
+
+typedef void (*cvinitfunc_t)(value_t*, u_int32_t, void*, void*);
+
+value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
+value_t int64sym, uint64sym;
+value_t longsym, ulongsym, charsym, wcharsym;
+value_t floatsym, doublesym;
+value_t gftypesym, lispvaluesym, stringtypesym, wcstringtypesym;
+value_t emptystringsym;
+
+value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
+value_t unionsym;
+
+value_t autoreleasesym, typeofsym, sizeofsym;
+
+static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest);
+
+void cvalue_print(FILE *f, value_t v, int princ);
+// exported guest functions
+value_t cvalue_new(value_t *args, u_int32_t nargs);
+value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
+value_t cvalue_typeof(value_t *args, u_int32_t nargs);
+
+// compute the size of the metadata object for a cvalue
+static size_t cv_nwords(cvalue_t *cv)
+{+ if (cv->flags.prim) {+ if (cv->flags.inlined)
+ return 2 + NWORDS(cv->flags.inllen);
+ return 3;
+ }
+ if (cv->flags.inlined) {+ size_t s = 3 + NWORDS(cv->flags.inllen + cv->flags.cstring);
+ return (s < 5) ? 5 : s;
+ }
+ return 5;
+}
+
+void *cv_data(cvalue_t *cv)
+{+ if (cv->flags.prim) {+ if (cv->flags.inlined) {+ return &((cprim_t*)cv)->data;
+ }
+ return ((cprim_t*)cv)->data;
+ }
+ else if (cv->flags.inlined) {+ return &cv->data;
+ }
+ return cv->data;
+}
+
+void *cvalue_data(value_t v)
+{+ return cv_data((cvalue_t*)ptr(v));
+}
+
+static void autorelease(cvalue_t *cv)
+{+ cv->flags.autorelease = 1;
+ // TODO: add to finalizer list
+}
+
+value_t cvalue(value_t type, size_t sz)
+{+ cvalue_t *pcv;
+
+ if (issymbol(type)) {+ cprim_t *pcp;
+ pcp = (cprim_t*)alloc_words(2 + NWORDS(sz));
+ pcp->flagbits = INITIAL_FLAGS;
+ pcp->flags.inllen = sz;
+ pcp->flags.inlined = 1;
+ pcp->flags.prim = 1;
+ pcp->type = type;
+ return tagptr(pcp, TAG_BUILTIN);
+ }
+ PUSH(type);
+ if (sz <= MAX_INL_SIZE) {+ size_t nw = 3 + NWORDS(sz);
+ pcv = (cvalue_t*)alloc_words((nw < 5) ? 5 : nw);
+ pcv->flagbits = INITIAL_FLAGS;
+ pcv->flags.inllen = sz;
+ pcv->flags.inlined = 1;
+ }
+ else {+ pcv = (cvalue_t*)alloc_words(5);
+ pcv->flagbits = INITIAL_FLAGS;
+ pcv->flags.inlined = 0;
+ pcv->data = malloc(sz);
+ pcv->len = sz;
+ autorelease(pcv);
+ }
+ pcv->deps = NIL;
+ pcv->type = POP();
+ return tagptr(pcv, TAG_BUILTIN);
+}
+
+value_t cvalue_from_data(value_t type, void *data, size_t sz)
+{+ cvalue_t *pcv;
+ value_t cv;
+ cv = cvalue(type, sz);
+ pcv = (cvalue_t*)ptr(cv);
+ memcpy(cv_data(pcv), data, sz);
+ return cv;
+}
+
+// this effectively dereferences a pointer
+// just like *p in C, it only removes a level of indirection from the type,
+// it doesn't copy any data.
+// this method of creating a cvalue only allocates metadata.
+// ptr is user-managed; we don't autorelease it unless the
+// user explicitly calls (autorelease ) on the result of this function.
+// 'parent' is an optional cvalue that this pointer is known to point
+// into; UNBOUND if none.
+value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent)
+{+ cvalue_t *pcv;
+ value_t cv;
+
+ PUSH(parent);
+ PUSH(type);
+ pcv = (cvalue_t*)alloc_words(5);
+ pcv->flagbits = INITIAL_FLAGS;
+ pcv->flags.inlined = 0;
+ pcv->data = ptr;
+ pcv->len = sz;
+ pcv->deps = NIL;
+ pcv->type = POP();
+ parent = POP();
+ if (parent != UNBOUND) {+ // TODO: add dependency
+ }
+ cv = tagptr(pcv, TAG_BUILTIN);
+ return cv;
+}
+
+value_t cvalue_string(size_t sz)
+{+ value_t cv;
+ char *data;
+ cvalue_t *pcv;
+
+ if (sz == 0)
+ return symbol_value(emptystringsym);
+ // secretly allocate space for 1 more byte, hide a NUL there so
+ // any string will always be NUL terminated.
+ cv = cvalue(symbol_value(stringtypesym), sz+1);
+ pcv = (cvalue_t*)ptr(cv);
+ data = cv_data(pcv);
+ data[sz] = '\0';
+ if (pcv->flags.inlined)
+ pcv->flags.inllen = sz;
+ else
+ pcv->len = sz;
+ pcv->flags.cstring = 1;
+ return cv;
+}
+
+value_t cvalue_pinned_cstring(char *str)
+{+ value_t v = cvalue_from_ref(symbol_value(stringtypesym), str, strlen(str),
+ UNBOUND);
+ ((cvalue_t*)ptr(v))->flags.cstring = 1;
+ return v;
+}
+
+// convert to malloc representation (fixed address)
+/*
+static void cv_pin(cvalue_t *cv)
+{+ if (!cv->flags.inlined)
+ return;
+ size_t sz = cv->flags.inllen;
+ void *data = malloc(sz);
+ cv->flags.inlined = 0;
+ // TODO: handle flags.cstring
+ if (cv->flags.prim) {+ memcpy(data, (void*)(&((cprim_t*)cv)->data), sz);
+ ((cprim_t*)cv)->data = data;
+ }
+ else {+ memcpy(data, (void*)(&cv->data), sz);
+ cv->data = data;
+ }
+ autorelease(cv);
+}
+*/
+
+static int64_t strtoi64(char *str, char *fname)
+{+ char *pend;
+ int64_t i;
+ errno = 0;
+ i = strtoll(str, &pend, 0);
+ if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname);
+ return i;
+}
+static uint64_t strtoui64(char *str, char *fname)
+{+ char *pend;
+ uint64_t i;
+ errno = 0;
+ i = strtoull(str, &pend, 0);
+ if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname);
+ return i;
+}
+static double strtodouble(char *str, char *fname)
+{+ char *pend;
+ double d;
+ errno = 0;
+ d = strtod(str, &pend);
+ if (*pend != '\0' || errno) lerror(ArgError, "%s: invalid string", fname);
+ return d;
+}
+
+#define num_ctor(typenam, cnvt, tag, fromstr) \
+static void cvalue_##typenam##_init(value_t *args, u_int32_t nargs, \
+ void *dest, void *data) \
+{ \+ typenam##_t n=0; \
+ (void)data; \
+ if (nargs) { \+ if (iscvalue(args[0])) { \+ cvalue_t *cv = (cvalue_t*)ptr(args[0]); \
+ void *p = cv_data(cv); \
+ if (valid_numtype(cv_numtype(cv))) { \+ n = (typenam##_t)conv_to_##cnvt(p, cv_numtype(cv)); \
+ } \
+ else if (cv->flags.cstring) { \+ n = fromstr(p, #typenam); \
+ } \
+ else if (cv_len(cv) == sizeof(typenam##_t)) { \+ n = *(typenam##_t*)p; \
+ } \
+ else { \+ type_error(#typenam, "number", args[0]); \
+ } \
+ } \
+ else { \+ n = tofixnum(args[0], #typenam); \
+ } \
+ } \
+ *((typenam##_t*)dest) = n; \
+} \
+value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
+{ \+ value_t cv = cvalue(typenam##sym, sizeof(typenam##_t)); \
+ ((cprim_t*)ptr(cv))->flags.numtype = tag; \
+ cvalue_##typenam##_init(args, nargs, &((cprim_t*)ptr(cv))->data, 0); \
+ return cv; \
+} \
+value_t mk_##typenam(typenam##_t n) \
+{ \+ value_t cv = cvalue(typenam##sym, sizeof(typenam##_t)); \
+ ((cprim_t*)ptr(cv))->flags.numtype = tag; \
+ *(typenam##_t*)&((cprim_t*)ptr(cv))->data = n; \
+ return cv; \
+}
+
+num_ctor(int8, int32, T_INT8, strtoi64)
+num_ctor(uint8, uint32, T_UINT8, strtoui64)
+num_ctor(int16, int32, T_INT16, strtoi64)
+num_ctor(uint16, uint32, T_UINT16, strtoui64)
+num_ctor(int32, int32, T_INT32, strtoi64)
+num_ctor(uint32, uint32, T_UINT32, strtoui64)
+num_ctor(int64, int64, T_INT64, strtoi64)
+num_ctor(uint64, uint64, T_UINT64, strtoui64)
+num_ctor(char, uint32, T_UINT8, strtoui64)
+num_ctor(wchar, int32, T_INT32, strtoi64)
+#ifdef BITS64
+num_ctor(long, int64, T_INT64, strtoi64)
+num_ctor(ulong, uint64, T_UINT64, strtoui64)
+#else
+num_ctor(long, int32, T_INT32, strtoi64)
+num_ctor(ulong, uint32, T_UINT32, strtoui64)
+#endif
+num_ctor(float, double, T_FLOAT, strtodouble)
+num_ctor(double, double, T_DOUBLE, strtodouble)
+
+value_t size_wrap(size_t sz)
+{+ if (fits_fixnum(sz))
+ return fixnum(sz);
+ assert(sizeof(void*) == sizeof(size_t));
+ return mk_ulong(sz);
+}
+
+size_t toulong(value_t n, char *fname)
+{+ if (isfixnum(n))
+ return numval(n);
+ if (iscvalue(n)) {+ cvalue_t *cv = (cvalue_t*)ptr(n);
+ if (valid_numtype(cv_numtype(cv))) {+ return conv_to_ulong(cv_data(cv), cv_numtype(cv));
+ }
+ }
+ type_error(fname, "number", n);
+ return 0;
+}
+
+static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest,
+ void *data)
+{+ int n=0;
+ value_t syms;
+
+ (void)data;
+ argcount("enum", nargs, 2);+ syms = args[0];
+ if (!iscons(syms))
+ type_error("enum", "cons", syms);+ if (issymbol(args[1])) {+ while (iscons(syms)) {+ if (car_(syms) == args[1]) {+ *(int*)dest = n;
+ return;
+ }
+ n++;
+ syms = cdr_(syms);
+ }
+ lerror(ArgError, "enum: invalid enum value");
+ }
+ if (isfixnum(args[1])) {+ n = (int)numval(args[1]);
+ }
+ else if (iscvalue(args[1])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[1]);
+ if (!valid_numtype(cv_numtype(cv)))
+ type_error("enum", "number", args[1]);+ n = conv_to_int32(cv_data(cv), cv_numtype(cv));
+ }
+ if ((unsigned)n >= llength(syms))
+ lerror(ArgError, "enum: value out of range");
+ *(int*)dest = n;
+}
+
+value_t cvalue_enum(value_t *args, u_int32_t nargs)
+{+ argcount("enum", nargs, 2);+ value_t cv = cvalue(list2(enumsym, args[0]), 4);
+ ((cvalue_t*)ptr(cv))->flags.numtype = T_INT32;
+ cvalue_enum_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), NULL);
+ return cv;
+}
+
+static void cvalue_array_init(value_t *args, u_int32_t nargs, void *dest,
+ void *data)
+{+ size_t cnt=0, elsize, i;
+ value_t *init = NULL;
+ int junk;
+
+ if (data != 0)
+ elsize = (size_t)data; // already computed by constructor
+ else
+ elsize = ctype_sizeof(args[0], &junk);
+ char *out = (char*)dest;
+
+ if (nargs == 2) {+ if (isvector(args[1]) || iscons(args[1]) || args[1]==NIL)
+ init = &args[1];
+ else
+ cnt = toulong(args[1], "array");
+ }
+ else if (nargs == 3) {+ cnt = toulong(args[1], "array");
+ init = &args[2];
+ }
+ else {+ argcount("array", nargs, 2);+ }
+ if (init) {+ if (isvector(*init)) {+ if (cnt && vector_size(*init) != cnt)
+ lerror(ArgError, "array: size mismatch");
+ cnt = vector_size(*init);
+ for(i=0; i < cnt; i++) {+ cvalue_init(args[0], &vector_elt(*init, i), 1, out);
+ out += elsize;
+ }
+ return;
+ }
+ else if (iscons(*init) || *init==NIL) {+ for(i=0; i < cnt || cnt==0; i++) {+ if (!iscons(*init)) {+ if (cnt != 0)
+ lerror(ArgError, "array: size mismatch");
+ else
+ break;
+ }
+ cvalue_init(args[0], &car_(*init), 1, out);
+ out += elsize;
+ *init = cdr_(*init);
+ }
+ return;
+ }
+ else if (iscvalue(*init)) {+ cvalue_t *cv = (cvalue_t*)ptr(*init);
+ size_t tot = cnt*elsize;
+ if (tot == cv_len(cv)) {+ if (tot) memcpy(out, cv_data(cv), tot);
+ return;
+ }
+ }
+ else {+ type_error("array", "cons", *init);+ }
+ lerror(ArgError, "array: invalid size");
+ }
+}
+
+static size_t predict_arraylen(value_t *args, u_int32_t nargs, size_t *elsz)
+{+ int junk;
+ size_t cnt;
+
+ if (nargs < 2)
+ argcount("array", nargs, 2);+ *elsz = ctype_sizeof(args[0], &junk);
+ if (isvector(args[1])) {+ cnt = vector_size(args[1]);
+ }
+ else if (iscons(args[1])) {+ cnt = llength(args[1]);
+ }
+ else if (args[1] == NIL) {+ cnt = 0;
+ }
+ else {+ cnt = toulong(args[1], "array");
+ }
+ return cnt;
+}
+
+static value_t alloc_array(value_t type, size_t sz)
+{+ value_t cv;
+ if (car_(cdr_(type)) == charsym) {+ cv = cvalue_string(sz);
+ ((cvalue_t*)ptr(cv))->type = type;
+ }
+ else {+ cv = cvalue(type, sz);
+ }
+ return cv;
+}
+
+value_t cvalue_array(value_t *args, u_int32_t nargs)
+{+ size_t elsize, cnt, sz;
+
+ cnt = predict_arraylen(args, nargs, &elsize);
+ sz = elsize * cnt;
+
+ value_t cv = alloc_array(listn(3, arraysym, args[0], size_wrap(cnt)), sz);
+ cvalue_array_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), (void*)elsize);
+ return cv;
+}
+
+// NOTE: v must be an array
+size_t cvalue_arraylen(value_t v)
+{+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ value_t type = cv_type(cv);
+
+ if (iscons(cdr_(cdr_(type)))) {+ return toulong(car_(cdr_(cdr_(type))), "length");
+ }
+ // incomplete array type
+ int junk;
+ value_t eltype = car_(cdr_(type));
+ size_t elsize = ctype_sizeof(eltype, &junk);
+ return elsize ? cv_len(cv)/elsize : 0;
+}
+
+value_t cvalue_relocate(value_t v)
+{+ size_t nw;
+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ cvalue_t *nv;
+ value_t ncv;
+
+ if (cv->flags.moved)
+ return cv->type;
+ nw = cv_nwords(cv);
+ if (!cv->flags.islispfunction) {+ nv = (cvalue_t*)alloc_words(nw);
+ memcpy(nv, cv, nw*sizeof(value_t));
+ ncv = tagptr(nv, TAG_BUILTIN);
+ cv->type = ncv;
+ cv->flags.moved = 1;
+ }
+ else {+ // guestfunctions are permanent objects, unmanaged
+ nv = cv;
+ ncv = v;
+ }
+ nv->type = relocate(nv->type);
+ return ncv;
+}
+
+size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
+ int *palign)
+{+ value_t fld = car(cdr_(type));
+ size_t fsz, ssz = 0;
+ int al;
+ *palign = 0;
+
+ while (iscons(fld)) {+ fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
+
+ ssz = ALIGN(ssz, al);
+ if (al > *palign)
+ *palign = al;
+
+ if (!computeTotal && field==car_(car_(fld))) {+ // found target field
+ return ssz;
+ }
+
+ ssz += fsz;
+ fld = cdr_(fld);
+ }
+ return ALIGN(ssz, *palign);
+}
+
+static size_t cvalue_union_size(value_t type, int *palign)
+{+ value_t fld = car(cdr_(type));
+ size_t fsz, usz = 0;
+ int al;
+ *palign = 0;
+
+ while (iscons(fld)) {+ fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
+ if (al > *palign) *palign = al;
+ if (fsz > usz) usz = fsz;
+ fld = cdr_(fld);
+ }
+ return ALIGN(usz, *palign);
+}
+
+// *palign is an output argument giving the alignment required by type
+size_t ctype_sizeof(value_t type, int *palign)
+{+ if (type == int8sym || type == uint8sym || type == charsym) {+ *palign = 1;
+ return 1;
+ }
+ if (type == int16sym || type == uint16sym) {+ *palign = ALIGN2;
+ return 2;
+ }
+ if (type == int32sym || type == uint32sym || type == wcharsym ||
+ type == floatsym) {+ *palign = ALIGN4;
+ return 4;
+ }
+ if (type == int64sym || type == uint64sym || type == doublesym) {+ *palign = ALIGN8;
+ return 8;
+ }
+ if (type == longsym || type == ulongsym) {+#ifdef BITS64
+ *palign = ALIGN8;
+ return 8;
+#else
+ *palign = ALIGN4;
+ return 4;
+#endif
+ }
+ if (iscons(type)) {+ value_t hed = car_(type);
+ if (hed == pointersym || hed == cfunctionsym || hed == lispvaluesym) {+ *palign = struct_aligns[sizeof(void*)-1];
+ return sizeof(void*);
+ }
+ if (hed == arraysym) {+ value_t t = car(cdr_(type));
+ if (!iscons(cdr_(cdr_(type))))
+ lerror(ArgError, "sizeof: incomplete type");
+ value_t n = car_(cdr_(cdr_(type)));
+ size_t sz = toulong(n, "sizeof");
+ return sz * ctype_sizeof(t, palign);
+ }
+ else if (hed == structsym) {+ return cvalue_struct_offs(type, NIL, 1, palign);
+ }
+ else if (hed == unionsym) {+ return cvalue_union_size(type, palign);
+ }
+ else if (hed == enumsym) {+ *palign = ALIGN4;
+ return 4;
+ }
+ }
+ lerror(ArgError, "sizeof: invalid c type");
+ return 0;
+}
+
+value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
+{+ cvalue_t *cv;
+ argcount("sizeof", nargs, 1);+ if (iscvalue(args[0])) {+ cv = (cvalue_t*)ptr(args[0]);
+ return size_wrap(cv_len(cv));
+ }
+ int a;
+ return size_wrap(ctype_sizeof(args[0], &a));
+}
+
+value_t cvalue_typeof(value_t *args, u_int32_t nargs)
+{+ argcount("typeof", nargs, 1);+ switch(tag(args[0])) {+ case TAG_CONS: return conssym;
+ case TAG_NUM: return fixnumsym;
+ case TAG_SYM: return symbolsym;
+ case TAG_BUILTIN:
+ if (isbuiltin(args[0]))
+ return builtinsym;
+ if (discriminateAsVector(args[0]))
+ return vectorsym;
+ }
+ return cv_type((cvalue_t*)ptr(args[0]));
+}
+
+value_t cvalue_copy(value_t v)
+{+ assert(iscvalue(v));
+ PUSH(v);
+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ size_t nw = cv_nwords(cv);
+ value_t *pnv = alloc_words(nw);
+ v = POP(); cv = (cvalue_t*)ptr(v);
+ memcpy(pnv, cv, nw * sizeof(value_t));
+ if (!cv->flags.inlined) {+ size_t len = cv_len(cv);
+ if (cv->flags.cstring) len++;
+ void *data = malloc(len);
+ memcpy(data, cv_data(cv), len);
+ if (cv->flags.prim)
+ ((cprim_t*)pnv)->data = data;
+ else
+ ((cvalue_t*)pnv)->data = data;
+ autorelease((cvalue_t*)pnv);
+ }
+
+ return tagptr(pnv, TAG_BUILTIN);
+}
+
+static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest)
+{+ cvinitfunc_t f;
+ unsigned int i, na=0;
+
+ if (issymbol(type)) {+ f = ((symbol_t*)ptr(type))->dlcache;
+ }
+ else if (!iscons(type)) {+ f = NULL;
+ lerror(ArgError, "c-value: invalid c type");
+ }
+ else {+ value_t head = car_(type);
+ f = ((symbol_t*)ptr(head))->dlcache;
+ type = cdr_(type);
+ while (iscons(type)) {+ PUSH(car_(type));
+ na++;
+ type = cdr_(type);
+ }
+ }
+ for(i=0; i < nv; i++)
+ PUSH(vs[i]);
+ na += nv;
+ f(&Stack[SP-na], na, dest, NULL);
+ POPN(na);
+}
+
+static numerictype_t sym_to_numtype(value_t type)
+{+ if (type == int8sym)
+ return T_INT8;
+ else if (type == uint8sym || type == charsym)
+ return T_UINT8;
+ else if (type == int16sym)
+ return T_INT16;
+ else if (type == uint16sym)
+ return T_UINT16;
+#ifdef BITS64
+ else if (type == int32sym || type == wcharsym)
+#else
+ else if (type == int32sym || type == wcharsym || type == longsym)
+#endif
+ return T_INT32;
+#ifdef BITS64
+ else if (type == uint32sym)
+#else
+ else if (type == uint32sym || type == ulongsym)
+#endif
+ return T_UINT32;
+#ifdef BITS64
+ else if (type == int64sym || type == longsym)
+#else
+ else if (type == int64sym)
+#endif
+ return T_INT64;
+#ifdef BITS64
+ else if (type == uint64sym || type == ulongsym)
+#else
+ else if (type == uint64sym)
+#endif
+ return T_UINT64;
+ assert(false);
+ return N_NUMTYPES;
+}
+
+// (new type . args)
+// this provides (1) a way to allocate values with a shared type for
+// efficiency, (2) a uniform interface for allocating cvalues of any
+// type, including user-defined.
+value_t cvalue_new(value_t *args, u_int32_t nargs)
+{+ if (nargs < 1)
+ argcount("c-value", nargs, 1);+ value_t type = args[0];
+ value_t cv;
+ if (iscons(type) && car_(type) == arraysym) {+ // special case to handle incomplete array types bla[]
+ size_t elsz;
+ value_t c = cdr_(type);
+ int na=0;
+ while (iscons(c)) {+ PUSH(car_(c));
+ c = cdr_(c);
+ na++;
+ }
+ if (nargs > 1) {+ PUSH(args[1]);
+ na++;
+ }
+ size_t cnt = predict_arraylen(&Stack[SP-na], na, &elsz);
+ cv = alloc_array(type, elsz * cnt);
+ cvalue_array_init(&Stack[SP-na], na, cv_data((cvalue_t*)ptr(cv)),
+ (void*)elsz);
+ POPN(na);
+ }
+ else {+ int junk;
+ cv = cvalue(type, ctype_sizeof(type, &junk));
+ if (issymbol(type)) {+ ((cvalue_t*)ptr(cv))->flags.numtype = sym_to_numtype(type);
+ }
+ cvalue_init(type, &args[1], nargs-1, cv_data((cvalue_t*)ptr(cv)));
+ }
+ return cv;
+}
+
+// NOTE: this only compares lexicographically; it ignores numeric formats
+value_t cvalue_compare(value_t a, value_t b)
+{+ cvalue_t *ca = (cvalue_t*)ptr(a);
+ cvalue_t *cb = (cvalue_t*)ptr(b);
+ char *adata = cv_data(ca);
+ char *bdata = cv_data(cb);
+ size_t asz = cv_len(ca);
+ size_t bsz = cv_len(cb);
+ size_t minsz = asz < bsz ? asz : bsz;
+ int diff = memcmp(adata, bdata, minsz);
+ if (diff == 0) {+ if (asz > bsz)
+ return fixnum(1);
+ else if (asz < bsz)
+ return fixnum(-1);
+ }
+ return fixnum(diff);
+}
+
+static void check_addr_args(char *fname, size_t typesize, value_t *args,
+ void **data, ulong_t *index)
+{+ size_t sz;
+ if (!iscvalue(args[0]))
+ type_error(fname, "cvalue", args[0]);
+ *data = cv_data((cvalue_t*)ptr(args[0]));
+ sz = cv_len((cvalue_t*)ptr(args[0]));
+ cvalue_t *cv = (cvalue_t*)ptr(args[1]);
+ if (isfixnum(args[1]))
+ *index = numval(args[1]);
+ else if (!iscvalue(args[1]) || !valid_numtype(cv_numtype(cv)))
+ type_error(fname, "number", args[1]);
+ else
+ *index = conv_to_ulong(cv_data(cv), cv_numtype(cv));
+ if (*index > sz - typesize)
+ bounds_error(fname, args[0], args[1]);
+}
+
+value_t cvalue_get_int8(value_t *args, u_int32_t nargs)
+{+ void *data; ulong_t index;
+ argcount("get-int8", nargs, 2);+ check_addr_args("get-int8", sizeof(int8_t), args, &data, &index);+ return fixnum(((int8_t*)data)[index]);
+}
+
+value_t cvalue_set_int8(value_t *args, u_int32_t nargs)
+{+ void *data; ulong_t index; int32_t val=0;
+ argcount("set-int8", nargs, 3);+ check_addr_args("set-int8", sizeof(int8_t), args, &data, &index);+ cvalue_t *cv = (cvalue_t*)ptr(args[2]);
+ if (isfixnum(args[2]))
+ val = numval(args[2]);
+ else if (!iscvalue(args[2]) || !valid_numtype(cv_numtype(cv)))
+ type_error("set-int8", "number", args[2]);+ else
+ val = conv_to_int32(cv_data(cv), cv_numtype(cv));
+ ((int8_t*)data)[index] = val;
+ return args[2];
+}
+
+value_t guestfunc(guestfunc_t f)
+{+ value_t gf = cvalue(symbol_value(gftypesym), sizeof(void*));
+ ((cvalue_t*)ptr(gf))->data = f;
+ ((cvalue_t*)ptr(gf))->flags.islispfunction = 1;
+ size_t nw = cv_nwords((cvalue_t*)ptr(gf));
+ // directly-callable values are assumed not to move for
+ // evaluator performance, so put guestfunction metadata on the
+ // unmanaged heap
+ cvalue_t *buf = malloc(nw * sizeof(value_t));
+ memcpy(buf, ptr(gf), nw*sizeof(value_t));
+ return tagptr(buf, TAG_BUILTIN);
+}
+
+#define cv_intern(tok) tok##sym = symbol(#tok)
+#define ctor_cv_intern(tok) cv_intern(tok); set(tok##sym, guestfunc(cvalue_##tok))
+#define symbol_dlcache(s) (((symbol_t*)ptr(s))->dlcache)
+#define cache_initfunc(tok) symbol_dlcache(tok##sym) = &cvalue_##tok##_init
+
+void cvalues_init()
+{+ int i;
+
+ // compute struct field alignment required for primitives of sizes 1-8
+ for(i=0; i < 8; i++)
+ struct_aligns[i] -= (i+1);
+ ALIGN2 = struct_aligns[1];
+ ALIGN4 = struct_aligns[3];
+ ALIGN8 = struct_aligns[7];
+
+ cv_intern(uint32);
+ cv_intern(pointer);
+ cfunctionsym = symbol("c-function");+ cv_intern(lispvalue);
+ gftypesym = symbol("*guest-function-type*");+ setc(gftypesym, listn(3, cfunctionsym, lispvaluesym,
+ list2(list2(pointersym, lispvaluesym), uint32sym)));
+ set(uint32sym, guestfunc(cvalue_uint32));
+
+ ctor_cv_intern(int8);
+ ctor_cv_intern(uint8);
+ ctor_cv_intern(int16);
+ ctor_cv_intern(uint16);
+ ctor_cv_intern(int32);
+ ctor_cv_intern(int64);
+ ctor_cv_intern(uint64);
+ ctor_cv_intern(char);
+ ctor_cv_intern(wchar);
+ ctor_cv_intern(long);
+ ctor_cv_intern(ulong);
+ ctor_cv_intern(float);
+ ctor_cv_intern(double);
+
+ ctor_cv_intern(array);
+ ctor_cv_intern(enum);
+ cv_intern(struct);
+ cv_intern(union);
+ cv_intern(void);
+ set(symbol("c-value"), guestfunc(cvalue_new));+ set(symbol("get-int8"), guestfunc(cvalue_get_int8));+ set(symbol("set-int8"), guestfunc(cvalue_set_int8));+
+ cv_intern(autorelease);
+ ctor_cv_intern(typeof);
+ ctor_cv_intern(sizeof);
+
+ // set up references to the init functions for each primitive type.
+ // this is used for fast access in constructors for compound types
+ // like arrays that need to initialize (but not allocate) elements.
+ cache_initfunc(int8);
+ cache_initfunc(uint8);
+ cache_initfunc(int16);
+ cache_initfunc(uint16);
+ cache_initfunc(int32);
+ cache_initfunc(uint32);
+ cache_initfunc(int64);
+ cache_initfunc(uint64);
+ cache_initfunc(char);
+ cache_initfunc(wchar);
+ cache_initfunc(long);
+ cache_initfunc(ulong);
+ cache_initfunc(float);
+ cache_initfunc(double);
+
+ cache_initfunc(array);
+ cache_initfunc(enum);
+
+ stringtypesym = symbol("*string-type*");+ setc(stringtypesym, list2(arraysym, charsym));
+
+ wcstringtypesym = symbol("*wcstring-type*");+ setc(wcstringtypesym, list2(arraysym, wcharsym));
+
+ emptystringsym = symbol("*empty-string*");+ setc(emptystringsym, cvalue_pinned_cstring(""));+}
+
+#define RETURN_NUM_AS(var, type) return(mk_##type((type##_t)var))
+
+value_t return_from_uint64(uint64_t Uaccum)
+{+ if (fits_fixnum(Uaccum)) {+ return fixnum((fixnum_t)Uaccum);
+ }
+ if (Uaccum > (uint64_t)S64_MAX) {+ RETURN_NUM_AS(Uaccum, uint64);
+ }
+ else if (Uaccum > (uint64_t)UINT_MAX) {+ RETURN_NUM_AS(Uaccum, int64);
+ }
+ else if (Uaccum > (uint64_t)INT_MAX) {+ RETURN_NUM_AS(Uaccum, uint32);
+ }
+ RETURN_NUM_AS(Uaccum, int32);
+}
+
+value_t return_from_int64(int64_t Saccum)
+{+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ if (Saccum > (int64_t)UINT_MAX || Saccum < (int64_t)INT_MIN) {+ RETURN_NUM_AS(Saccum, int64);
+ }
+ else if (Saccum > (int64_t)INT_MAX) {+ RETURN_NUM_AS(Saccum, uint32);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+}
+
+value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
+{+ uint64_t Uaccum=0;
+ int64_t Saccum = carryIn;
+ double Faccum=0;
+ uint32_t i;
+
+ for(i=0; i < nargs; i++) {+ if (isfixnum(args[i])) {+ Saccum += numval(args[i]);
+ continue;
+ }
+ else if (iscvalue(args[i])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[i]);
+ void *a = cv_data(cv);
+ int64_t i64;
+ switch(cv_numtype(cv)) {+ case T_INT8: Saccum += *(int8_t*)a; break;
+ case T_UINT8: Saccum += *(uint8_t*)a; break;
+ case T_INT16: Saccum += *(int16_t*)a; break;
+ case T_UINT16: Saccum += *(uint16_t*)a; break;
+ case T_INT32: Saccum += *(int32_t*)a; break;
+ case T_UINT32: Saccum += *(uint32_t*)a; break;
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 > 0)
+ Uaccum += (uint64_t)i64;
+ else
+ Saccum += i64;
+ break;
+ case T_UINT64: Uaccum += *(uint64_t*)a; break;
+ case T_FLOAT: Faccum += *(float*)a; break;
+ case T_DOUBLE: Faccum += *(double*)a; break;
+ default:
+ goto add_type_error;
+ }
+ continue;
+ }
+ add_type_error:
+ type_error("+", "number", args[i]);+ }
+ if (Faccum != 0) {+ Faccum += Uaccum;
+ Faccum += Saccum;
+ return mk_double(Faccum);
+ }
+ else if (Saccum < 0) {+ uint64_t negpart = (uint64_t)(-Saccum);
+ if (negpart > Uaccum) {+ Saccum += (int64_t)Uaccum;
+ // return value in Saccum
+ if (Saccum >= INT_MIN) {+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+ }
+ RETURN_NUM_AS(Saccum, int64);
+ }
+ Uaccum -= negpart;
+ }
+ else {+ Uaccum += (uint64_t)Saccum;
+ }
+ // return value in Uaccum
+ return return_from_uint64(Uaccum);
+}
+
+value_t fl_neg(value_t n)
+{+ if (isfixnum(n)) {+ return fixnum(-numval(n));
+ }
+ else if (iscvalue(n)) {+ cvalue_t *cv = (cvalue_t*)ptr(n);
+ void *a = cv_data(cv);
+ uint32_t ui32;
+ int32_t i32;
+ int64_t i64;
+ switch(cv_numtype(cv)) {+ case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
+ case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
+ case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
+ case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
+ case T_INT32:
+ i32 = *(int32_t*)a;
+ if (i32 == (int32_t)BIT31)
+ return mk_uint32((uint32_t)BIT31);
+ return mk_int32(-i32);
+ case T_UINT32:
+ ui32 = *(uint32_t*)a;
+ if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(-(int32_t)ui32);
+ return mk_int64(-(int64_t)ui32);
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 == (int64_t)BIT63)
+ return mk_uint64((uint64_t)BIT63);
+ return mk_int64(-i64);
+ case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a);
+ case T_FLOAT: return mk_float(-*(float*)a);
+ case T_DOUBLE: return mk_double(-*(double*)a);
+ break;
+ }
+ }
+ type_error("-", "number", n);+}
+
+value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
+{+ uint64_t Uaccum=1;
+ double Faccum=1;
+ uint32_t i;
+
+ for(i=0; i < nargs; i++) {+ if (isfixnum(args[i])) {+ Saccum *= numval(args[i]);
+ continue;
+ }
+ else if (iscvalue(args[i])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[i]);
+ void *a = cv_data(cv);
+ int64_t i64;
+ switch(cv_numtype(cv)) {+ case T_INT8: Saccum *= *(int8_t*)a; break;
+ case T_UINT8: Saccum *= *(uint8_t*)a; break;
+ case T_INT16: Saccum *= *(int16_t*)a; break;
+ case T_UINT16: Saccum *= *(uint16_t*)a; break;
+ case T_INT32: Saccum *= *(int32_t*)a; break;
+ case T_UINT32: Saccum *= *(uint32_t*)a; break;
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 > 0)
+ Uaccum *= (uint64_t)i64;
+ else
+ Saccum *= i64;
+ break;
+ case T_UINT64: Uaccum *= *(uint64_t*)a; break;
+ case T_FLOAT: Faccum *= *(float*)a; break;
+ case T_DOUBLE: Faccum *= *(double*)a; break;
+ default:
+ goto mul_type_error;
+ }
+ continue;
+ }
+ mul_type_error:
+ type_error("*", "number", args[i]);+ }
+ if (Faccum != 1) {+ Faccum *= Uaccum;
+ Faccum *= Saccum;
+ return mk_double(Faccum);
+ }
+ else if (Saccum < 0) {+ Saccum *= (int64_t)Uaccum;
+ if (Saccum >= INT_MIN) {+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+ }
+ RETURN_NUM_AS(Saccum, int64);
+ }
+ else {+ Uaccum *= (uint64_t)Saccum;
+ }
+ return return_from_uint64(Uaccum);
+}
+
+value_t fl_div2(value_t a, value_t b)
+{+ double da, db;
+ int_t ai, bi;
+ int ta, tb;
+ void *aptr=NULL, *bptr=NULL;
+ cvalue_t *cv;
+
+ if (isfixnum(a)) {+ ai = numval(a);
+ aptr = &ai;
+ ta = T_FIXNUM;
+ }
+ else if (iscvalue(a)) {+ cv = (cvalue_t*)ptr(a);
+ ta = cv_numtype(cv);
+ if (ta <= T_DOUBLE)
+ aptr = cv_data(cv);
+ }
+ if (aptr == NULL)
+ type_error("/", "number", a);+ if (isfixnum(b)) {+ bi = numval(b);
+ bptr = &bi;
+ tb = T_FIXNUM;
+ }
+ else if (iscvalue(b)) {+ cv = (cvalue_t*)ptr(b);
+ tb = cv_numtype(cv);
+ if (tb <= T_DOUBLE)
+ bptr = cv_data(cv);
+ }
+ if (bptr == NULL)
+ type_error("/", "number", b);+
+ if (ta == T_FLOAT) {+ db = conv_to_double(bptr, tb);
+ da = (double)*(float*)aptr / db;
+ return mk_double(da);
+ }
+ if (ta == T_DOUBLE) {+ db = conv_to_double(bptr, tb);
+ da = *(double*)aptr / db;
+ return mk_double(da);
+ }
+ if (tb == T_FLOAT) {+ da = conv_to_double(aptr, ta);
+ da /= (double)*(float*)bptr;
+ return mk_double(da);
+ }
+ if (tb == T_DOUBLE) {+ da = conv_to_double(aptr, ta);
+ da /= *(double*)bptr;
+ return mk_double(da);
+ }
+
+ int64_t a64, b64;
+
+ if (ta == T_UINT64) {+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr == 0) goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
+ }
+ b64 = conv_to_int64(bptr, tb);
+ if (b64 < 0) {+ return return_from_int64(-(int64_t)(*(uint64_t*)aptr /
+ (uint64_t)(-b64)));
+ }
+ if (b64 == 0)
+ goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
+ }
+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr == 0) goto div_error;
+ a64 = conv_to_int64(aptr, ta);
+ if (a64 < 0) {+ return return_from_int64(-((int64_t)((uint64_t)(-a64) /
+ *(uint64_t*)bptr)));
+ }
+ return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
+ }
+
+ b64 = conv_to_int64(bptr, tb);
+ if (b64 == 0) goto div_error;
+
+ return return_from_int64(conv_to_int64(aptr, ta) / b64);
+ div_error:
+ lerror(DivideError, "/: division by zero");
+}
+
+static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
+{+ cvalue_t *cv;
+ if (iscvalue(a)) {+ cv = (cvalue_t*)ptr(a);
+ *pnumtype = cv_numtype(cv);
+ if (*pnumtype < T_FLOAT)
+ return cv_data(cv);
+ }
+ type_error(fname, "integer", a);
+ return NULL;
+}
+
+value_t fl_bitwise_not(value_t a)
+{+ cvalue_t *cv;
+ int ta;
+ void *aptr;
+
+ if (iscvalue(a)) {+ cv = (cvalue_t*)ptr(a);
+ ta = cv_numtype(cv);
+ aptr = cv_data(cv);
+ switch (ta) {+ case T_INT8: return mk_int8(~*(int8_t *)aptr);
+ case T_UINT8: return mk_uint8(~*(uint8_t *)aptr);
+ case T_INT16: return mk_int16(~*(int16_t *)aptr);
+ case T_UINT16: return mk_uint16(~*(uint16_t*)aptr);
+ case T_INT32: return mk_int32(~*(int32_t *)aptr);
+ case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
+ case T_INT64: return mk_int64(~*(int64_t *)aptr);
+ case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
+ }
+ }
+ type_error("~", "integer", a);+ return NIL;
+}
+
+#define BITSHIFT_OP(name, op) \
+value_t fl_##name(value_t a, int n) \
+{ \+ cvalue_t *cv; \
+ int ta; \
+ void *aptr; \
+ if (iscvalue(a)) { \+ cv = (cvalue_t*)ptr(a); \
+ ta = cv_numtype(cv); \
+ aptr = cv_data(cv); \
+ switch (ta) { \+ case T_INT8: return mk_int8((*(int8_t *)aptr) op n); \
+ case T_UINT8: return mk_uint8((*(uint8_t *)aptr) op n); \
+ case T_INT16: return mk_int16((*(int16_t *)aptr) op n); \
+ case T_UINT16: return mk_uint16((*(uint16_t*)aptr) op n); \
+ case T_INT32: return mk_int32((*(int32_t *)aptr) op n); \
+ case T_UINT32: return mk_uint32((*(uint32_t*)aptr) op n); \
+ case T_INT64: return mk_int64((*(int64_t *)aptr) op n); \
+ case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \
+ } \
+ } \
+ type_error(#op, "integer", a); \
+ return NIL; \
+}
+BITSHIFT_OP(shl,<<)
+BITSHIFT_OP(shr,>>)
+
+value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
+{+ int_t ai, bi;
+ int ta, tb, itmp;
+ void *aptr=NULL, *bptr=NULL, *ptmp;
+ int64_t b64;
+
+ if (isfixnum(a)) {+ ta = T_FIXNUM;
+ ai = numval(a);
+ aptr = &ai;
+ bptr = int_data_ptr(b, &tb, fname);
+ }
+ else {+ aptr = int_data_ptr(a, &ta, fname);
+ if (isfixnum(b)) {+ tb = T_FIXNUM;
+ bi = numval(b);
+ bptr = &bi;
+ }
+ else {+ bptr = int_data_ptr(b, &tb, fname);
+ }
+ }
+ if (ta < tb) {+ itmp = ta; ta = tb; tb = itmp;
+ ptmp = aptr; aptr = bptr; bptr = ptmp;
+ }
+ // now a's type is larger than or same as b's
+ b64 = conv_to_int64(bptr, tb);
+ switch (opcode) {+ case 0:
+ switch (ta) {+ case T_INT8: return mk_int8( *(int8_t *)aptr & (int8_t )b64);
+ case T_UINT8: return mk_uint8( *(uint8_t *)aptr & (uint8_t )b64);
+ case T_INT16: return mk_int16( *(int16_t*)aptr & (int16_t )b64);
+ case T_UINT16: return mk_uint16(*(uint16_t*)aptr & (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
+ }
+ break;
+ case 1:
+ switch (ta) {+ case T_INT8: return mk_int8( *(int8_t *)aptr | (int8_t )b64);
+ case T_UINT8: return mk_uint8( *(uint8_t *)aptr | (uint8_t )b64);
+ case T_INT16: return mk_int16( *(int16_t*)aptr | (int16_t )b64);
+ case T_UINT16: return mk_uint16(*(uint16_t*)aptr | (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
+ }
+ break;
+ case 2:
+ switch (ta) {+ case T_INT8: return mk_int8( *(int8_t *)aptr ^ (int8_t )b64);
+ case T_UINT8: return mk_uint8( *(uint8_t *)aptr ^ (uint8_t )b64);
+ case T_INT16: return mk_int16( *(int16_t*)aptr ^ (int16_t )b64);
+ case T_UINT16: return mk_uint16(*(uint16_t*)aptr ^ (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
+ }
+ }
+ assert(0);
+ return NIL;
+}
--- /dev/null
+++ b/femtolisp/dict.lsp
@@ -1,0 +1,51 @@
+; dictionary as binary tree
+
+(defun dict () ())
+
+; node representation ((k . v) L R)
+(defun dict-peek (d key nf)
+ (if (null d) nf
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (cdar d))
+ ((< c 0) (dict-peek (cadr d) key nf))
+ (T (dict-peek (caddr d) key nf))))))
+
+(defun dict-get (d key) (dict-peek d key nil))
+
+(defun dict-put (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
+ ((< c 0) (list (car d)
+ (dict-put (cadr d) key v)
+ (caddr d)))
+ (T (list (car d)
+ (cadr d)
+ (dict-put (caddr d) key v)))))))
+
+; mutable dictionary
+(defun dict-nput (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (rplacd (car d) v))
+ ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v)))
+ (T (setf (caddr d) (dict-nput (caddr d) key v))))
+ d)))
+
+(defun dict-collect (f d)
+ (if (null d) ()
+ (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d))
+ (dict-collect f (caddr d))))))
+
+(defun dict-keys (d) (dict-collect K d))
+(defun dict-pairs (d) (dict-collect cons d))
+
+(defun dict-each (f d)
+ (if (null d) ()
+ (progn (f (caar d) (cdar d))
+ (dict-each f (cadr d))
+ (dict-each f (caddr d)))))
+
+(defun alist-to-dict (a)
+ (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
+ (dict) a))
--- /dev/null
+++ b/femtolisp/equal.c
@@ -1,0 +1,253 @@
+#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"
+
+// comparable with ==
+#define eq_comparable(a,b) (!(((a)|(b))&0x1))
+
+// is it a leaf? (i.e. does not lead to other values)
+static inline int leafp(value_t a)
+{+ return (!iscons(a) && !isvector(a));
+}
+
+static value_t eq_class(ptrhash_t *table, value_t key)
+{+ value_t c = (value_t)ptrhash_get(table, (void*)key);
+ if (c == (value_t)PH_NOTFOUND)
+ return NIL;
+ if (c == key)
+ return c;
+ return eq_class(table, c);
+}
+
+static void eq_union(ptrhash_t *table, value_t a, value_t b,
+ value_t c, value_t cb)
+{+ value_t ca = (c==NIL ? a : c);
+ if (cb != NIL)
+ ptrhash_put(table, (void*)cb, (void*)ca);
+ ptrhash_put(table, (void*)a, (void*)ca);
+ ptrhash_put(table, (void*)b, (void*)ca);
+}
+
+// a is a fixnum, b is a cvalue
+static int compare_num_cvalue(value_t a, value_t b)
+{+ cvalue_t *bcv = (cvalue_t*)ptr(b);
+ numerictype_t bt;
+ if (valid_numtype(bt=cv_numtype(bcv))) {+ fixnum_t ia = numval(a);
+ void *bptr = cv_data(bcv);
+ if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
+ return 0;
+ if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
+ return -1;
+ }
+ else {+ return -1;
+ }
+ return 1;
+}
+
+static value_t bounded_compare(value_t a, value_t b, int bound);
+static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table);
+
+static value_t bounded_vector_compare(value_t a, value_t b, int bound)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ m = la < lb ? la : lb;
+ for (i = 0; i < m; i++) {+ value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i), bound-1);
+ if (d==NIL || numval(d)!=0) return d;
+ }
+ if (la < lb) return fixnum(-1);
+ if (la > lb) return fixnum(1);
+ return fixnum(0);
+}
+
+// strange comparisons are resolved arbitrarily but consistently.
+// ordering: number < builtin < cvalue < vector < symbol < cons
+static value_t bounded_compare(value_t a, value_t b, int bound)
+{+ value_t d;
+
+ compare_top:
+ if (a == b) return fixnum(0);
+ if (bound <= 0)
+ return NIL;
+ switch (tag(a)) {+ case TAG_NUM:
+ if (isfixnum(b)) {+ return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
+ }
+ if (iscvalue(b)) {+ return fixnum(compare_num_cvalue(a, b));
+ }
+ return fixnum(-1);
+ case TAG_SYM:
+ if (tag(b) < TAG_SYM) return fixnum(1);
+ if (tag(b) > TAG_SYM) return fixnum(-1);
+ return fixnum(strcmp(symbol_name(a), symbol_name(b)));
+ case TAG_BUILTIN:
+ if (tag(b) > TAG_BUILTIN) return fixnum(-1);
+ if (tag(b) == TAG_BUILTIN) {+ if (uintval(a) < N_BUILTINS || uintval(b) < N_BUILTINS) {+ return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
+ }
+ if (discriminateAsVector(a)) {+ if (discriminateAsVector(b))
+ return bounded_vector_compare(a, b, bound);
+ return fixnum(1);
+ }
+ if (discriminateAsVector(b))
+ return fixnum(-1);
+ assert(iscvalue(a));
+ assert(iscvalue(b));
+ cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
+ numerictype_t at, bt;
+ if (valid_numtype(at=cv_numtype(acv)) &&
+ valid_numtype(bt=cv_numtype(bcv))) {+ void *aptr = cv_data(acv);
+ void *bptr = cv_data(bcv);
+ if (cmp_eq(aptr, at, bptr, bt))
+ return fixnum(0);
+ if (cmp_lt(aptr, at, bptr, bt))
+ return fixnum(-1);
+ return fixnum(1);
+ }
+ return cvalue_compare(a, b);
+ }
+ assert(isfixnum(b));
+ return fixnum(-compare_num_cvalue(b, a));
+ case TAG_CONS:
+ if (tag(b) < TAG_CONS) return fixnum(1);
+ d = bounded_compare(car_(a), car_(b), bound-1);
+ if (numval(d) != 0) return d;
+ a = cdr_(a); b = cdr_(b);
+ bound--;
+ goto compare_top;
+ }
+ return NIL;
+}
+
+static value_t cyc_vector_compare(value_t a, value_t b, ptrhash_t *table)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ value_t d, xa, xb, ca, cb;
+
+ // first try to prove them different with no recursion
+ m = la < lb ? la : lb;
+ for (i = 0; i < m; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (leafp(xa) || leafp(xb)) {+ d = bounded_compare(xa, xb, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (tag(xa) < tag(xb)) {+ return fixnum(-1);
+ }
+ else if (tag(xa) > tag(xb)) {+ return fixnum(1);
+ }
+ }
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+
+ for (i = 0; i < m; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (!leafp(xa) && !leafp(xb)) {+ d = cyc_compare(xa, xb, table);
+ if (numval(d)!=0)
+ return d;
+ }
+ }
+
+ if (la < lb) return fixnum(-1);
+ if (la > lb) return fixnum(1);
+ return fixnum(0);
+}
+
+static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table)
+{+ if (a==b)
+ return fixnum(0);
+ if (iscons(a)) {+ if (iscons(b)) {+ value_t aa = car_(a); value_t da = cdr_(a);
+ value_t ab = car_(b); value_t db = cdr_(b);
+ value_t d, ca, cb;
+ if (leafp(aa) || leafp(ab)) {+ d = bounded_compare(aa, ab, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (tag(aa) < tag(ab))
+ return fixnum(-1);
+ else if (tag(aa) > tag(ab))
+ return fixnum(1);
+ if (leafp(da) || leafp(db)) {+ d = bounded_compare(da, db, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (tag(da) < tag(db))
+ return fixnum(-1);
+ else if (tag(da) > tag(db))
+ return fixnum(1);
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_compare(aa, ab, table);
+ if (numval(d)!=0) return d;
+ return cyc_compare(da, db, table);
+ }
+ else {+ return fixnum(1);
+ }
+ }
+ else if (isvector(a) && isvector(b)) {+ return cyc_vector_compare(a, b, table);
+ }
+ return bounded_compare(a, b, 1);
+}
+
+value_t compare(value_t a, value_t b)
+{+ ptrhash_t h;
+ value_t guess = bounded_compare(a, b, 2048);
+ if (guess != NIL)
+ return guess;
+
+ ptrhash_new(&h, 512);
+ guess = cyc_compare(a, b, &h);
+ ptrhash_free(&h);
+ return guess;
+}
+
+/*
+ optimizations:
+ - use hash updates instead of calling lookup then insert. i.e. get the
+ bp once and use it twice.
+ - preallocate hash table and call reset() instead of new/free
+ - specialized version for equal (unordered comparison)
+ - less redundant tag checking, 3-bit tags
+*/
--- /dev/null
+++ b/femtolisp/equal.scm
@@ -1,0 +1,68 @@
+; Terminating equal predicate
+; by Jeff Bezanson
+;
+; This version only considers pairs and simple atoms.
+
+; equal?, with bounded recursion. returns 0 if we suspect
+; nontermination, otherwise #t or #f for the correct answer.
+(define (bounded-equal a b N)
+ (cond ((<= N 0) 0)
+ ((and (pair? a) (pair? b))
+ (let ((as
+ (bounded-equal (car a) (car b) (- N 1))))
+ (if (number? as)
+ 0
+ (and as
+ (bounded-equal (cdr a) (cdr b) (- N 1))))))
+ (else (eq? a b))))
+
+; union-find algorithm
+
+; find equivalence class of a cons cell, or #f if not yet known
+; the root of a class is a cons that is its own class
+(define (class table key)
+ (let ((c (hashtable-ref table key #f)))
+ (if (or (not c) (eq? c key))
+ c
+ (class table c))))
+
+; move a and b to the same equivalence class, given c and cb
+; as the current values of (class table a) and (class table b)
+; Note: this is not quite optimal. We blindly pick 'a' as the
+; root of the new class, but we should pick whichever class is
+; larger.
+(define (union! table a b c cb)
+ (let ((ca (if c c a)))
+ (if cb
+ (hashtable-set! table cb ca))
+ (hashtable-set! table a ca)
+ (hashtable-set! table b ca)))
+
+; cyclic equal. first, attempt to compare a and b as best
+; we can without recurring. if we can't prove them different,
+; set them equal and move on.
+(define (cyc-equal a b table)
+ (cond ((eq? a b) #t)
+ ((not (and (pair? a) (pair? b))) (eq? a b))
+ (else
+ (let ((aa (car a)) (da (cdr a))
+ (ab (car b)) (db (cdr b)))
+ (cond ((or (not (eq? (atom? aa) (atom? ab)))
+ (not (eq? (atom? da) (atom? db)))) #f)
+ ((and (atom? aa)
+ (not (eq? aa ab))) #f)
+ ((and (atom? da)
+ (not (eq? da db))) #f)
+ (else
+ (let ((ca (class table a))
+ (cb (class table b)))
+ (if (and ca cb (eq? ca cb))
+ #t
+ (begin (union! table a b ca cb)
+ (and (cyc-equal aa ab table)
+ (cyc-equal da db table)))))))))))
+
+(define (equal a b)
+ (let ((guess (bounded-equal a b 2048)))
+ (if (boolean? guess) guess
+ (cyc-equal a b (make-eq-hashtable)))))
--- /dev/null
+++ b/femtolisp/flisp.c
@@ -1,0 +1,1471 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ This is a fork of femtoLisp with advanced reading and printing facilities:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and correctly printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+ The value of this extra complexity, and what makes this fork worthy of
+ the femtoLisp brand, is that the interpreter is fully "closed" in the
+ sense that all representable values can be read and printed.
+
+ This is a fully fleshed-out lisp built up from femtoLisp. It has all the
+ remaining features needed to be taken seriously:
+ * vectors
+ * exceptions
+ * gensyms (can be usefully read back in, too)
+ * #| multiline comments |#
+ * generic compare function
+ * cvalues system providing C data types and a C FFI
+ * constructor notation for nicely printing arbitrary values
+ * cyclic equal
+ * strings
+ - hash tables
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <wctype.h>
+#include <sys/types.h>
+#include <locale.h>
+#include <limits.h>
+#include <errno.h>
+#include "llt.h"
+#include "flisp.h"
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "label",+ "trycatch", "progn",
+
+ "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
+ "builtinp", "vectorp", "fixnump", "equal",
+ "cons", "car", "cdr", "rplaca", "rplacd",
+ "eval", "apply", "set", "prog1", "raise",
+ "+", "-", "*", "/", "<", "~", "&", "!", "$",
+ "vector", "aref", "aset", "length", "assoc", "compare" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 98304
+value_t Stack[N_STACK];
+u_int32_t SP = 0;
+
+value_t NIL, T, LAMBDA, LABEL, QUOTE, VECTOR, IF, TRYCATCH;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
+value_t DivideError, BoundsError, Error;
+value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
+
+static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+static value_t *alloc_words(int n);
+static value_t relocate(value_t v);
+static void do_print(FILE *f, value_t v, int princ);
+
+typedef struct _readstate_t {+ ptrhash_t backrefs;
+ ptrhash_t gensyms;
+ struct _readstate_t *prev;
+} readstate_t;
+static readstate_t *readstate = NULL;
+
+static void free_readstate(readstate_t *rs)
+{+ ptrhash_free(&rs->backrefs);
+ ptrhash_free(&rs->gensyms);
+}
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 256*1024;//bytes
+static u_int32_t *consflags;
+static u_int32_t printlabel;
+
+// error utilities ------------------------------------------------------------
+
+// saved execution state for an unwind target
+typedef struct _ectx_t {+ jmp_buf buf;
+ u_int32_t sp;
+ readstate_t *rdst;
+ struct _ectx_t *prev;
+} exception_context_t;
+
+static exception_context_t *ctx = NULL;
+static value_t lasterror;
+static char lerrorbuf[512];
+
+#define FL_TRY \
+ exception_context_t _ctx; int l__tr, l__ca; \
+ _ctx.sp=SP; _ctx.rdst=readstate; _ctx.prev=ctx; \
+ ctx = &_ctx; \
+ if (!setjmp(_ctx.buf)) \
+ for (l__tr=1; l__tr; l__tr=0, (void)(ctx->prev && (ctx=ctx->prev)))
+
+#define FL_CATCH \
+ else \
+ for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL)
+
+void raise(value_t e)
+{+ if (e != lasterror) {+ lasterror = e;
+ lerrorbuf[0] = '\0'; // overwriting exception; clear error buf
+ }
+ // unwind read state
+ while (readstate != ctx->rdst) {+ free_readstate(readstate);
+ readstate = readstate->prev;
+ }
+ SP = ctx->sp;
+ exception_context_t *thisctx = ctx;
+ if (ctx->prev) // don't throw past toplevel
+ ctx = ctx->prev;
+ longjmp(thisctx->buf, 1);
+}
+
+void lerror(value_t e, char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args);
+ va_end(args);
+
+ lasterror = e;
+ raise(e);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ raise(listn(4, TypeError, symbol(fname), symbol(expected), got));
+}
+
+void bounds_error(char *fname, value_t arr, value_t ind)
+{+ lerror(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(fixnum,fixnum_t, numval)
+SAFECAST_OP(cvalue,cvalue_t*,ptr)
+SAFECAST_OP(string,char*, cvalue_data)
+
+// symbol table ---------------------------------------------------------------
+
+symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) - sizeof(void*) + strlen(str)+1);
+ sym->left = sym->right = NULL;
+ sym->binding = UNBOUND;
+ sym->syntax = 0;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+typedef struct {+ value_t binding; // global value binding
+ value_t syntax; // syntax environment entry
+ void *dlcache; // dlsym address
+ u_int32_t id;
+} gensym_t;
+
+static u_int32_t _gensym_ctr=0;
+// two static buffers for gensym printing so there can be two
+// gensym names available at a time, mostly for compare()
+static char gsname[2][16];
+static int gsnameno=0;
+value_t gensym(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ (void)nargs;
+ gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
+ gs->id = _gensym_ctr++;
+ gs->binding = UNBOUND;
+ gs->syntax = 0;
+ return tagptr(gs, TAG_SYM);
+}
+
+value_t fl_gensym()
+{+ return gensym(NULL, 0);
+}
+
+static char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
+{+ size_t i=n-1;
+
+ nbuf[i--] = '\0';
+ do {+ nbuf[i--] = '0' + g%10;
+ g/=10;
+ } while (g && i);
+ nbuf[i] = 'g';
+ return &nbuf[i];
+}
+
+char *symbol_name(value_t v)
+{+ if (ismanaged(v)) {+ gensym_t *gs = (gensym_t*)ptr(v);
+ gsnameno = 1-gsnameno;
+ return snprintf_gensym_id(gsname[gsnameno], sizeof(gsname[0]), gs->id);
+ }
+ return ((symbol_t*)ptr(v))->name;
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t *alloc_words(int n)
+{+ value_t *first;
+
+ // the minimum allocation is a 2-word block
+ if (n < 2) n = 2;
+ if ((value_t*)curheap > ((value_t*)lim)+2-n) {+ gc(0);
+ while ((value_t*)curheap > ((value_t*)lim)+2-n) {+ gc(1);
+ }
+ }
+ first = (value_t*)curheap;
+ curheap += (n*sizeof(value_t));
+ return first;
+}
+
+// allocate n consecutive conses
+#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+value_t alloc_vector(size_t n, int init)
+{+ value_t *c = alloc_words(n+1);
+ value_t v = tagptr(c, TAG_BUILTIN);
+ vector_setsize(v, n);
+ if (init) {+ unsigned int i;
+ for(i=0; i < n; i++)
+ vector_elt(v, i) = NIL;
+ }
+ return v;
+}
+
+// print ----------------------------------------------------------------------
+
+static int isnumtok(char *tok, value_t *pval);
+static int symchar(char c);
+
+#include "print.c"
+
+// cvalues --------------------------------------------------------------------
+
+#include "cvalues.c"
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if (isfixnum(v))
+ return(v);
+ else if (iscons(v)) {+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == UNBOUND) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = (d==NIL) ? NIL : relocate(d);
+
+ return first;
+ }
+ else if (isvectorish(v)) {+ if (discriminateAsVector(v)) {+ // 0-length vectors secretly have space for a first element
+ if (vector_elt(v,0) == UNBOUND)
+ return vector_elt(v,-1);
+ size_t i, newsz, sz = vector_size(v);
+ newsz = sz;
+ if (vector_elt(v,-1) & 0x1)
+ newsz += vector_grow_amt(sz);
+ nc = alloc_vector(newsz, 0);
+ a = vector_elt(v,0);
+ vector_elt(v,0) = UNBOUND;
+ vector_elt(v,-1) = nc;
+ i = 0;
+ if (sz > 0) {+ vector_elt(nc,0) = relocate(a); i++;
+ for(; i < sz; i++)
+ vector_elt(nc,i) = relocate(vector_elt(v,i));
+ }
+ for(; i < newsz; i++)
+ vector_elt(nc,i) = NIL;
+ return nc;
+ }
+ else {+ return cvalue_relocate(v);
+ }
+ }
+ else if (ismanaged(v)) {+ assert(issymbol(v));
+ gensym_t *gs = (gensym_t*)ptr(v);
+ if (gs->id == 0xffffffff)
+ return gs->binding;
+ gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
+ *ng = *gs;
+ gs->id = 0xffffffff;
+ nc = tagptr(ng, TAG_SYM);
+ gs->binding = nc;
+ if (ng->binding != UNBOUND)
+ ng->binding = relocate(ng->binding);
+ return nc;
+ }
+ return v;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ if (iscons(root->syntax))
+ root->syntax = relocate(root->syntax);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ void *temp;
+ u_int32_t i;
+ readstate_t *rs;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+ rs = readstate;
+ while (rs) {+ for(i=0; i < rs->backrefs.size; i++)
+ rs->backrefs.table[i] = (void*)relocate((value_t)rs->backrefs.table[i]);
+ for(i=0; i < rs->gensyms.size; i++)
+ rs->gensyms.table[i] = (void*)relocate((value_t)rs->gensyms.table[i]);
+ rs = rs->prev;
+ }
+ lasterror = relocate(lasterror);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror(MemoryError, "out of memory");
+ tospace = temp;
+ if (!grew) {+ heapsize*=2;
+ }
+ else {+ temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1);
+ if (temp == NULL)
+ lerror(MemoryError, "out of memory");
+ consflags = (u_int32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+// utils ----------------------------------------------------------------------
+
+value_t apply(value_t f, value_t l)
+{+ PUSH(f);
+ PUSH(l);
+ value_t e = cons_reserve(5);
+ value_t x = e;
+ car_(e) = builtin(F_APPLY);
+ cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
+ // TODO: consider quoting this if it's a lambda expression
+ car_(e) = Stack[SP-2];
+ cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
+ car_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS);
+ cdr_(e) = NIL;
+ e = car_(e);
+ car_(e) = QUOTE;
+ cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e);
+ car_(e) = Stack[SP-1];
+ cdr_(e) = NIL;
+ POPN(2);
+ return toplevel_eval(x);
+}
+
+value_t listn(size_t n, ...)
+{+ va_list ap;
+ va_start(ap, n);
+ u_int32_t si = SP;
+ size_t i;
+
+ for(i=0; i < n; i++) {+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ cons_t *c = (cons_t*)alloc_words(n*2);
+ cons_t *l = c;
+ for(i=0; i < n; i++) {+ c->car = Stack[si++];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ (c-1)->cdr = NIL;
+
+ POPN(n);
+ va_end(ap);
+ return tagptr(l, TAG_CONS);
+}
+
+value_t list2(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ cons_t *c = (cons_t*)alloc_words(4);
+ b = POP();
+ a = POP();
+ c[0].car = a;
+ c[0].cdr = tagptr(c+1, TAG_CONS);
+ c[1].car = b;
+ c[1].cdr = NIL;
+ return tagptr(c, TAG_CONS);
+}
+
+value_t fl_cons(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ value_t c = mk_cons();
+ cdr_(c) = POP();
+ car_(c) = POP();
+ return c;
+}
+
+// NOTE: this is NOT an efficient operation. it is only used by the
+// reader; vectors should not generally be resized.
+// vector_grow requires at least 1 and up to 3 garbage collections!
+static value_t vector_grow(value_t v)
+{+ size_t s = vector_size(v);
+ size_t d = vector_grow_amt(s);
+ PUSH(v);
+ // first allocate enough space to guarantee the heap will be big enough
+ // for the new vector
+ alloc_words(d);
+ // setting low bit of vector's size acts as a flag to the collector
+ // to grow this vector as it is relocated
+ ((size_t*)ptr(Stack[SP-1]))[0] |= 0x1;
+ gc(0);
+ return POP();
+}
+
+extern value_t compare(value_t a, value_t b);
+
+int isnumber(value_t v)
+{+ return (isfixnum(v) ||
+ (iscvalue(v) &&
+ valid_numtype(cv_numtype((cvalue_t*)ptr(v)))));
+}
+
+// read -----------------------------------------------------------------------
+
+#include "read.c"
+
+// eval -----------------------------------------------------------------------
+
+// return a cons element of v whose car is item
+static value_t assoc(value_t item, value_t v)
+{+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return NIL;
+}
+
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define tail_eval(xpr) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); goto eval_top; } } while (0)+
+static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend)
+{+ value_t v;
+
+ FL_TRY {+ v = eval(expr);
+ }
+ FL_CATCH {+ v = cdr_(Stack[SP-1]);
+ if (!iscons(v)) {+ v = NIL; // 1-argument form
+ }
+ else {+ Stack[SP-1] = car_(v);
+ value_t quoted = list2(QUOTE, lasterror);
+ expr = list2(Stack[SP-1], quoted);
+ v = eval(expr);
+ }
+ }
+ return v;
+}
+
+/* stack setup on entry:
+ n n+1 ...
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ | SYM | VAL | SYM | VAL | CLO | | | |
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ ^ ^ ^
+ | | |
+ penv envend SP (who knows where)
+
+ sym is an argument name and val is its binding. CLO is a closed-up
+ environment vector (which can be empty, i.e. NIL).
+ CLO is always there, but there might be zero SYM/VAL pairs.
+
+ if tail==1, you are allowed (indeed encouraged) to overwrite this
+ environment, otherwise you have to put any new environment on the top
+ of the stack.
+*/
+static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+{+ value_t f, v, asym, *pv, *argsyms, *body, *lenv, *argenv;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ fixnum_t s;
+ cvalue_t *cv;
+ int64_t accum;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->syntax == TAG_CONST) return sym->binding;
+ while (1) {+ if (tag(*penv) == TAG_BUILTIN)
+ penv = &vector_elt(*penv, 0);
+ if (*penv == e)
+ return penv[1];
+ else if (*penv == NIL)
+ break;
+ penv+=2;
+ }
+ if ((v = sym->binding) == UNBOUND) // 3. global env
+ raise(list2(UnboundError, e));
+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror(MemoryError, "eval: stack overflow");
+ saveSP = SP;
+ v = car_(e);
+ PUSH(cdr_(e));
+ if (tag(v)<0x2) f=v;
+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) {+ // handle special syntax forms
+ if (isspecial(f))
+ goto apply_special;
+ else if (f == TAG_CONST)
+ f = ((symbol_t*)ptr(v))->binding;
+ else
+ noeval = 2;
+ }
+ else f = eval_sexpr(v, penv, 0, envend);
+ v = Stack[saveSP];
+ if (tag(f) == TAG_BUILTIN) {+ // handle builtin function
+ // evaluate argument list, placing arguments on stack
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ apply_special:
+ switch (uintval(f)) {+ // special forms
+ case F_QUOTE:
+ if (!iscons(Stack[saveSP]))
+ lerror(ArgError, "quote: expected argument");
+ v = car_(Stack[saveSP]);
+ break;
+ case F_LAMBDA:
+ // build a closure (lambda args body . env)
+ if (issymbol(*penv) && *penv != NIL) {+ // save temporary environment to the heap
+ // find out how much space we need
+ nargs = ((int)(&Stack[envend] - penv - 1));
+ lenv = penv;
+ pv = alloc_words(nargs + 2);
+ PUSH(tagptr(pv, TAG_BUILTIN));
+ pv[0] = (nargs+1)<<2;
+ pv++;
+ while (nargs--)
+ *pv++ = *penv++;
+ // final element points to existing cloenv
+ *pv = Stack[envend-1];
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ *lenv = Stack[SP-1];
+ }
+ else {+ PUSH(*penv); // env has already been captured; share
+ }
+ c = (cons_t*)ptr(v=cons_reserve(3));
+ c->car = LAMBDA;
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = car(Stack[saveSP]); //argsyms
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = car(cdr_(Stack[saveSP])); //body
+ c->cdr = Stack[SP-1]; //env
+ break;
+ case F_LABEL:
+ // the syntax of label is (label name (lambda args body))
+ // nothing else is guaranteed to work
+ PUSH(car(Stack[saveSP]));
+ PUSH(car(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ *body = eval(*body); // evaluate lambda
+ pv = alloc_words(4);
+ pv[0] = 3<<2; // vector size 3
+ // add [name fn] to front of function's environment
+ pv[1] = Stack[SP-2]; // name
+ pv[2] = v = *body; // lambda
+ f = cdr(cdr(v));
+ pv[3] = cdr(f);
+ cdr_(f) = tagptr(pv, TAG_BUILTIN);
+ break;
+ case F_IF:
+ v = car(Stack[saveSP]);
+ if (eval(v) != NIL)
+ v = car(cdr_(Stack[saveSP]));
+ else
+ v = car(cdr(cdr_(Stack[saveSP])));
+ tail_eval(v);
+ break;
+ case F_COND:
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car);
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_OR:
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) != NIL) {+ SP = saveSP; return v;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(Stack[saveSP]));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(Stack[saveSP]);
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond) != NIL) {+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body));
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_TRYCATCH:
+ v = do_trycatch(car(Stack[saveSP]), penv, envend);
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ while (1) {+ if (tag(*penv) == TAG_BUILTIN)
+ penv = &vector_elt(*penv, 0);
+ if (*penv == e) {+ penv[1] = Stack[SP-1];
+ SP=saveSP; return penv[1];
+ }
+ else if (*penv == NIL)
+ break;
+ penv+=2;
+ }
+ sym = tosymbol(e, "set");
+ v = Stack[SP-1];
+ if (sym->syntax != TAG_CONST)
+ sym->binding = v;
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ v = (sym->binding == UNBOUND) ? NIL : T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ c->car = Stack[SP-2];
+ c->cdr = Stack[SP-1];
+ v = tagptr(c, TAG_CONS);
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_VECTOR:
+ v = alloc_vector(nargs, 0);
+ memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t));
+ break;
+ case F_LENGTH:
+ argcount("length", nargs, 1);+ if (isvectorish(Stack[SP-1])) {+ if (discriminateAsVector(Stack[SP-1])) {+ v = fixnum(vector_size(Stack[SP-1]));
+ break;
+ }
+ else {+ cv = (cvalue_t*)ptr(Stack[SP-1]);
+ v = cv_type(cv);
+ if (iscons(v) && car_(v) == arraysym) {+ v = size_wrap(cvalue_arraylen(Stack[SP-1]));
+ break;
+ }
+ else if (v == charsym) {+ v = fixnum(1);
+ break;
+ }
+ else if (v == wcharsym) {+ v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv)));
+ break;
+ }
+ }
+ }
+ else if (Stack[SP-1] == NIL) {+ v = fixnum(0); break;
+ }
+ else if (iscons(Stack[SP-1])) {+ v = fixnum(llength(Stack[SP-1])); break;
+ }
+ type_error("length", "sequence", Stack[SP-1]);+ break;
+ case F_AREF:
+ argcount("aref", nargs, 2);+ v = Stack[SP-2];
+ i = tofixnum(Stack[SP-1], "aref");
+ if (isvector(v)) {+ if ((unsigned)i >= vector_size(v))
+ bounds_error("aref", v, Stack[SP-1]);+ v = vector_elt(v, i);
+ }
+ else {+ // TODO other sequence types?
+ type_error("aref", "sequence", v);+ }
+ break;
+ case F_ASET:
+ argcount("aset", nargs, 3);+ e = Stack[SP-3];
+ i = tofixnum(Stack[SP-2], "aset");
+ if (isvector(e)) {+ if ((unsigned)i >= vector_size(e))
+ bounds_error("aref", v, Stack[SP-1]);+ vector_elt(e, i) = (v=Stack[SP-1]);
+ }
+ else {+ type_error("aset", "sequence", e);+ }
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isfixnum(Stack[SP-1]) ||
+ (iscvalue(Stack[SP-1]) &&
+ valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) ))
+ ? T : NIL);
+ break;
+ case F_FIXNUMP:
+ argcount("fixnump", nargs, 1);+ v = ((isfixnum(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_BUILTINP:
+ argcount("builtinp", nargs, 1);+ v = (isbuiltin(Stack[SP-1]) ||
+ (iscvalue(Stack[SP-1]) &&
+ ((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL;
+ break;
+ case F_VECTORP:
+ argcount("vectorp", nargs, 1);+ v = ((isvector(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ if (isfixnum(Stack[i])) {+ s += numval(Stack[i]);
+ if (!fits_fixnum(s)) {+ i++;
+ goto add_ovf;
+ }
+ }
+ else {+ add_ovf:
+ v = fl_add_any(&Stack[i], SP-i, s);
+ SP = saveSP;
+ return v;
+ }
+ }
+ v = fixnum(s);
+ break;
+ case F_SUB:
+ if (nargs < 1) lerror(ArgError, "-: too few arguments");
+ i = saveSP+1;
+ if (nargs == 1) {+ if (isfixnum(Stack[i]))
+ v = fixnum(-numval(Stack[i]));
+ else
+ v = fl_neg(Stack[i]);
+ break;
+ }
+ if (nargs == 2) {+ if (bothfixnums(Stack[i], Stack[i+1])) {+ s = numval(Stack[i]) - numval(Stack[i+1]);
+ if (fits_fixnum(s)) {+ v = fixnum(s);
+ break;
+ }
+ Stack[i+1] = fixnum(-numval(Stack[i+1]));
+ }
+ else {+ Stack[i+1] = fl_neg(Stack[i+1]);
+ }
+ }
+ else {+ Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0));
+ }
+ v = fl_add_any(&Stack[i], 2, 0);
+ break;
+ case F_MUL:
+ accum = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ if (isfixnum(Stack[i])) {+ accum *= numval(Stack[i]);
+ }
+ else {+ v = fl_mul_any(&Stack[i], SP-i, accum);
+ SP = saveSP;
+ return v;
+ }
+ }
+ if (fits_fixnum(accum))
+ v = fixnum(accum);
+ else
+ v = return_from_int64(accum);
+ break;
+ case F_DIV:
+ if (nargs < 1) lerror(ArgError, "/: too few arguments");
+ i = saveSP+1;
+ if (nargs == 1) {+ v = fl_div2(fixnum(1), Stack[i]);
+ }
+ else {+ if (nargs > 2)
+ Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1);
+ v = fl_div2(Stack[i], Stack[i+1]);
+ }
+ break;
+ case F_BNOT:
+ argcount("~", nargs, 1);+ if (isfixnum(Stack[SP-1]))
+ v = fixnum(~numval(Stack[SP-1]));
+ else
+ v = fl_bitwise_not(Stack[SP-1]);
+ break;
+ case F_BAND:
+ argcount("&", nargs, 2);+ if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+ v = Stack[SP-1] & Stack[SP-2];
+ else
+ v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");
+ break;
+ case F_BOR:
+ argcount("!", nargs, 2);+ if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+ v = Stack[SP-1] | Stack[SP-2];
+ else
+ v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");
+ break;
+ case F_BXOR:
+ argcount("$", nargs, 2);+ if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+ v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));
+ else
+ v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
+ break;
+ case F_COMPARE:
+ argcount("compare", nargs, 2);+ v = compare(Stack[SP-2], Stack[SP-1]);
+ break;
+ 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;
+ }
+ else {+ v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL;
+ }
+ break;
+ case F_EQUAL:
+ argcount("equal", nargs, 2);+ if (!((Stack[SP-2] | Stack[SP-1])&0x1)) {+ v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
+ }
+ else {+ v = (compare(Stack[SP-2], Stack[SP-1])==0) ? T : NIL;
+ }
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ if (tag(v)<0x2) { SP=saveSP; return v; }+ if (tail) {+ *penv = NIL;
+ envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
+ e=v; goto eval_top;
+ }
+ else {+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ }
+ break;
+ case F_RAISE:
+ argcount("raise", nargs, 1);+ raise(Stack[SP-1]);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1) 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]);
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (tag(f) == TAG_BUILTIN) {+ assert(!isspecial(f));
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ default:
+ cv = (cvalue_t*)ptr(f);
+ if (!discriminateAsVector(f) && cv->flags.islispfunction) {+ v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs);
+ }
+ else {+ goto apply_lambda; // trigger type error
+ }
+ }
+ SP = saveSP;
+ return v;
+ }
+ apply_lambda:
+ if (iscons(f)) {+ // apply lambda or macro expression
+ PUSH(cdr(cdr_(f)));
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ argenv = &Stack[SP]; // argument environment starts now
+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror(ArgError, "apply: too many arguments");
+ break;
+ }
+ asym = car_(*argsyms);
+ if (asym==NIL || !issymbol(asym))
+ lerror(ArgError, "apply: invalid formal argument");
+ v = car_(v);
+ if (!noeval) {+ v = eval(v);
+ }
+ PUSH(asym);
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ PUSH(*argsyms);
+ PUSH(Stack[saveSP]);
+ if (!noeval) {+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ PUSH(eval(car_(Stack[saveSP])));
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = cons_reserve(nargs);
+ c = (cons_t*)ptr(Stack[i-1]);
+ for(; i < (int)SP; i++) {+ c->car = Stack[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ (c-1)->cdr = Stack[saveSP];
+ POPN(nargs);
+ }
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror(ArgError, "apply: too few arguments");
+ }
+ }
+ PUSH(cdr(Stack[saveSP+1])); // add cloenv to new environment
+ e = car_(Stack[saveSP+1]);
+ // macro: evaluate expansion in the calling environment
+ if (noeval == 2) {+ if (tag(e)<0x2) ;
+ else e = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ if (tag(e)<0x2) return(e);
+ noeval = 0;
+ goto eval_top;
+ }
+ else {+ if (tag(e)<0x2) { SP=saveSP; return(e); }+ if (tail) {+ noeval = 0;
+ // ok to overwrite environment
+ nargs = (int)(&Stack[SP] - argenv);
+ for(i=0; i < nargs; i++)
+ penv[i] = argenv[i];
+ envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ goto eval_top;
+ }
+ else {+ v = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ return v;
+ }
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// initialization -------------------------------------------------------------
+
+extern void builtins_init();
+
+void lisp_init(void)
+{+ int i;
+
+ llt_init();
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
+ ptrhash_new(&printconses, 32);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("T"); setc(T, T);+ LAMBDA = symbol("lambda");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ VECTOR = symbol("vector");+ TRYCATCH = symbol("trycatch");+ BACKQUOTE = symbol("backquote");+ COMMA = symbol("*comma*");+ COMMAAT = symbol("*comma-at*");+ COMMADOT = symbol("*comma-dot*");+ IOError = symbol("io-error");+ ParseError = symbol("parse-error");+ TypeError = symbol("type-error");+ ArgError = symbol("arg-error");+ UnboundError = symbol("unbound-error");+ MemoryError = symbol("memory-error");+ BoundsError = symbol("bounds-error");+ DivideError = symbol("divide-error");+ Error = symbol("error");+ conssym = symbol("cons");+ symbolsym = symbol("symbol");+ fixnumsym = symbol("fixnum");+ vectorsym = symbol("vector");+ builtinsym = symbol("builtin");+ lasterror = NIL;
+ lerrorbuf[0] = '\0';
+ i = 0;
+ while (isspecial(builtin(i))) {+ ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
+ i++;
+ }
+ for (; i < N_BUILTINS; i++) {+ setc(symbol(builtin_names[i]), builtin(i));
+ }
+
+#ifdef LINUX
+ set(symbol("os.name"), symbol("linux"));+#elif defined(WIN32) || defined(WIN64)
+ set(symbol("os.name"), symbol("win32"));+#elif defined(MACOSX)
+ set(symbol("os.name"), symbol("macos"));+#else
+ set(symbol("os.name"), symbol("unknown"));+#endif
+
+ cvalues_init();
+ set(symbol("gensym"), guestfunc(gensym));+ builtins_init();
+}
+
+// repl -----------------------------------------------------------------------
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ u_int32_t saveSP = SP;
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-1]);
+ SP = saveSP;
+ return v;
+}
+
+static void print_toplevel_exception()
+{+ if (iscons(lasterror) && car_(lasterror) == TypeError &&
+ llength(lasterror) == 4) {+ fprintf(stderr, "type-error: ");
+ print(stderr, car_(cdr_(lasterror)), 1);
+ fprintf(stderr, ": expected ");
+ print(stderr, car_(cdr_(cdr_(lasterror))), 1);
+ fprintf(stderr, ", got ");
+ print(stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0);
+ }
+ else if (iscons(lasterror) && car_(lasterror) == UnboundError &&
+ iscons(cdr_(lasterror))) {+ fprintf(stderr, "unbound-error: eval: variable %s has no value",
+ (symbol_name(car_(cdr_(lasterror)))));
+ }
+ else if (iscons(lasterror) && car_(lasterror) == Error) {+ value_t v = cdr_(lasterror);
+ fprintf(stderr, "error: ");
+ while (iscons(v)) {+ print(stderr, car_(v), 1);
+ v = cdr_(v);
+ }
+ }
+ else {+ if (lasterror != NIL) {+ if (!lerrorbuf[0])
+ fprintf(stderr, "*** Unhandled exception: ");
+ print(stderr, lasterror, 0);
+ if (lerrorbuf[0])
+ fprintf(stderr, ": ");
+ }
+ }
+
+ if (lerrorbuf[0])
+ fprintf(stderr, "%s", lerrorbuf);
+}
+
+value_t load_file(char *fname)
+{+ value_t volatile e, v=NIL;
+ FILE * volatile f = fopen(fname, "r");
+ if (f == NULL) lerror(IOError, "file \"%s\" not found", fname);
+ FL_TRY {+ while (1) {+ e = read_sexpr(f);
+ //print(stdout,e,0); printf("\n");+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ }
+ FL_CATCH {+ fclose(f);
+ size_t msglen = strlen(lerrorbuf);
+ snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen,
+ "\nin file \"%s\"", fname);
+ lerrorbuf[sizeof(lerrorbuf)-1] = '\0';
+ raise(lasterror);
+ }
+ fclose(f);
+ return v;
+}
+
+static value_t argv_list(int argc, char *argv[])
+{+ int i;
+ PUSH(NIL);
+ if (argc > 1) { argc--; argv++; }+ for(i=argc-1; i >= 0; i--)
+ Stack[SP-1] = fl_cons(cvalue_pinned_cstring(argv[i]), Stack[SP-1]);
+ return POP();
+}
+
+int locale_is_utf8;
+
+int main(int argc, char *argv[])
+{+ value_t v;
+
+ locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ set(symbol("argv"), argv_list(argc, argv));+ FL_TRY {+ // install toplevel exception handler
+ }
+ FL_CATCH {+ print_toplevel_exception();
+
+ lerrorbuf[0] = '\0';
+ lasterror = NIL;
+ fprintf(stderr, "\n\n");
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("; _ \n");+ printf("; |_ _ _ |_ _ | . _ _\n");+ printf("; | (-||||_(_)|__|_)|_)\n");+ printf(";-------------------|----------------------------------------------------------\n\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v), 0);
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ printf("\n");+ return 0;
+}
--- /dev/null
+++ b/femtolisp/flisp.h
@@ -1,0 +1,235 @@
+#ifndef _FLISP_H_
+#define _FLISP_H_
+
+typedef uptrint_t value_t;
+typedef int_t fixnum_t;
+#ifdef BITS64
+#define T_FIXNUM T_INT64
+#else
+#define T_FIXNUM T_INT32
+#endif
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t syntax; // syntax environment entry
+ void *dlcache; // dlsym address
+ // below fields are private
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ union {+ char name[1];
+ void *_pad; // ensure field aligned to pointer size
+ };
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define TAG_CONST ((value_t)-2) // in sym->syntax for constants
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define fixnum(x) ((value_t)((x)<<2))
+#define numval(x) (((fixnum_t)(x))>>2)
+#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
+#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
+#define uintval(x) (((unsigned int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isfixnum(x) (tag(x) == TAG_NUM)
+#define bothfixnums(x,y) (tag((x)|(y)) == TAG_NUM)
+#define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS)
+#define isvectorish(x) ((tag(x) == TAG_BUILTIN) && uintval(x) > N_BUILTINS)
+#define isvector(x) (isvectorish(x) && !(((value_t*)ptr(x))[0] & 0x2))
+#define iscvalue(x) (isvectorish(x) && (((value_t*)ptr(x))[0] & 0x2))
+// distinguish a vector from a cvalue
+#define discriminateAsVector(x) (!(((value_t*)ptr(x))[0] & 0x2))
+#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
+#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
+#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)])
+#define vector_grow_amt(x) ((x)<8 ? 4 : 6*((x)>>3))
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) do { ((symbol_t*)ptr(s))->syntax = TAG_CONST; \+ ((symbol_t*)ptr(s))->binding = (v); } while (0)
+#define isconstant(s) (((symbol_t*)ptr(s))->syntax == TAG_CONST)
+#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
+#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
+ (((unsigned char*)ptr(v)) < fromspace+heapsize))
+
+extern value_t Stack[];
+extern u_int32_t SP;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_LABEL,
+ F_TRYCATCH, 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_CAR, F_CDR, F_RPLACA, F_RPLACD,
+ F_EVAL, F_APPLY, F_SET, 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,
+ N_BUILTINS
+};
+#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN)
+
+extern value_t NIL, T;
+
+/* read, eval, print main entry points */
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v, int princ);
+value_t toplevel_eval(value_t expr);
+value_t apply(value_t f, value_t l);
+value_t load_file(char *fname);
+
+/* object model manipulation */
+value_t fl_cons(value_t a, value_t b);
+value_t list2(value_t a, value_t b);
+value_t listn(size_t n, ...);
+value_t symbol(char *str);
+value_t fl_gensym();
+char *symbol_name(value_t v);
+value_t alloc_vector(size_t n, int init);
+size_t llength(value_t v);
+value_t list_nth(value_t l, size_t n);
+value_t compare(value_t a, value_t b);
+
+/* safe casts */
+cons_t *tocons(value_t v, char *fname);
+symbol_t *tosymbol(value_t v, char *fname);
+fixnum_t tofixnum(value_t v, char *fname);
+char *tostring(value_t v, char *fname);
+
+/* error handling */
+void lerror(value_t e, char *format, ...) __attribute__ ((__noreturn__));
+void raise(value_t e) __attribute__ ((__noreturn__));
+void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
+void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
+extern value_t ArgError, IOError;
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
+}
+
+/* c interface */
+#define INL_SIZE_NBITS 16
+typedef struct {+ unsigned two:2;
+ unsigned moved:1;
+ unsigned numtype:4;
+ unsigned inllen:INL_SIZE_NBITS;
+ unsigned cstring:1;
+ unsigned unused:4;
+ unsigned prim:1;
+ unsigned inlined:1;
+ unsigned islispfunction:1;
+ unsigned autorelease:1;
+#ifdef BITS64
+ unsigned pad:32;
+#endif
+} cvflags_t;
+
+// initial flags have two==0x2 (type tag) and numtype==0xf
+#ifdef BITFIELD_BIG_ENDIAN
+# ifdef BITS64
+# define INITIAL_FLAGS 0x9e00000000000000UL
+# else
+# define INITIAL_FLAGS 0x9e000000
+# endif
+#else
+# ifdef BITS64
+# define INITIAL_FLAGS 0x000000000000007aUL
+# else
+# define INITIAL_FLAGS 0x0000007a
+# endif
+#endif
+
+typedef struct {+ union {+ cvflags_t flags;
+ unsigned long flagbits;
+ };
+ value_t type;
+ value_t deps;
+ // fields below are absent in inline-allocated values
+ void *data;
+ size_t len; // length of *data in bytes
+ //cvtable_t *vtable;
+} cvalue_t;
+
+typedef struct {+ union {+ cvflags_t flags;
+ unsigned long flagbits;
+ };
+ value_t type;
+ void *data;
+} cprim_t;
+
+#define cv_len(c) ((c)->flags.inlined ? (c)->flags.inllen : (c)->len)
+#define cv_type(c) ((c)->type)
+#define cv_numtype(c) ((c)->flags.numtype)
+
+#define valid_numtype(v) ((v) < N_NUMTYPES)
+
+/* C type names corresponding to cvalues type names */
+typedef unsigned long ulong;
+typedef unsigned int uint;
+typedef unsigned char uchar;
+typedef char char_t;
+typedef long long_t;
+typedef unsigned long ulong_t;
+typedef double double_t;
+typedef float float_t;
+
+typedef value_t (*guestfunc_t)(value_t*, u_int32_t);
+
+extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
+extern value_t int64sym, uint64sym, shortsym, ushortsym;
+extern value_t intsym, uintsym, longsym, ulongsym, charsym, ucharsym, wcharsym;
+extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
+extern value_t stringtypesym, wcstringtypesym, emptystringsym;
+extern value_t unionsym, floatsym, doublesym, lispvaluesym;
+
+value_t cvalue(value_t type, size_t sz);
+size_t ctype_sizeof(value_t type, int *palign);
+void *cvalue_data(value_t v);
+void *cv_data(cvalue_t *cv);
+value_t cvalue_copy(value_t v);
+value_t cvalue_from_data(value_t type, void *data, size_t sz);
+value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent);
+value_t guestfunc(guestfunc_t f);
+size_t cvalue_arraylen(value_t v);
+value_t size_wrap(size_t sz);
+size_t toulong(value_t n, char *fname);
+value_t cvalue_string(size_t sz);
+value_t cvalue_pinned_cstring(char *str);
+int isstring(value_t v);
+int isnumber(value_t v);
+value_t cvalue_compare(value_t a, value_t b);
+
+value_t mk_double(double_t n);
+value_t mk_uint32(uint32_t n);
+value_t mk_uint64(uint64_t n);
+value_t return_from_uint64(uint64_t Uaccum);
+value_t return_from_int64(int64_t Saccum);
+
+#endif
--- /dev/null
+++ b/femtolisp/pisum.lsp
@@ -1,0 +1,8 @@
+(defun pisum ()
+ (dotimes (j 500)
+ ((label sumloop
+ (lambda (i sum)
+ (if (> i 10000)
+ sum
+ (sumloop (+ i 1) (+ sum (/ (* i i)))))))
+ 1.0 0.0)))
--- /dev/null
+++ b/femtolisp/print.c
@@ -1,0 +1,570 @@
+static ptrhash_t printconses;
+
+static int HPOS, VPOS;
+static void outc(char c, FILE *f)
+{+ fputc(c, f);
+ HPOS++;
+}
+static void outs(char *s, FILE *f)
+{+ fputs(s, f);
+ HPOS += u8_strwidth(s);
+}
+static void outindent(int n, FILE *f)
+{+ fputc('\n', f);+ VPOS++;
+ HPOS = n;
+ while (n >= 8) {+ fputc('\t', f);+ n -= 8;
+ }
+ while (n) {+ fputc(' ', f);+ n--;
+ }
+}
+
+static void print_traverse(value_t v)
+{+ value_t *bp;
+ while (iscons(v)) {+ if (ismarked(v)) {+ bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
+ if (*bp == (value_t)PH_NOTFOUND)
+ *bp = fixnum(printlabel++);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+ if (!ismanaged(v) || issymbol(v))
+ return;
+ if (isvectorish(v)) {+ if (ismarked(v)) {+ bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
+ if (*bp == (value_t)PH_NOTFOUND)
+ *bp = fixnum(printlabel++);
+ return;
+ }
+ if (discriminateAsVector(v)) {+ mark_cons(v);
+ unsigned int i;
+ for(i=0; i < vector_size(v); i++)
+ print_traverse(vector_elt(v,i));
+ }
+ else {+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ // don't consider shared references to ""
+ if (!cv->flags.cstring || cv_len(cv)!=0)
+ mark_cons(v);
+ }
+ }
+}
+
+static void print_symbol_name(FILE *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if ((name[0] == '\0') ||
+ (name[0] == '.' && name[1] == '\0') ||
+ (name[0] == '#') ||
+ isnumtok(name, NULL))
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ outc('|', f);+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ outc('\\', f);+ outc(name[i], f);
+ i++;
+ }
+ outc('|', f);+ }
+ else {+ outc('|', f);+ outs(name, f);
+ outc('|', f);+ }
+ }
+ else {+ outs(name, f);
+ }
+}
+
+/*
+ The following implements a simple pretty-printing algorithm. This is
+ an unlimited-width approach that doesn't require an extra pass.
+ It uses some heuristics to guess whether an expression is "small",
+ and avoids wrapping symbols across lines. The result is high
+ performance and nice output for typical code. Quality is poor for
+ pathological or deeply-nested expressions, but those are difficult
+ to print anyway.
+*/
+static inline int tinyp(value_t v)
+{+ return (issymbol(v) || isfixnum(v) || isbuiltin(v));
+}
+
+static int smallp(value_t v)
+{+ if (tinyp(v)) return 1;
+ if (isnumber(v)) return 1;
+ if (iscons(v)) {+ if (tinyp(car_(v)) && (tinyp(cdr_(v)) ||
+ (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
+ cdr_(cdr_(v))==NIL)))
+ return 1;
+ return 0;
+ }
+ if (isvector(v)) {+ size_t s = vector_size(v);
+ return (s == 0 || (tinyp(vector_elt(v,0)) &&
+ (s == 1 || (s == 2 &&
+ tinyp(vector_elt(v,1))))));
+ }
+ return 0;
+}
+
+static int specialindent(value_t v)
+{+ // indent these forms 2 spaces, not lined up with the first argument
+ if (v == LAMBDA || v == TRYCATCH)
+ return 2;
+ return -1;
+}
+
+static int lengthestimate(value_t v)
+{+ // get the width of an expression if we can do so cheaply
+ if (issymbol(v))
+ return u8_strwidth(symbol_name(v));
+ return -1;
+}
+
+static int allsmallp(value_t v)
+{+ int n = 1;
+ while (iscons(v)) {+ if (!smallp(car_(v)))
+ return 0;
+ v = cdr_(v);
+ n++;
+ if (n > 25)
+ return n;
+ }
+ return n;
+}
+
+static int indentevery(value_t v)
+{+ // indent before every subform of a special form, unless every
+ // subform is "small"
+ value_t c = car_(v);
+ if (c == LAMBDA)
+ return 0;
+ value_t f;
+ if (issymbol(c) && (f=((symbol_t*)ptr(c))->syntax) && isspecial(f))
+ return !allsmallp(cdr_(v));
+ return 0;
+}
+
+static int blockindent(value_t v)
+{+ // in this case we switch to block indent mode, where the head
+ // is no longer considered special:
+ // (a b c d e
+ // f g h i j)
+ return (allsmallp(v) > 9);
+}
+
+static void print_pair(FILE *f, value_t v, int princ)
+{+ value_t cd;
+ char *op = NULL;
+ if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL &&
+ !ptrhash_has(&printconses, (void*)cdr_(v)) &&
+ (((car_(v) == QUOTE) && (op = "'")) ||
+ ((car_(v) == BACKQUOTE) && (op = "`")) ||
+ ((car_(v) == COMMA) && (op = ",")) ||
+ ((car_(v) == COMMAAT) && (op = ",@")) ||
+ ((car_(v) == COMMADOT) && (op = ",.")))) {+ // special prefix syntax
+ unmark_cons(v);
+ unmark_cons(cdr_(v));
+ outs(op, f);
+ do_print(f, car_(cdr_(v)), princ);
+ return;
+ }
+ int startpos = HPOS;
+ outc('(', f);+ int newindent=HPOS, blk=blockindent(v);
+ int lastv, n=0, si, ind=0, est, always=0, nextsmall;
+ if (!blk) always = indentevery(v);
+ value_t head = car_(v);
+ while (1) {+ lastv = VPOS;
+ unmark_cons(v);
+ do_print(f, car_(v), princ);
+ cd = cdr_(v);
+ if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) {+ if (cd != NIL) {+ outs(" . ", f);+ do_print(f, cd, princ);
+ }
+ outc(')', f);+ break;
+ }
+
+ if (princ || (head == LAMBDA && n == 0)) {+ // never break line before lambda-list or in princ
+ ind = 0;
+ }
+ else {+ est = lengthestimate(car_(cd));
+ nextsmall = smallp(car_(cd));
+ ind = (((n > 0) &&
+ ((!nextsmall && HPOS>28) || (VPOS > lastv))) ||
+
+ ((VPOS > lastv) && (!nextsmall || n==0)) ||
+
+ (HPOS > 50 && !nextsmall) ||
+
+ (HPOS > 74) ||
+
+ (est!=-1 && (HPOS+est > 78)) ||
+
+ (head == LAMBDA && !nextsmall) ||
+
+ (n > 0 && always));
+ }
+
+ if (ind) {+ outindent(newindent, f);
+ }
+ else {+ outc(' ', f);+ if (n==0) {+ // set indent level after printing head
+ si = specialindent(head);
+ if (si != -1)
+ newindent = startpos + si;
+ else if (!blk)
+ newindent = HPOS;
+ }
+ }
+ n++;
+ v = cd;
+ }
+}
+
+void cvalue_print(FILE *f, value_t v, int princ);
+
+static void do_print(FILE *f, value_t v, int princ)
+{+ value_t label;
+ char *name;
+
+ switch (tag(v)) {+ case TAG_NUM: HPOS+=fprintf(f, "%ld", numval(v)); break;
+ case TAG_SYM:
+ name = symbol_name(v);
+ if (princ)
+ outs(name, f);
+ else if (v == NIL)
+ outs("()", f);+ else if (ismanaged(v)) {+ outs("#:", f);+ outs(name, f);
+ }
+ else
+ print_symbol_name(f, name);
+ break;
+ case TAG_BUILTIN:
+ if (isbuiltin(v)) {+ outs("#.", f);+ outs(builtin_names[uintval(v)], f);
+ break;
+ }
+ if (!ismanaged(v)) {+ assert(iscvalue(v));
+ cvalue_print(f, v, princ); break;
+ }
+ case TAG_CONS:
+ if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
+ (value_t)PH_NOTFOUND) {+ if (!ismarked(v)) {+ HPOS+=fprintf(f, "#%ld#", numval(label));
+ return;
+ }
+ HPOS+=fprintf(f, "#%ld=", numval(label));
+ }
+ if (isvector(v)) {+ outc('[', f);+ int newindent = HPOS, est;
+ unmark_cons(v);
+ int i, sz = vector_size(v);
+ for(i=0; i < sz; i++) {+ do_print(f, vector_elt(v,i), princ);
+ if (i < sz-1) {+ if (princ) {+ outc(' ', f);+ }
+ else {+ est = lengthestimate(vector_elt(v,i+1));
+ if (HPOS > 74 || (est!=-1 && (HPOS+est > 78)) ||
+ (HPOS > 40 && !smallp(vector_elt(v,i+1))))
+ outindent(newindent, f);
+ else
+ outc(' ', f);+ }
+ }
+ }
+ outc(']', f);+ break;
+ }
+ if (iscvalue(v)) {+ unmark_cons(v);
+ cvalue_print(f, v, princ);
+ break;
+ }
+ print_pair(f, v, princ);
+ break;
+ }
+}
+
+void print_string(FILE *f, char *str, size_t sz)
+{+ char buf[512];
+ size_t i = 0;
+
+ outc('"', f);+ while (i < sz) {+ u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
+ outs(buf, f);
+ }
+ outc('"', f);+}
+
+static numerictype_t sym_to_numtype(value_t type);
+
+// 'weak' means we don't need to accurately reproduce the type, so
+// for example #int32(0) can be printed as just 0. this is used
+// printing in a context where a type is already implied, e.g. inside
+// an array.
+static void cvalue_printdata(FILE *f, void *data, size_t len, value_t type,
+ int princ, int weak)
+{+ int64_t tmp=0;
+
+ if (type == charsym) {+ // print chars as characters when possible
+ unsigned char ch = *(unsigned char*)data;
+ if (princ)
+ outc(ch, f);
+ else if (weak)
+ HPOS+=fprintf(f, "%hhu", ch);
+ else if (isprint(ch))
+ HPOS+=fprintf(f, "#\\%c", ch);
+ else
+ HPOS+=fprintf(f, "#char(%hhu)", ch);
+ }
+ /*
+ else if (type == ucharsym) {+ uchar ch = *(uchar*)data;
+ if (princ)
+ outc(ch, f);
+ else {+ if (!weak)
+ fprintf(f, "#uchar(");+ fprintf(f, "%hhu", ch);
+ if (!weak)
+ outs(")", f);+ }
+ }
+ */
+ else if (type == wcharsym) {+ uint32_t wc = *(uint32_t*)data;
+ char seq[8];
+ if (weak)
+ HPOS+=fprintf(f, "%d", (int)wc);
+ else if (princ || (iswprint(wc) && wc>0x7f)) {+ // reader only reads #\c syntax as wchar if the code is >0x7f
+ size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
+ seq[nb] = '\0';
+ // TODO: better multibyte handling
+ if (!princ) outs("#\\", f);+ outs(seq, f);
+ }
+ else {+ HPOS+=fprintf(f, "#%s(%d)", symbol_name(type), (int)wc);
+ }
+ }
+ else if (type == int64sym
+#ifdef BITS64
+ || type == longsym
+#endif
+ ) {+ int64_t i64 = *(int64_t*)data;
+ if (fits_fixnum(i64) || princ) {+ if (weak || princ)
+ HPOS+=fprintf(f, "%lld", i64);
+ else
+ HPOS+=fprintf(f, "#%s(%lld)", symbol_name(type), i64);
+ }
+ else
+ HPOS+=fprintf(f, "#%s(0x%08x%08x)", symbol_name(type),
+ (uint32_t)(i64>>32),
+ (uint32_t)(i64));
+ }
+ else if (type == uint64sym
+#ifdef BITS64
+ || type == ulongsym
+#endif
+ ) {+ uint64_t ui64 = *(uint64_t*)data;
+ if (fits_fixnum(ui64) || princ) {+ if (weak || princ)
+ HPOS+=fprintf(f, "%llu", ui64);
+ else
+ HPOS+=fprintf(f, "#%s(%llu)", symbol_name(type), ui64);
+ }
+ else
+ HPOS+=fprintf(f, "#%s(0x%08x%08x)", symbol_name(type),
+ (uint32_t)(ui64>>32),
+ (uint32_t)(ui64));
+ }
+ else if (type == lispvaluesym) {+ // TODO
+ }
+ else if (type == floatsym || type == doublesym) {+ char buf[64];
+ double d;
+ if (type == floatsym) d = (double)*(float*)data;
+ else d = *(double*)data;
+ snprint_real(buf, sizeof(buf), d, 0, 16, 3, 10);
+ if (weak || princ || (type==doublesym && strpbrk(buf, ".eE"))) {+ outs(buf, f);
+ }
+ else {+ if (!DFINITE(d))
+ HPOS+=fprintf(f, "#%s(\"%s\")", symbol_name(type), buf);
+ else
+ HPOS+=fprintf(f, "#%s(%s)", symbol_name(type), buf);
+ }
+ }
+ else if (issymbol(type)) {+ // handle other integer prims. we know it's smaller than 64 bits
+ // at this point, so int64 is big enough to capture everything.
+ tmp = conv_to_int64(data, sym_to_numtype(type));
+ if (fits_fixnum(tmp) || princ) {+ if (weak || princ)
+ HPOS+=fprintf(f, "%lld", tmp);
+ else
+ HPOS+=fprintf(f, "#%s(%lld)", symbol_name(type), tmp);
+ }
+ else
+ HPOS+=fprintf(f, "#%s(0x%08x)", symbol_name(type),
+ (uint32_t)(tmp&0xffffffff));
+ }
+ else if (iscons(type)) {+ if (car_(type) == arraysym) {+ value_t eltype = car(cdr_(type));
+ size_t cnt, elsize;
+ if (iscons(cdr_(cdr_(type)))) {+ cnt = toulong(car_(cdr_(cdr_(type))), "length");
+ elsize = cnt ? len/cnt : 0;
+ }
+ else {+ // incomplete array type
+ int junk;
+ elsize = ctype_sizeof(eltype, &junk);
+ cnt = elsize ? len/elsize : 0;
+ }
+ if (eltype == charsym) {+ if (princ) {+ fwrite(data, 1, len, f);
+ }
+ else {+ print_string(f, (char*)data, len);
+ }
+ return;
+ }
+ else if (eltype == wcharsym) {+ // TODO wchar
+ }
+ else {+ }
+ size_t i;
+ if (!weak) {+ outs("#array(", f);+ do_print(f, eltype, princ);
+ outc(' ', f);+ }
+ outc('[', f);+ for(i=0; i < cnt; i++) {+ cvalue_printdata(f, data, elsize, eltype, princ, 1);
+ if (i < cnt-1)
+ outc(' ', f);+ data += elsize;
+ }
+ outc(']', f);+ if (!weak)
+ outc(')', f);+ }
+ else if (car_(type) == enumsym) {+ value_t sym = list_nth(car(cdr_(type)), *(size_t*)data);
+ if (!weak) {+ outs("#enum(", f);+ do_print(f, car(cdr_(type)), princ);
+ outc(' ', f);+ }
+ if (sym == NIL) {+ cvalue_printdata(f, data, len, int32sym, princ, 1);
+ }
+ else {+ do_print(f, sym, princ);
+ }
+ if (!weak)
+ outc(')', f);+ }
+ }
+}
+
+void cvalue_print(FILE *f, value_t v, int princ)
+{+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ void *data = cv_data(cv);
+
+ if (cv->flags.islispfunction) {+ HPOS+=fprintf(f, "#<guestfunction @0x%08lx>",
+ (unsigned long)*(guestfunc_t*)data);
+ return;
+ }
+
+ cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0);
+}
+
+void print(FILE *f, value_t v, int princ)
+{+ ptrhash_reset(&printconses, 32);
+ printlabel = 0;
+ print_traverse(v);
+ HPOS = VPOS = 0;
+ do_print(f, v, princ);
+}
--- /dev/null
+++ b/femtolisp/printcases.lsp
@@ -1,0 +1,21 @@
+macroexpand
+append
+bq-process
+(syntax-environment)
+
+(symbol-syntax 'try)
+
+(map-int (lambda (x) `(a b c d e)) 90)
+
+(list-to-vector (map-int (lambda (x) `(a b c d e)) 90))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
+
+'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))
--- /dev/null
+++ b/femtolisp/read.c
@@ -1,0 +1,542 @@
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
+ TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
+};
+
+// defines which characters are ordinary symbol characters.
+// exceptions are '.', which is an ordinary symbol character
+// unless it's the only character in the symbol, and '#', which is
+// an ordinary symbol character unless it's the first character.
+static int symchar(char c)
+{+ static char *special = "()[]'\";`,\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static int isnumtok(char *tok, value_t *pval)
+{+ char *end;
+ int64_t i64;
+ uint64_t ui64;
+ double d;
+ if (*tok == '\0')
+ return 0;
+ if (!((tok[0]=='0' && tok[1]=='x') || // these formats are always integer
+ (tok[0]=='0' && isdigit(tok[1]))) &&
+ strpbrk(tok, ".eE")) {+ d = strtod(tok, &end);
+ if (*end == '\0') {+ if (pval) *pval = mk_double(d);
+ return 1;
+ }
+ }
+ if (isdigit(tok[0]) || tok[0]=='-' || tok[0]=='+') {+ if (tok[0]=='-') {+ i64 = strtoll(tok, &end, 0);
+ if (pval) *pval = return_from_int64(i64);
+ }
+ else {+ ui64 = strtoull(tok, &end, 0);
+ if (pval) *pval = return_from_uint64(ui64);
+ }
+ if (*end == '\0')
+ return 1;
+ }
+ return 0;
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ int ch;
+ char c;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror(ParseError, "read: token too long");
+}
+
+// return: 1 if escaped (forced to be symbol)
+static int read_token(FILE *f, char c, int digits)
+{+ int i=0, ch, escaped=0, issym=0, first=1;
+
+ while (1) {+ if (!first) {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ }
+ first = 0;
+ if (c == '|') {+ issym = 1;
+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ issym = 1;
+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return issym;
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ fixnum_t x;
+ int ch;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '[') {+ toktype = TOK_OPENB;
+ }
+ else if (c == ']') {+ toktype = TOK_CLOSEB;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '"') {+ toktype = TOK_DOUBLEQUOTE;
+ }
+ else if (c == '#') {+ ch = fgetc(f);
+ if (ch == EOF)
+ lerror(ParseError, "read: invalid read macro");
+ if ((char)ch == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if ((char)ch == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if ((char)ch == '\\') {+ u_int32_t cval = u8_fgetc(f);
+ if (cval == UEOF)
+ lerror(ParseError, "read: end of input in character constant");
+ toktype = TOK_NUM;
+ tokval = fixnum(cval);
+ if (cval > 0x7f) {+ tokval = cvalue_wchar(&tokval, 1);
+ }
+ else {+ tokval = cvalue_char(&tokval, 1);
+ }
+ }
+ else if ((char)ch == '(') {+ toktype = TOK_SHARPOPEN;
+ }
+ else if ((char)ch == '<') {+ lerror(ParseError, "read: unreadable object");
+ }
+ else if (isdigit((char)ch)) {+ read_token(f, (char)ch, 1);
+ c = (char)fgetc(f);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror(ParseError, "read: invalid label");
+ errno = 0;
+ x = strtol(buf, &end, 10);
+ if (*end != '\0' || errno)
+ lerror(ParseError, "read: invalid label");
+ tokval = fixnum(x);
+ }
+ else if ((char)ch == '!') {+ // #! single line comment for shbang script support
+ do {+ ch = fgetc(f);
+ } while (ch != EOF && (char)ch != '\n');
+ return peek(f);
+ }
+ else if ((char)ch == '|') {+ // multiline comment
+ while (1) {+ ch = fgetc(f);
+ hashpipe_got:
+ if (ch == EOF)
+ lerror(ParseError, "read: eof within comment");
+ if ((char)ch == '|') {+ ch = fgetc(f);
+ if ((char)ch == '#')
+ break;
+ goto hashpipe_got;
+ }
+ }
+ // this was whitespace, so keep peeking
+ return peek(f);
+ }
+ else if ((char)ch == ':') {+ // gensym
+ ch = fgetc(f);
+ if ((char)ch == 'g')
+ ch = fgetc(f);
+ read_token(f, (char)ch, 0);
+ errno = 0;
+ x = strtol(buf, &end, 10);
+ if (*end != '\0' || buf[0] == '\0' || errno)
+ lerror(ParseError, "read: invalid gensym label");
+ toktype = TOK_GENSYM;
+ tokval = fixnum(x);
+ }
+ else if (symchar((char)ch)) {+ 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");
+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = fgetc(f);
+ if (ch == EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ungetc((char)ch, f);
+ }
+ else {+ if (!read_token(f, c, 0)) {+ if (buf[0]=='.' && buf[1]=='\0') {+ return (toktype=TOK_DOT);
+ }
+ else {+ errno = 0;
+ if (isnumtok(buf, &tokval)) {+ if (errno)
+ lerror(ParseError,"read: overflow in numeric constant");
+ return (toktype=TOK_NUM);
+ }
+ }
+ }
+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ return toktype;
+}
+
+static value_t do_read_sexpr(FILE *f, value_t label);
+
+static value_t read_vector(FILE *f, value_t label, u_int32_t closer)
+{+ value_t v=alloc_vector(4, 1), elt;
+ u_int32_t i=0;
+ PUSH(v);
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
+ while (peek(f) != closer) {+ if (feof(f))
+ lerror(ParseError, "read: unexpected end of input");
+ if (i >= vector_size(v))
+ Stack[SP-1] = vector_grow(v);
+ elt = do_read_sexpr(f, UNBOUND);
+ v = Stack[SP-1];
+ vector_elt(v,i) = elt;
+ i++;
+ }
+ take();
+ vector_setsize(v, i);
+ return POP();
+}
+
+static value_t read_string(FILE *f)
+{+ char *buf, *temp;
+ char eseq[10];
+ size_t i=0, j, sz = 64, ndig;
+ int c;
+ value_t s;
+ u_int32_t wc;
+
+ buf = malloc(sz);
+ while (1) {+ if (i >= sz-4) { // -4: leaves room for longest utf8 sequence+ sz *= 2;
+ temp = realloc(buf, sz);
+ if (temp == NULL) {+ free(buf);
+ lerror(ParseError, "read: out of memory reading string");
+ }
+ buf = temp;
+ }
+ c = fgetc(f);
+ if (c == EOF) {+ free(buf);
+ lerror(ParseError, "read: unexpected end of input in string");
+ }
+ if (c == '"')
+ break;
+ else if (c == '\\') {+ c = fgetc(f);
+ if (c == EOF) {+ free(buf);
+ lerror(ParseError, "read: end of input in escape sequence");
+ }
+ j=0;
+ if (octal_digit(c)) {+ do {+ eseq[j++] = c;
+ c = fgetc(f);
+ } while (octal_digit(c) && j<3 && (c!=EOF));
+ if (c!=EOF) ungetc(c, f);
+ eseq[j] = '\0';
+ wc = strtol(eseq, NULL, 8);
+ i += u8_wc_toutf8(&buf[i], wc);
+ }
+ else if ((c=='x' && (ndig=2)) ||
+ (c=='u' && (ndig=4)) ||
+ (c=='U' && (ndig=8))) {+ wc = c;
+ c = fgetc(f);
+ while (hex_digit(c) && j<ndig && (c!=EOF)) {+ eseq[j++] = c;
+ c = fgetc(f);
+ }
+ if (c!=EOF) ungetc(c, f);
+ eseq[j] = '\0';
+ if (j) wc = strtol(eseq, NULL, 16);
+ i += u8_wc_toutf8(&buf[i], wc);
+ }
+ else if (c == 'n')
+ buf[i++] = '\n';
+ else if (c == 't')
+ buf[i++] = '\t';
+ else if (c == 'r')
+ buf[i++] = '\r';
+ else if (c == 'b')
+ buf[i++] = '\b';
+ else if (c == 'f')
+ buf[i++] = '\f';
+ else if (c == 'v')
+ buf[i++] = '\v';
+ else if (c == 'a')
+ buf[i++] = '\a';
+ else
+ buf[i++] = c;
+ }
+ else {+ buf[i++] = c;
+ }
+ }
+ s = cvalue_string(i);
+ memcpy(cvalue_data(s), buf, i);
+ free(buf);
+ return s;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval, value_t label)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror(ParseError, "read: unexpected end of input");
+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)c);
+ }
+ *pc = c;
+ c = do_read_sexpr(f,UNBOUND); // must be on separate lines due to
+ car_(*pc) = c; // undefined evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(f,UNBOUND);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror(ParseError, "read: unexpected end of input");
+ if (t != TOK_CLOSE)
+ lerror(ParseError, "read: expected ')'");
+ }
+ }
+ take();
+ (void)POP();
+}
+
+// label is the backreference we'd like to fix up with this read
+static value_t do_read_sexpr(FILE *f, value_t label)
+{+ value_t v, sym, oldtokval, *head;
+ value_t *pv;
+ u_int32_t t;
+
+ t = peek(f);
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror(ParseError, "read: unexpected ')'");
+ case TOK_CLOSEB:
+ lerror(ParseError, "read: unexpected ']'");
+ case TOK_DOT:
+ lerror(ParseError, "read: unexpected '.'");
+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ v = cons_reserve(2);
+ car_(v) = *head;
+ cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
+ car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
+ PUSH(v);
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
+ v = do_read_sexpr(f,UNBOUND);
+ car_(cdr_(Stack[SP-1])) = v;
+ return POP();
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(f, label);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], label);
+ return POP();
+ case TOK_SHARPSYM:
+ // constructor notation
+ sym = tokval;
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], UNBOUND);
+ v = POP();
+ return apply(sym, v);
+ case TOK_OPENB:
+ return read_vector(f, label, TOK_CLOSEB);
+ case TOK_SHARPOPEN:
+ return read_vector(f, label, TOK_CLOSE);
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ v = do_read_sexpr(f,UNBOUND);
+ return toplevel_eval(v);
+ case TOK_LABEL:
+ // create backreference label
+ if (ptrhash_has(&readstate->backrefs, (void*)tokval))
+ lerror(ParseError, "read: label %ld redefined", numval(tokval));
+ oldtokval = tokval;
+ v = do_read_sexpr(f, tokval);
+ ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
+ if (v == (value_t)PH_NOTFOUND)
+ lerror(ParseError, "read: undefined label %ld", numval(tokval));
+ return v;
+ case TOK_GENSYM:
+ pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
+ if (*pv == (value_t)PH_NOTFOUND)
+ *pv = gensym(NULL, 0);
+ return *pv;
+ case TOK_DOUBLEQUOTE:
+ return read_string(f);
+ }
+ return NIL;
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+ readstate_t state;
+ state.prev = readstate;
+ ptrhash_new(&state.backrefs, 16);
+ ptrhash_new(&state.gensyms, 16);
+ readstate = &state;
+
+ v = do_read_sexpr(f, UNBOUND);
+
+ readstate = state.prev;
+ free_readstate(&state);
+ return v;
+}
--- /dev/null
+++ b/femtolisp/site/doc
@@ -1,0 +1,62 @@
+1. Syntax
+
+symbols
+numbers
+conses and vectors
+comments
+special prefix tokens: ' ` , ,@ ,.
+other read macros: #. #' #\ #< #n= #n# #: #ctor
+builtins
+
+2. Data and execution models
+
+3. Primitive functions
+
+eq atom not set prog1 progn
+symbolp numberp builtinp consp vectorp boundp
++ - * / <
+apply eval
+
+4. Special forms
+
+quote if lambda macro while label cond and or
+
+5. Data structures
+
+cons car cdr rplaca rplacd list
+alloc vector aref aset length
+
+6. Other functions
+
+read, print, princ, load, exit
+equal, compare
+gensym
+
+7. Exceptions
+
+trycatch raise
+
+8. Cvalues
+
+introduction
+type representations
+constructors
+access
+memory management concerns
+ccall
+
+
+If deliberate 50% heap utilization seems wasteful, consider:
+
+- malloc has per-object overhead. for small allocations you might use
+ much more space than you think.
+- any non-moving memory manager (whether malloc or a collector) can
+ waste arbitrary amounts of memory through fragmentation.
+
+With a copying collector, you agree to give up 50% of your memory
+up front, in exchange for significant benefits:
+
+- really fast allocation
+- heap compaction, improving locality and possibly speeding up computation
+- collector performance O(1) in number of dead objects, essential for
+ maximal performance on generational workloads
--- /dev/null
+++ b/femtolisp/site/doc.html
@@ -1,0 +1,428 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html;charset=utf-8" >
+<title>femtoLisp</title>
+</head>
+<body bgcolor="#fcfcfc"> <!-"#fcfcc8">
+<img src="flbanner.jpg">
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>0. Argument</h1>
+This Lisp has the following characteristics and goals:
+
+<ul>
+<li>Lisp-1 evaluation rule (ala Scheme)
+<li>Self-evaluating lambda (i.e. <tt>'(lambda (x) x)</tt> is callable)
+<li>Full Common Lisp-style macros
+<li>Dotted lambda lists for rest arguments (ala Scheme)
+<li>Symbols have one binding
+<li>Builtin functions are constants
+<li><em>All</em> values are printable and readable
+<li>Case-sensitive symbol names
+<li>Only the minimal core built-in (i.e. written in C), but
+ enough to provide a practical level of performance
+<li>Very short (but not necessarily simple...) implementation
+<li>Generally use Common Lisp operator names
+<li>Nothing excessively weird or fancy
+</ul>
+
+<h1>1. Syntax</h1>
+<h2>1.1. Symbols</h2>
+Any character string can be a symbol name, including the empty string. In
+general, text between whitespace is read as a symbol except in the following
+cases:
+<ul>
+<li>The text begins with <tt>#</tt>
+<li>The text consists of a single period <tt>.</tt>
+<li>The text contains one of the special characters <tt>()[]';`,\|</tt>
+<li>The text is a valid number
+<li>The text is empty
+</ul>
+In these cases the symbol can be written by surrounding it with <tt>| |</tt>
+characters, or by escaping individual characters within the symbol using
+backslash <tt>\</tt>. Note that <tt>|</tt> and <tt>\</tt> must always be
+preceded with a backslash when writing a symbol name.
+
+<h2>1.2. Numbers</h2>
+
+A number consists of an optional + or - sign followed by one of the following
+sequences:
+<ul>
+<li><tt>NNN...</tt> where N is a decimal digit
+<li><tt>0xNNN...</tt> where N is a hexadecimal digit
+<li><tt>0NNN...</tt> where N is an octal digit
+</ul>
+femtoLisp provides 30-bit integers, and it is an error to write a constant
+less than -2<sup>29</sup> or greater than 2<sup>29</sup>-1.
+
+<h2>1.3. Conses and vectors</h2>
+
+The text <tt>(a b c)</tt> parses to the structure
+<tt>(cons a (cons b (cons c nil)))</tt> where a, b, and c are arbitrary
+expressions.
+<p>
+The text <tt>(a . b)</tt> parses to the structure
+<tt>(cons a b)</tt> where a and b are arbitrary expressions.
+<p>
+The text <tt>()</tt> reads as the symbol <tt>nil</tt>.
+<p>
+The text <tt>[a b c]</tt> parses to a vector of expressions a, b, and c.
+The syntax <tt>#(a b c)</tt> has the same meaning.
+
+
+<h2>1.4. Comments</h2>
+
+Text between a semicolon <tt>;</tt> and the next end-of-line is skipped.
+Text between <tt>#|</tt> and <tt>|#</tt> is also skipped.
+
+<h2>1.5. Prefix tokens</h2>
+
+There are five special prefix tokens which parse as follows:<p>
+<tt>'a</tt> is equivalent to <tt>(quote a)</tt>.<br>
+<tt>`a</tt> is equivalent to <tt>(backquote a)</tt>.<br>
+<tt>,a</tt> is equivalent to <tt>(*comma* a)</tt>.<br>
+<tt>,@a</tt> is equivalent to <tt>(*comma-at* a)</tt>.<br>
+<tt>,.a</tt> is equivalent to <tt>(*comma-dot* a)</tt>.
+
+
+<h2>1.6. Other read macros</h2>
+
+femtoLisp provides a few "read macros" that let you accomplish interesting
+tricks for textually representing data structures.
+
+<table border=1>
+<tr>
+<td>sequence<td>meaning
+<tr>
+<td><tt>#.e</tt><td>evaluate expression <tt>e</tt> and behave as if e's
+ value had been written in place of e
+<tr>
+<td><tt>#\c</tt><td><tt>c</tt> is a character; read as its Unicode value
+<tr>
+<td><tt>#n=e</tt><td>read <tt>e</tt> and label it as <tt>n</tt>, where n
+ is a decimal number
+<tr>
+<td><tt>#n#</tt><td>read as the identically-same value previously labeled
+ <tt>n</tt>
+<tr>
+<td><tt>#:gNNN or #:NNN</tt><td>read a gensym. NNN is a hexadecimal
+ constant. future occurrences of the same <tt>#:</tt> sequence will read to
+ the identically-same gensym
+<tr>
+<td><tt>#sym(...)</tt><td>reads to the result of evaluating
+ <tt>(apply sym '(...))</tt>
+<tr>
+<td><tt>#<</tt><td>triggers an error
+<tr>
+<td><tt>#'</tt><td>ignored; provided for compatibility
+<tr>
+<td><tt>#!</tt><td>single-line comment, for script execution support
+<tr>
+<td><tt>"str"</tt><td>UTF-8 character string; may contain newlines.
+ <tt>\</tt> is the escape character. All C escape sequences are supported, plus
+ <tt>\u</tt> and <tt>\U</tt> for unicode values.
+</table>
+When a read macro involves persistent state (e.g. label assignments), that
+state is valid only within the closest enclosing call to <tt>read</tt>.
+
+
+<h2>1.7. Builtins</h2>
+
+Builtin functions are represented as opaque constants. Every builtin
+function is the value of some constant symbol, so the builtin <tt>eq</tt>,
+for example, can be written as <tt>#.eq</tt> ("the value of symbol eq").+Note that <tt>eq</tt> itself is still an ordinary symbol, except that its
+value cannot be changed.
+<p>
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+
+<h1>2. Data and execution models</h1>
+
+
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+
+<h1>3. Primitive functions</h1>
+
+
+eq atom not set prog1 progn
+symbolp numberp builtinp consp vectorp boundp
++ - * / <
+apply eval
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>4. Special forms</h1>
+
+quote if lambda macro while label cond and or
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>5. Data structures</h1>
+
+cons car cdr rplaca rplacd list
+alloc vector aref aset length
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>6. Other functions</h1>
+
+read print princ load exit
+equal compare
+gensym
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>7. Exceptions</h1>
+
+trycatch raise
+
+
+<table border=0 width="100%" cellpadding=0 cellspacing=0>
+<tr><td bgcolor="#2d3f5f" height=4></table>
+
+<h1>8. Cvalues</h1>
+
+<h2>8.1. Introduction</h2>
+
+femtoLisp allows you to use the full range of C data types on
+dynamically-typed Lisp values. The motivation for this feature is that
+useful
+interpreters must provide a large library of routines in C for dealing
+with "real world" data like text and packed numeric arrays, and I would
+rather not write yet another such library. Instead, all the
+required data representations and primitives are provided so that such
+features could be implemented in, or at least described in, Lisp.
+<p>
+The cvalues capability makes it easier to call C from Lisp by providing
+ways to construct whatever arguments your C routines might require, and ways
+to decipher whatever values your C routines might return. Here are some
+things you can do with cvalues:
+<ul>
+<li>Call native C functions from Lisp without wrappers
+<li>Wrap C functions in pure Lisp, automatically inheriting some degree
+ of type safety
+<li>Use Lisp functions as callbacks from C code
+<li>Use the Lisp garbage collector to reclaim malloc'd storage
+<li>Annotate C pointers with size information for bounds checking or
+ serialization
+<li>Attach symbolic type information to a C data structure, allowing it to
+ inherit Lisp services such as printing a readable representation
+<li>Add datatypes like strings to Lisp
+<li>Use more efficient represenations for your Lisp programs' data
+</ul>
+<p>
+femtoLisp's "cvalues" is inspired in part by Python's "ctypes" package.
+Lisp doesn't really have first-class types the way Python does, but it does
+have values, hence my version is called "cvalues".
+
+<h2>8.2. Type representations</h2>
+
+The core of cvalues is a language for describing C data types as
+symbolic expressions:
+
+<ul>
+<li>Primitive types are symbols <tt>int8, uint8, int16, uint16, int32, uint32,
+int64, uint64, char, wchar, long, ulong, float, double, void</tt>
+<li>Arrays <tt>(array TYPE SIZE)</tt>, where TYPE is another C type and
+SIZE is either a Lisp number or a C ulong. SIZE can be omitted to
+represent incomplete C array types like "int a[]". As in C, the size may
+only be omitted for the top level of a nested array; all array
+<em>element</em> types
+must have explicit sizes. Examples:
+<ul>
+ <tt>int a[][2][3]</tt> is <tt>(array (array (array int32 3) 2))</tt><br>
+ <tt>int a[4][]</tt> would be <tt>(array (array int32) 4)</tt>, but this is
+ invalid.
+</ul>
+<li>Pointer <tt>(pointer TYPE)</tt>
+<li>Struct <tt>(struct ((NAME TYPE) (NAME TYPE) ...))</tt>
+<li>Union <tt>(union ((NAME TYPE) (NAME TYPE) ...))</tt>
+<li>Enum <tt>(enum (NAME NAME ...))</tt>
+<li>Function <tt>(c-function RET-TYPE (ARG-TYPE ARG-TYPE ...))</tt>
+</ul>
+
+A cvalue can be constructed using <tt>(c-value TYPE arg)</tt>, where
+<tt>arg</tt> is some Lisp value. The system will try to convert the Lisp
+value to the specified type. In many cases this will work better if some
+components of the provided Lisp value are themselves cvalues.
+
+<p>
+Note the function type is called "c-function" to avoid confusion, since
+functions are such a prevalent concept in Lisp.
+
+<p>
+The function <tt>sizeof</tt> returns the size (in bytes) of a cvalue or a
+c type. Every cvalue has a size, but incomplete types will cause
+<tt>sizeof</tt> to raise an error. The function <tt>typeof</tt> returns
+the type of a cvalue.
+
+<p>
+You are probably wondering how 32- and 64-bit integers are constructed from
+femtoLisp's 30-bit integers. The answer is that larger integers are
+constructed from multiple Lisp numbers 16 bits at a time, in big-endian
+fashion. In fact, the larger numeric types are the only cvalues
+types whose constructors accept multiple arguments. Examples:
+<ul>
+<pre>
+(c-value 'int32 0xdead 0xbeef) ; make 0xdeadbeef
+(c-value 'uint64 0x1001 0x8000 0xffff) ; make 0x000010018000ffff
+</pre>
+</ul>
+As you can see, missing zeros are padded in from the left.
+
+
+<h2>8.3. Constructors</h2>
+
+For convenience, a specialized constructor is provided for each
+class of C type (primitives, pointer, array, struct, union, enum,
+and c-function).
+For example:
+<ul>
+<pre>
+(uint32 0xcafe 0xd00d)
+(int32 -4)
+(char #\w)
+(array 'int8 [1 1 2 3 5 8])
+</pre>
+</ul>
+
+These forms can be slightly less efficient than <tt>(c-value ...)</tt>
+because in many cases they will allocate a new type for the new value.
+For example, the fourth expression must create the type
+<tt>(array int8 6)</tt>.
+
+<p>
+Notice that calls to these constructors strongly resemble
+the types of the values they create. This relationship can be expressed
+formally as follows:
+
+<pre>
+(define (c-allocate type)
+ (if (atom type)
+ (apply (eval type) ())
+ (apply (eval (car type)) (cdr type))))
+</pre>
+
+This function produces an instance of the given type by
+invoking the appropriate constructor. Primitive types (whose representations
+are symbols) can be constructed with zero arguments. For other types,
+the only required arguments are those present in the type representation.
+Any arguments after those are initializers. Using
+<tt>(cdr type)</tt> as the argument list provides only required arguments,
+so the value you get will not be initialized.
+
+<p>
+The builtin <tt>c-value</tt> function is similar to this one, except that it
+lets you pass initializers.
+
+<p>
+Cvalue constructors are generally permissive; they do the best they
+can with whatever you pass in. For example:
+
+<ul>
+<pre>
+(c-value '(array int8 1)) ; ok, full type provided
+(c-value '(array int8)) ; error, no size information
+(c-value '(array int8) [0 1]) ; ok, size implied by initializer
+</pre>
+</ul>
+
+<p>
+ccopy, c2lisp
+
+<h2>8.4. Pointers, arrays, and strings</h2>
+
+Pointer types are provided for completeness and C interoperability, but
+they should not generally be used from Lisp. femtoLisp doesn't know
+anything about a pointer except the raw address and the (alleged) type of the
+value it points to. Arrays are much more useful. They behave like references
+as in C, but femtoLisp tracks their sizes and performs bounds checking.
+
+<p>
+Arrays are used to allocate strings. All strings share
+the incomplete array type <tt>(array char)</tt>:
+
+<pre>
+> (c-value '(array char) [#\h #\e #\l #\l #\o])
+"hello"
+
+> (sizeof that)
+5
+</pre>
+
+<tt>sizeof</tt> reveals that the size is known even though it is not
+reflected in the type (as is always the case with incomplete array types).
+
+<p>
+Since femtoLisp tracks the sizes of all values, there is no need for NUL
+terminators. Strings are just arrays of bytes, and may contain zero bytes
+throughout. However, C functions require zero-terminated strings. To
+solve this problem, femtoLisp allocates magic strings that actually have
+space for one more byte than they appear to. The hidden extra byte is
+always zero. This guarantees that a C function operating on the string
+will never overrun its allocated space.
+
+<p>
+Such magic strings are produced by double-quoted string literals, and by
+any explicit string-constructing function (such as <tt>string</tt>).
+
+<p>
+Unfortunately you still need to be careful, because it is possible to
+allocate a non-magic character array with no terminator. The "hello"
+string above is an example of this, since it was constructed from an
+explicit vector of characters.
+Such an array would cause problems if passed to a function expecting a
+C string.
+
+<p>
+deref
+
+<h2>8.5. Access</h2>
+
+cref,cset,byteref,byteset,ccopy
+
+<h2>8.6. Memory management concerns</h2>
+
+autorelease
+
+
+<h2>8.7. Guest functions</h2>
+
+Functions written in C but designed to operate on Lisp values are
+known here as "guest functions". Although they are foreign, they live in
+Lisp's house and so live by its rules. Guest functions are what you
+use to write interpreter extensions, for example to implement a function
+like <tt>assoc</tt> in C for performance.
+
+<p>
+Guest functions must have a particular signature:
+<pre>
+value_t func(value_t *args, uint32_t nargs);
+</pre>
+Guest functions must also be aware of the femtoLisp API and garbage
+collector.
+
+
+<h2>8.8. Native functions</h2>
+
+</body>
+</html>
binary files /dev/null b/femtolisp/site/flbanner.jpg differ
binary files /dev/null b/femtolisp/site/flbanner.xcf differ
binary files /dev/null b/femtolisp/site/flbanner2.jpg differ
binary files /dev/null b/femtolisp/site/home.gif differ
--- /dev/null
+++ b/femtolisp/site/index.html
@@ -1,0 +1,206 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html;charset=utf-8" >
+<title>femtoLisp</title>
+</head>
+<body>
+<h1>femtoLisp</h1>
+<hr>
+femtoLisp is an elegant Lisp implementation. Its goal is to be a
+reasonably efficient and capable interpreter with the shortest, simplest
+code possible. As its name implies, it is small (10<sup>-15</sup>).
+Right now it is just 1000 lines of C (give or take). It would make a great
+teaching example, or a useful system anywhere a very small Lisp is wanted.
+It is also a useful basis for developing other interpreters or related
+languages.
+
+
+<h2>The language implemented</h2>
+
+femtoLisp tries to be a generic, simple Lisp dialect, influenced by McCarthy's
+original.
+
+<ul>
+<li>Types: cons, symbol, 30-bit integer, builtin function
+<li>Self-evaluating lambda, macro, and label forms
+<li>Full Common Lisp-style macros
+<li>Case-sensitive symbol names
+<li>Scheme-style evaluation rule where any expression may appear in head
+ position as long as it evaluates to a callable
+<li>Scheme-style formal argument lists (dotted lists for varargs)
+<li>Transparent closure representation <tt>(lambda args body . env)</tt>
+<li>A lambda body may contain only one form. Use explicit <tt>progn</tt> for
+ multiple forms. Included macros, however, allow <tt>defun</tt>,
+ <tt>let</tt>, etc. to accept multiple body forms.
+<li>Builtin function names are constants and cannot be redefined.
+<li>Symbols have one binding, as in Scheme.
+</ul>
+<b>Builtin special forms:</b><br>
+<tt>quote, cond, if, and, or, lambda, macro, label, while, progn, prog1</tt>
+<p>
+<b>Builtin functions:</b><br>
+<tt>eq, atom, not, symbolp, numberp, boundp, cons, car, cdr,
+ read, eval, print, load, set,
+ +, -, *, /, <, apply, rplaca, rplacd</tt>
+<p>
+<b>Included library functions and macros:</b><br>
+<tt>
+setq, setf, defmacro, defun, define, let, let*, labels, dotimes,
+macroexpand-1, macroexpand, backquote,
+
+null, consp, builtinp, self-evaluating-p, listp, eql, equal, every, any,
+when, unless,
+
+=, !=, >, <=, >=, compare, mod, abs, identity,
+
+list, list*, length, last, nthcdr, lastcdr, list-ref, reverse, nreverse,
+assoc, member, append, nconc, copy-list, copy-tree, revappend, nreconc,
+
+mapcar, filter, reduce, map-int,
+
+symbol-plist, set-symbol-plist, put, get
+</tt>
+<p>
+<a href="system.lsp">system.lsp</a>
+
+
+<h2>The implementation</h2>
+
+<ul>
+<li>Compacting copying garbage collector (<tt>O(1)</tt> in number of dead
+ objects)
+<li>Tagged pointers for efficient type checking and fast integers
+<li>Tail-recursive evaluator (tail calls use no stack space)
+<li>Minimally-consing <tt>apply</tt>
+<li>Interactive and script execution modes
+</ul>
+<p>
+<a href="lisp.c">lisp.c</a>
+
+
+<h2>femtoLisp2</h2>
+
+This version includes robust reading and printing capabilities for
+circular structures and escaped symbol names. It adds read and print support
+for the Common Lisp read-macros <tt>#., #n#,</tt> and <tt>#n=</tt>.
+This allows builtins to be printed in a readable fashion as e.g.
+"<tt>#.eq</tt>".
+<p>
+The net result is that the interpreter achieves a highly satisfying property
+of closure under I/O. In other words, every representable Lisp value can be
+read and printed.
+<p>
+The traditional builtin <tt>label</tt> provides a purely-functional,
+non-circular way
+to write an anonymous recursive function. In femtoLisp2 you can
+achieve the same effect "manually" using nothing more than the reader:
+<br>
+<tt>#0=(lambda (x) (if (<= x 0) 1 (* x (#0# (- x 1)))))</tt>
+<p>
+femtoLisp2 has the following extra features and optimizations:
+<ul>
+<li> builtin functions <tt>error, exit,</tt> and <tt>princ</tt>
+<li> read support for backquote expressions
+<li> delayed environment consing
+<li> collective allocation of cons chains
+</ul>
+Those two optimizations are a Big Deal.
+<p>
+<a href="lisp2.c">lisp2.c</a> (uses <a href="flutils.c">flutils.c</a>)
+
+
+<h2>Performance</h2>
+
+femtoLisp's performance is surprising. It is faster than most
+interpreters, and it is usually within a factor of 2-5 of compiled CLISP.
+
+<table border=1>
+<tr>
+<td colspan=3><center><b>solve 5 queens problem 100x</b></center></td>
+<tr>
+<td> <td>interpreted<td>compiled
+<tr>
+<td>CLISP <td>4.02 sec <td>0.68 sec
+<tr>
+<td>femtoLisp2<td>2.62 sec <td>2.03 sec**
+<tr>
+<td>femtoLisp <td>6.02 sec <td>5.64 sec**
+<tr>
+
+<td colspan=3><center><b>recursive fib(34)</b></center></td>
+<tr>
+<td> <td>interpreted<td>compiled
+<tr>
+<td>CLISP <td>23.12 sec <td>4.04 sec
+<tr>
+<td>femtoLisp2<td>4.71 sec <td>n/a
+<tr>
+<td>femtoLisp <td>7.25 sec <td>n/a
+<tr>
+
+</table>
+** femtoLisp is not a compiler; in this context "compiled" means macros
+were pre-expanded.
+
+
+<h2>"Installation"</h2>
+
+Here is a <a href="Makefile">Makefile</a>. Type <tt>make</tt> to build
+femtoLisp, <tt>make NAME=lisp2</tt> to build femtoLisp2.
+
+
+<h2>Tail recursion</h2>
+The femtoLisp evaluator is tail-recursive, following the idea in
+<a href="http://library.readscheme.org/servlets/cite.ss?pattern=Ste-76b">
+Lambda: The Ultimate Declarative</a> (should be required reading
+for all schoolchildren).
+<p>
+The femtoLisp source provides a simple concrete example showing why a function
+call is best viewed as a "renaming plus goto" rather than as a set of stack
+operations.
+<p>
+Here is the non-tail-recursive evaluator code to evaluate the body of a
+lambda (function), from <a href="lisp-nontail.c">lisp-nontail.c</a>:
+<pre>
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ return v;
+</pre>
+(Note that because of the copying garbage collector, values are referenced
+through relocatable handles.)
+<p>
+Superficially, the call to <tt>eval</tt> is not a tail call, because work
+remains after it returns—namely, popping the environment off the stack.
+In other words, the control stack must be saved and restored to allow us to
+eventually restore the environment stack. However, restoring the environment
+stack is the <i>only</i> work to be done. Yet after this point the old
+environment is not used! So restoring the environment stack isn't
+necessary, therefore restoring the control stack isn't either.
+<p>
+This perspective makes proper tail recursion seem like more than an
+alternate design or optimization. It seems more correct.
+<p>
+Here is the corrected, tail-recursive version of the code:
+<pre>
+ SP = saveSP; // restore stack completely
+ e = *body; // reassign arguments
+ *penv = *lenv;
+ goto eval_top;
+</pre>
+<tt>penv</tt> is a pointer to the old environment, which we overwrite.
+(Notice that the variable <tt>penv</tt> does not even appear in the first code
+example.)
+So where is the environment saved and restored, if not here? The answer
+is that the burden is shifted to the caller; a caller to <tt>eval</tt> must
+expect that its environment might be overwritten, and take steps to save it
+if it will be needed further after the call. In practice, this means
+the environment is saved and restored around the evaluation of
+arguments, rather than around function applications. Hence <tt>(f x)</tt>
+might be a tail call to <tt>f</tt>, but <tt>(+ y (f x))</tt> is not.
+
+</body>
+</html>
binary files /dev/null b/femtolisp/site/software.gif differ
binary files /dev/null b/femtolisp/site/source.gif differ
binary files /dev/null b/femtolisp/site/text.gif differ
--- /dev/null
+++ b/femtolisp/system.lsp
@@ -1,0 +1,466 @@
+; femtoLisp standard library
+; by Jeff Bezanson
+; Public Domain
+
+(set 'list (lambda args args))
+
+(set-syntax 'setq (lambda (name val)
+ (list set (list 'quote name) val)))
+
+; 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)
+ (cond ((atom e) e)
+ ((eq (cdr e) ()) (car e))
+ (T (cons 'progn e)))))
+
+(set-syntax 'defmacro
+ (lambda (name args . body)
+ (list 'set-syntax (list 'quote name)
+ (list 'lambda args (f-body body)))))
+
+; support both CL defun and Scheme-style define
+(defmacro defun (name args . body)
+ (list 'setq name (list 'lambda args (f-body body))))
+
+(defmacro define (name . body)
+ (if (symbolp name)
+ (list 'setq name (car body))
+ (cons 'defun (cons (car name) (cons (cdr name) body)))))
+
+(defun identity (x) x)
+(setq null not)
+
+(defun map (f lst)
+ (if (atom lst) lst
+ (cons (f (car lst)) (map f (cdr lst)))))
+
+(defmacro 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)))
+
+(defun nconc lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (T ((lambda (l d) (if (null l) d
+ (prog1 l
+ (while (consp (cdr l)) (set 'l (cdr l)))
+ (rplacd l d))))
+ (car lsts) (apply nconc (cdr lsts))))))
+
+(defun append lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (T ((label append2 (lambda (l d)
+ (if (null l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (apply append (cdr lsts))))))
+
+(defun member (item lst)
+ (cond ((atom lst) ())
+ ((equal (car lst) item) lst)
+ (T (member item (cdr lst)))))
+
+(defun macrocallp (e) (and (symbolp (car e))
+ (symbol-syntax (car e))))
+
+(defun functionp (x)
+ (or (builtinp x)
+ (and (consp x) (eq (car x) 'lambda))))
+
+(defun macroexpand-1 (e)
+ (if (atom e) e
+ (let ((f (macrocallp e)))
+ (if f (apply f (cdr e))
+ e))))
+
+; convert to proper list, i.e. remove "dots", and append
+(defun 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)))
+
+(defun macroexpand (e)
+ ((label mexpand
+ (lambda (e env f)
+ (progn
+ (while (and (consp e)
+ (not (member (car e) env))
+ (set 'f (macrocallp e)))
+ (set 'e (apply f (cdr e))))
+ (if (and (consp e)
+ (not (eq (car e) 'quote)))
+ (let ((newenv
+ (if (and (eq (car e) 'lambda)
+ (consp (cdr e)))
+ (append.2 (cadr e) env)
+ env)))
+ (map (lambda (x) (mexpand x newenv nil)) e))
+ e))))
+ e nil nil))
+
+; 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 (list 'lambda args (macroexpand (f-body body)))))
+
+; 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)
+ (list 'lambda args (macroexpand (f-body body)))))
+
+(setq = equal)
+(setq eql equal)
+(define (/= a b) (not (equal a b)))
+(define != /=)
+(define (> a b) (< b a))
+(define (<= a b) (not (< b a)))
+(define (>= a b) (not (< a b)))
+(define (1+ n) (+ n 1))
+(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 (caar x) (car (car x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+
+(defun every (pred lst)
+ (or (atom lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(defun any (pred lst)
+ (and (consp lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(defun listp (a) (or (eq a ()) (consp a)))
+
+(defun nthcdr (n lst)
+ (if (<= n 0) lst
+ (nthcdr (- n 1) (cdr lst))))
+
+(defun list-ref (lst n)
+ (car (nthcdr n lst)))
+
+(defun list* l
+ (if (atom (cdr l))
+ (car l)
+ (cons (car l) (apply list* (cdr l)))))
+
+(defun nlist* l
+ (if (atom (cdr l))
+ (car l)
+ (rplacd l (apply nlist* (cdr l)))))
+
+(defun lastcdr (l)
+ (if (atom l) l
+ (lastcdr (cdr l))))
+
+(defun last (l)
+ (cond ((atom l) l)
+ ((atom (cdr l)) l)
+ (T (last (cdr l)))))
+
+(defun map! (f lst)
+ (prog1 lst
+ (while (consp lst)
+ (rplaca lst (f (car lst)))
+ (set 'lst (cdr lst)))))
+
+(defun mapcar (f . lsts)
+ ((label mapcar-
+ (lambda (lsts)
+ (cond ((null lsts) (f))
+ ((atom (car lsts)) (car lsts))
+ (T (cons (apply f (map car lsts))
+ (mapcar- (map cdr lsts)))))))
+ lsts))
+
+(defun transpose (M) (apply mapcar (cons list M)))
+
+(defun filter (pred lst)
+ (cond ((null lst) ())
+ ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
+ (T (filter pred (cdr lst)))))
+
+(define (foldr f zero lst)
+ (if (null lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (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 (copy-list l)
+ (if (atom l) l
+ (cons (car l)
+ (copy-list (cdr l)))))
+(define (copy-tree l)
+ (if (atom l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (nreverse l)
+ (let ((prev nil))
+ (while (consp l)
+ (set 'l (prog1 (cdr l)
+ (rplacd l (prog1 prev
+ (set 'prev l))))))
+ prev))
+
+(defmacro let* (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons 'progn
+ (nconc (map (lambda (b) (cons 'setq b)) binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro labels (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons 'progn
+ (nconc (map (lambda (b)
+ (list 'setq (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro when (c . body) (list 'if c (f-body body) nil))
+(defmacro unless (c . body) (list 'if c nil (f-body body)))
+
+(defmacro dotimes (var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ (list 'let (list (list v 0))
+ (list 'while (list < v cnt)
+ (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
+
+(defun 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))))
+
+(defun iota (n) (map-int identity n))
+
+(defun error args (raise (cons 'error args)))
+
+(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value)))
+(defmacro 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))))))
+
+(defmacro unwind-protect (expr finally)
+ (let ((e (gensym)))
+ `(prog1 (trycatch ,expr
+ (lambda (,e) (progn ,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)
+ (let* ((e (gensym))
+ (reraised (gensym))
+ (final (f-body (cdr (or (assoc 'finally forms) '(())))))
+ (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
+ (catchblock `(cond
+ ,.(map (lambda (catc)
+ (let* ((specific (cdr (cadr catc)))
+ (extype (caadr catc))
+ (var (if specific (car specific)
+ extype))
+ (todo (cddr catc)))
+ `(,(if specific
+ ; exception matching logic
+ `(or (eq ,e ',extype)
+ (and (consp ,e)
+ (eq (car ,e)
+ ',extype)))
+ T); (catch (e) ...), match anything
+ (let ((,var ,e)) (progn ,@todo)))))
+ catches)
+ (T (raise ,e))))) ; no matches, reraise
+ (if final
+ (if catches
+ ; form with both catch and finally
+ `(prog1 (trycatch ,expr
+ (lambda (,e)
+ (trycatch ,catchblock
+ (lambda (,reraised)
+ (progn ,final
+ (raise ,reraised))))))
+ ,final)
+ ; finally only; same as unwind-protect
+ `(prog1 (trycatch ,expr (lambda (,e)
+ (progn ,final (raise ,e))))
+ ,final))
+ ; catch, no finally
+ `(trycatch ,expr (lambda (,e) ,catchblock)))))
+
+; 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*
+ ; place mutator f
+ '((car rplaca identity)
+ (cdr rplacd identity)
+ (caar rplaca car)
+ (cadr rplaca cdr)
+ (cdar rplacd car)
+ (cddr rplacd cdr)
+ (caaar rplaca caar)
+ (caadr rplaca cadr)
+ (cadar rplaca cdar)
+ (caddr rplaca cddr)
+ (cdaar rplacd caar)
+ (cdadr rplacd cadr)
+ (cddar rplacd cdar)
+ (cdddr rplacd cddr)
+ (get put identity)
+ (aref aset identity)
+ (symbol-function set identity)
+ (symbol-value set identity)
+ (symbol-plist set-symbol-plist identity)
+ (symbol-syntax set-syntax identity)))
+
+(defun setf-place-mutator (place val)
+ (if (symbolp place)
+ (list 'setq place val)
+ (let ((mutator (assoc (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))))))
+
+(defmacro 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))
+
+(defun list-to-vector (l) (apply vector l))
+(defun vector-to-list (v)
+ (let ((i (- (length v) 1))
+ (l nil))
+ (while (>= i 0)
+ (setq l (cons (aref v i) l))
+ (setq i (- i 1)))
+ l))
+
+(defun self-evaluating-p (x)
+ (or (eq x nil)
+ (eq x T)
+ (and (atom x)
+ (not (symbolp x)))))
+
+; backquote
+(defmacro backquote (x) (bq-process x))
+
+(defun splice-form-p (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)
+ (if (vectorp x)
+ (let ((body (bq-process (vector-to-list x))))
+ (if (eq (car body) 'list)
+ (cons vector (cdr body))
+ (list apply vector body)))
+ x))
+ ((atom x) (list 'quote x))
+ ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
+ ((eq (car x) '*comma*) (cadr x))
+ ((not (any splice-form-p x))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null lc)
+ (cons 'list forms)
+ (nconc (cons 'nlist* forms) (list (bq-process lc))))))
+ (T (let ((p x) (q ()))
+ (while (and (consp p)
+ (not (eq (car p) '*comma*)))
+ (setq q (cons (bq-bracket (car p)) q))
+ (setq p (cdr p)))
+ (let ((forms
+ (cond ((consp p) (nreconc q (list (cadr p))))
+ ((null p) (nreverse q))
+ (T (nreconc q (list (bq-process p)))))))
+ (if (null (cdr forms))
+ (car forms)
+ (cons 'nconc forms)))))))
+
+(defun bq-bracket (x)
+ (cond ((atom x) (list cons (bq-process x) nil))
+ ((eq (car x) '*comma*) (list cons (cadr x) nil))
+ ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
+ ((eq (car x) '*comma-dot*) (cadr x))
+ (T (list cons (bq-process x) nil))))
+
+; bracket without splicing
+(defun bq-bracket1 (x)
+ (if (and (consp x) (eq (car x) '*comma*))
+ (cadr x)
+ (bq-process x)))
+
+(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr))))
+
+(defmacro time (expr)
+ (let ((t0 (gensym)))
+ `(let ((,t0 (time.now)))
+ (prog1
+ ,expr
+ (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
--- /dev/null
+++ b/femtolisp/tcolor.lsp
@@ -1,0 +1,11 @@
+; 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)))
+ (dotimes (n 99) (color-pairs Q '(a b c d e))))
+(time (ct))
+(print C)
--- /dev/null
+++ b/femtolisp/test.lsp
@@ -1,0 +1,194 @@
+; 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) (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))
+
+(define (append- . lsts)
+ ((label append-h
+ (lambda (lsts)
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (T ((label append2 (lambda (l d)
+ (if (null l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (append-h (cdr lsts)))))))
+ lsts))
+
+;(princ 'Hello '| | 'world! "\n")
+;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
+(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 80000) (list 1 2 3 4 5))
+;(setq a (map-int identity 10000))
+;(dotimes (i 200) (rfoldl cons nil a))
+
+; iterative filter
+(defun 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))
+
+(defun sort (l)
+ (if (or (null l) (null (cdr l))) l
+ (let ((piv (car l)))
+ (nconc (sort (filter (lambda (x) (<= x piv)) (cdr l)))
+ (list piv)
+ (sort (filter (lambda (x) (> x piv)) (cdr l)))))))
+
+;(setq r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
+;(sort r)
+
+(defmacro dotimes (var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(let ((,v 0))
+ (while (< ,v ,cnt)
+ (prog1
+ ,(f-body body)
+ (setq ,v (+ ,v 1)))))))
+
+(defmacro labl (name fn)
+ (list (list lambda (cons name nil) (list 'setq name fn)) nil))
+
+;(dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2)))
+
+(define (square x) (* x x))
+(define (evenp x) (= x (* (/ x 2) 2)))
+(define (expt b p)
+ (cond ((= p 0) 1)
+ ((= b 0) 0)
+ ((evenp p) (square (expt b (/ p 2))))
+ (T (* b (expt b (- p 1))))))
+
+(define (gcd a b)
+ (cond ((= a 0) b)
+ ((= b 0) a)
+ ((< a b) (gcd a (- b a)))
+ (T (gcd b (- a b)))))
+
+; like eval-when-compile
+(defmacro literal (expr)
+ (let ((v (eval expr)))
+ (if (self-evaluating-p v) v (list quote v))))
+
+(defun cardepth (l)
+ (if (atom l) 0
+ (+ 1 (cardepth (car l)))))
+
+(defun nestlist (f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(defun mapl (f . lsts)
+ ((label mapl-
+ (lambda (lsts)
+ (if (null (car lsts)) ()
+ (progn (apply f lsts) (mapl- (map cdr lsts))))))
+ lsts))
+
+; test to see if a symbol begins with :
+(defun keywordp (s)
+ (and (>= s '|:|) (<= s '|:~|)))
+
+; swap the cars and cdrs of every cons in a structure
+(defun swapad (c)
+ (if (atom c) c
+ (rplacd c (K (swapad (car c))
+ (rplaca c (swapad (cdr c)))))))
+
+(defun without (x l)
+ (filter (lambda (e) (not (eq e x))) l))
+
+(defun conscount (c)
+ (if (consp c) (+ 1
+ (conscount (car c))
+ (conscount (cdr c)))
+ 0))
+
+; _ Welcome to
+; (_ _ _ |_ _ | . _ _ 2
+; | (-||||_(_)|__|_)|_)
+; ==================|==
+
+;[` _ ,_ |- | . _ 2
+;| (/_||||_()|_|_\|)
+; |
+
+(defmacro while- (test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (progn ,@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
+; inside a catch block. one way to handle it would be to replace all
+; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
+; (try expr
+; (catch (TypeError e) . exprs)
+; (catch (IOError e) . exprs)
+; (finally . exprs))
+(defmacro try (expr . forms)
+ (let ((final (f-body (cdr (or (assoc '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
+ (lambda (catc next)
+ (let ((var (cadr (cadr catc)))
+ (extype (caadr catc))
+ (todo (f-body (cddr catc))))
+ `(lambda (,var)
+ (if (or (eq ,var ',extype)
+ (and (consp ,var)
+ (eq (car ,var) ',extype)))
+ ,todo
+ (,next ,var)))))
+
+ ; default function; no matches so re-raise
+ '(lambda (e) (progn (*_try_finally_thunk_*) (raise e)))
+
+ ; make list of catch forms
+ (filter (lambda (f) (eq (car f) 'catch)) forms))))
+ `(let ((*_try_finally_thunk_* (lambda () ,final)))
+ (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)
+ (f (lambda (x) ((h h) x))))
+ (lambda (h)
+ (f (lambda (x) ((h h) x)))))))
+
+(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)
--- /dev/null
+++ b/femtolisp/tiny/Makefile
@@ -1,0 +1,22 @@
+CC = gcc
+
+NAME = lisp
+SRC = $(NAME).c
+EXENAME = $(NAME)
+
+FLAGS = -Wall -Wextra
+LIBS =
+
+DEBUGFLAGS = -g -DDEBUG $(FLAGS)
+SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS)
+
+default: release
+
+debug: $(SRC)
+ $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
+
+release: $(SRC)
+ $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
+
+clean:
+ rm -f $(EXENAME)
--- /dev/null
+++ b/femtolisp/tiny/eval1
@@ -1,0 +1,390 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/femtolisp/tiny/eval2
@@ -1,0 +1,407 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/femtolisp/tiny/evalt
@@ -1,0 +1,443 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *pv = eval(*body, penv);
+ *penv = Stack[saveSP+1];
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/femtolisp/tiny/flutils.c
@@ -1,0 +1,119 @@
+u_int32_t *bitvector_resize(u_int32_t *b, size_t n)
+{+ u_int32_t *p;
+ size_t sz = ((n+31)>>5) * 4;
+ p = realloc(b, sz);
+ if (p == NULL) return NULL;
+ memset(p, 0, sz);
+ return p;
+}
+
+u_int32_t *mk_bitvector(size_t n)
+{+ return bitvector_resize(NULL, n);
+}
+
+void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c)
+{+ if (c)
+ b[n>>5] |= (1<<(n&31));
+ else
+ b[n>>5] &= ~(1<<(n&31));
+}
+
+u_int32_t bitvector_get(u_int32_t *b, u_int32_t n)
+{+ return b[n>>5] & (1<<(n&31));
+}
+
+typedef struct {+ size_t n, maxsize;
+ unsigned long *items;
+} ltable_t;
+
+void ltable_init(ltable_t *t, size_t n)
+{+ t->n = 0;
+ t->maxsize = n;
+ t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
+}
+
+void ltable_clear(ltable_t *t)
+{+ t->n = 0;
+}
+
+void ltable_insert(ltable_t *t, unsigned long item)
+{+ unsigned long *p;
+
+ if (t->n == t->maxsize) {+ p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
+ if (p == NULL) return;
+ t->items = p;
+ t->maxsize *= 2;
+ }
+ t->items[t->n++] = item;
+}
+
+#define NOTFOUND ((int)-1)
+
+int ltable_lookup(ltable_t *t, unsigned long item)
+{+ int i;
+ for(i=0; i < (int)t->n; i++)
+ if (t->items[i] == item)
+ return i;
+ return NOTFOUND;
+}
+
+void ltable_adjoin(ltable_t *t, unsigned long item)
+{+ if (ltable_lookup(t, item) == NOTFOUND)
+ ltable_insert(t, item);
+}
+
+static const u_int32_t offsetsFromUTF8[6] = {+ 0x00000000UL, 0x00003080UL, 0x000E2080UL,
+ 0x03C82080UL, 0xFA082080UL, 0x82082080UL
+};
+
+static const char trailingBytesForUTF8[256] = {+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
+};
+
+int u8_seqlen(const char c)
+{+ return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1;
+}
+
+#define UEOF ((u_int32_t)EOF)
+
+u_int32_t u8_fgetc(FILE *f)
+{+ int amt=0, sz, c;
+ u_int32_t ch=0;
+
+ c = fgetc(f);
+ if (c == EOF)
+ return UEOF;
+ ch = (u_int32_t)c;
+ amt = sz = u8_seqlen(ch);
+ while (--amt) {+ ch <<= 6;
+ c = fgetc(f);
+ if (c == EOF)
+ return UEOF;
+ ch += (u_int32_t)c;
+ }
+ ch -= offsetsFromUTF8[sz-1];
+
+ return ch;
+}
binary files /dev/null b/femtolisp/tiny/lisp differ
--- /dev/null
+++ b/femtolisp/tiny/lisp-nontail.c
@@ -1,0 +1,975 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons();
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return i;
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtol(buf, &end, 10);
+ if (*end != '\0')
+ lerror("read: error: invalid integer constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ read_token(f, c);
+ if (!strcmp(buf, ".")) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = eval(e, &NIL);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=eval(v, &NIL));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/femtolisp/tiny/lisp.c
@@ -1,0 +1,1029 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons();
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-' || c=='+') {+ read_token(f, c);
+ x = strtol(buf, &end, 0);
+ if (*end != '\0') {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
+#define tail_eval(xpr, env) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); *penv=(env); goto eval_top; } } while (0)+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body), penv);
+ *penv = Stack[saveSP+1];
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ u_int32_t saveSP = SP;
+ PUSH(NIL);
+ v = eval(expr, &Stack[SP-1]);
+ SP = saveSP;
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
binary files /dev/null b/femtolisp/tiny/lisp2 differ
--- /dev/null
+++ b/femtolisp/tiny/lisp2.c
@@ -1,0 +1,1434 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ This is a fork of femtoLisp with advanced reading and printing facilities:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and correctly printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+ The value of this extra complexity, and what makes this fork worthy of
+ the femtoLisp brand, is that the interpreter is fully "closed" in the
+ sense that all representable values can be read and printed.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
+ F_ASSOC, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn",
+ "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
+ "consp", "assoc" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 98304
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v, int princ);
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+value_t load_file(char *fname);
+value_t toplevel_eval(value_t expr);
+
+#include "flutils.c"
+
+typedef struct _readstate_t {+ ltable_t labels;
+ ltable_t exprs;
+ struct _readstate_t *prev;
+} readstate_t;
+static readstate_t *readstate = NULL;
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+
+ while (readstate) {+ free(readstate->labels.items);
+ free(readstate->exprs.items);
+ readstate = readstate->prev;
+ }
+
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got, 0); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 128*1024;//bytes
+static u_int32_t *consflags;
+static ltable_t printconses;
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = mk_bitvector(heapsize/sizeof(cons_t));
+
+ ltable_init(&printconses, 32);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ BACKQUOTE = symbol("backquote");+ COMMA = symbol("*comma*");+ COMMAAT = symbol("*comma-at*");+ COMMADOT = symbol("*comma-dot*");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+// allocate n consecutive conses
+static value_t cons_reserve(int n)
+{+ cons_t *first;
+
+ n--;
+ if ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(0);
+ while ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(1);
+ }
+ }
+ first = (cons_t*)curheap;
+ curheap += ((n+1)*sizeof(cons_t));
+ return tagptr(first, TAG_CONS);
+}
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if (!iscons(v))
+ return v;
+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == UNBOUND) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = d;
+
+ return first;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ void *temp;
+ u_int32_t i;
+ readstate_t *rs;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+ rs = readstate;
+ while (rs) {+ for(i=0; i < rs->exprs.n; i++)
+ rs->exprs.items[i] = relocate(rs->exprs.items[i]);
+ rs = rs->prev;
+ }
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew) {+ heapsize*=2;
+ }
+ else {+ temp = bitvector_resize(consflags, heapsize/sizeof(cons_t));
+ if (temp == NULL)
+ lerror("out of memory\n");+ consflags = (u_int32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
+};
+
+// defines which characters are ordinary symbol characters.
+// the only exception is '.', which is an ordinary symbol character
+// unless it is the only character in the symbol.
+static int symchar(char c)
+{+ static char *special = "()';`,\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ int ch;
+ char c;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c, int digits)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+ int ch;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '#') {+ ch = fgetc(f);
+ if (ch == EOF)
+ lerror("read: error: invalid read macro\n");+ if ((char)ch == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if ((char)ch == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if ((char)ch == '\\') {+ u_int32_t cval = u8_fgetc(f);
+ toktype = TOK_NUM;
+ tokval = number(cval);
+ }
+ else if (isdigit((char)ch)) {+ read_token(f, (char)ch, 1);
+ c = (char)fgetc(f);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror("read: error: invalid label\n");+ x = strtol(buf, &end, 10);
+ tokval = number(x);
+ }
+ else {+ lerror("read: error: unknown read macro\n");+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = fgetc(f);
+ if (ch == EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ungetc((char)ch, f);
+ }
+ else if (isdigit(c) || c=='-' || c=='+') {+ read_token(f, c, 0);
+ x = strtol(buf, &end, 0);
+ if (*end != '\0') {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c, 0)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+static value_t do_read_sexpr(FILE *f, int fixup);
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval, int fixup)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = c;
+ }
+ *pc = c;
+ c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(f,-1);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+// fixup is the index of the label we'd like to fix up with this read
+static value_t do_read_sexpr(FILE *f, int fixup)
+{+ value_t v, *head;
+ u_int32_t t, l;
+ int i;
+
+ t = peek(f);
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ v = cons_reserve(2);
+ car_(v) = *head;
+ cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
+ car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
+ PUSH(v);
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = v;
+ v = do_read_sexpr(f,-1);
+ car_(cdr_(Stack[SP-1])) = v;
+ return POP();
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(f, fixup);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], fixup);
+ return POP();
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ v = do_read_sexpr(f,-1);
+ return toplevel_eval(v);
+ case TOK_LABEL:
+ // create backreference label
+ l = numval(tokval);
+ if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
+ lerror("read: error: label %d redefined\n", l);+ ltable_insert(&readstate->labels, l);
+ i = readstate->exprs.n;
+ ltable_insert(&readstate->exprs, UNBOUND);
+ v = do_read_sexpr(f,i);
+ readstate->exprs.items[i] = v;
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ l = numval(tokval);
+ i = ltable_lookup(&readstate->labels, l);
+ if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
+ readstate->exprs.items[i] == UNBOUND)
+ lerror("read: error: undefined label %d\n", l);+ return readstate->exprs.items[i];
+ }
+ return NIL;
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+ readstate_t state;
+ state.prev = readstate;
+ ltable_init(&state.labels, 16);
+ ltable_init(&state.exprs, 16);
+ readstate = &state;
+
+ v = do_read_sexpr(f, -1);
+
+ readstate = state.prev;
+ free(state.labels.items);
+ free(state.exprs.items);
+ return v;
+}
+
+// print ----------------------------------------------------------------------
+
+static void print_traverse(value_t v)
+{+ while (iscons(v)) {+ if (ismarked(v)) {+ ltable_adjoin(&printconses, v);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+}
+
+static void print_symbol(FILE *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if (name[0] == '\0') {+ fprintf(f, "||");
+ return;
+ }
+ if (name[0] == '.' && name[1] == '\0') {+ fprintf(f, "|.|");
+ return;
+ }
+ if (name[0] == '#')
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ fprintf(f, "|");
+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ fprintf(f, "\\%c", name[i]);
+ else
+ fprintf(f, "%c", name[i]);
+ i++;
+ }
+ fprintf(f, "|");
+ }
+ else {+ fprintf(f, "|%s|", name);
+ }
+ }
+ else {+ fprintf(f, "%s", name);
+ }
+}
+
+static void do_print(FILE *f, value_t v, int princ)
+{+ value_t cd;
+ int label;
+ char *name;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM:
+ name = ((symbol_t*)ptr(v))->name;
+ if (princ)
+ fprintf(f, "%s", name);
+ else
+ print_symbol(f, name);
+ break;
+ case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {+ if (!ismarked(v)) {+ fprintf(f, "#%d#", label);
+ return;
+ }
+ fprintf(f, "#%d=", label);
+ }
+ fprintf(f, "(");+ while (1) {+ unmark_cons(v);
+ do_print(f, car_(v), princ);
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ else {+ if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ fprintf(f, ")");
+ break;
+ }
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+void print(FILE *f, value_t v, int princ)
+{+ ltable_clear(&printconses);
+ print_traverse(v);
+ do_print(f, v, princ);
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+// return a cons element of v whose car is item
+static value_t assoc(value_t item, value_t v)
+{+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return NIL;
+}
+
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define tail_eval(xpr) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); goto eval_top; } } while (0)+
+/* stack setup on entry:
+ n n+1 ...
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ | SYM | VAL | SYM | VAL | CLO | | | |
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ ^ ^ ^
+ | | |
+ penv envend SP (who knows where)
+
+ sym is an argument name and val is its binding. CLO is a closed-up
+ environment list (which can be empty, i.e. NIL).
+ CLO is always there, but there might be zero SYM/VAL pairs.
+
+ if tail==1, you are allowed (indeed encouraged) to overwrite this
+ environment, otherwise you have to put any new environment on the top
+ of the stack.
+*/
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+{+ value_t f, v, headsym, asym, *pv, *argsyms, *body, *lenv, *argenv;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ while (issymbol(*penv)) { // 1. try lookup in argument env+ if (*penv == NIL)
+ goto get_global;
+ if (*penv == e)
+ return penv[1];
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) // 2. closure env
+ return cdr_(v);
+ get_global:
+ if ((v = sym->binding) == UNBOUND) // 3. global env
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ v = car_(e);
+ if (tag(v)<0x2) f = v;
+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
+ else f = eval_sexpr(v, penv, 0, envend);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v)) lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ // build a closure (lambda args body . env)
+ if (issymbol(*penv) && *penv != NIL) {+ // cons up and save temporary environment
+ PUSH(Stack[envend-1]); // passed-in CLOENV
+ // find out how many new conses we need
+ nargs = ((int)(&Stack[envend] - penv - 1))>>1;
+ if (nargs) {+ lenv = penv;
+ Stack[SP-1] = cons_reserve(nargs*2);
+ c = (cons_t*)ptr(Stack[SP-1]);
+ while (1) {+ c->car = tagptr(c+1, TAG_CONS);
+ (c+1)->car = penv[0];
+ (c+1)->cdr = penv[1];
+ nargs--;
+ if (nargs==0) break;
+ penv+=2;
+ c->cdr = tagptr(c+2, TAG_CONS);
+ c += 2;
+ }
+ // final cdr points to existing cloenv
+ c->cdr = Stack[envend-1];
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ *lenv = Stack[SP-1];
+ }
+ }
+ else {+ PUSH(*penv); // env has already been captured; share
+ }
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ c = (cons_t*)ptr(v=cons_reserve(3));
+ c->car = (intval(f)==F_LAMBDA ? LAMBDA : MACRO);
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = Stack[SP-2]; //argsyms
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = Stack[SP-1]; //body
+ c->cdr = Stack[SP-3]; //env
+ break;
+ case F_LABEL:
+ // the syntax of label is (label name (lambda args body))
+ // nothing else is guaranteed to work
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ *body = eval(*body); // evaluate lambda
+ c = (cons_t*)ptr(cons_reserve(2));
+ c->car = Stack[SP-2]; // name
+ c->cdr = v = *body; c++;
+ c->car = tagptr(c-1, TAG_CONS);
+ f = cdr(cdr(v));
+ c->cdr = cdr(f);
+ // add (name . fn) to front of function's environment
+ cdr_(f) = tagptr(c, TAG_CONS);
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car);
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) != NIL) {+ SP = saveSP; return v;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond) != NIL) {+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body));
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ while (issymbol(*penv)) {+ if (*penv == NIL)
+ goto set_global;
+ if (*penv == e) {+ penv[1] = Stack[SP-1];
+ SP=saveSP; return penv[1];
+ }
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) {+ cdr_(v) = (e=Stack[SP-1]);
+ SP=saveSP; return e;
+ }
+ set_global:
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1) lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1) lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0) lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ // this implements generic comparison for all atoms
+ // strange comparisons (for example with builtins) are resolved
+ // arbitrarily but consistently.
+ // ordering: number < builtin < symbol < cons
+ if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {+ v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
+ }
+ else {+ switch (tag(Stack[SP-2])) {+ case TAG_NUM:
+ v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_SYM:
+ v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
+ ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
+ T : NIL;
+ break;
+ case TAG_BUILTIN:
+ v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_CONS:
+ lerror("<: error: expected atom\n");+ }
+ }
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ if (tag(v)<0x2) { SP=saveSP; return v; }+ if (tail) {+ *penv = NIL;
+ envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
+ e=v; goto eval_top;
+ }
+ else {+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ }
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1) lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_ASSOC:
+ argcount("assoc", nargs, 2);+ v = assoc(Stack[SP-2], Stack[SP-1]);
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ // apply lambda or macro expression
+ PUSH(cdr(cdr_(f)));
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ argenv = &Stack[SP]; // argument environment starts now
+ if (headsym == MACRO)
+ noeval = 1;
+ //else if (headsym != LAMBDA)
+ // lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (asym==NIL || iscons(asym))
+ lerror("apply: error: invalid formal argument\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v);
+ }
+ PUSH(asym);
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ PUSH(*argsyms);
+ if (noeval) {+ PUSH(Stack[saveSP]);
+ }
+ else {+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ PUSH(NIL);
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ PUSH(eval(car_(Stack[saveSP])));
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = cons_reserve(nargs);
+ c = (cons_t*)ptr(Stack[i-1]);
+ for(; i < (int)SP; i++) {+ c->car = Stack[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ (c-1)->cdr = NIL;
+ POPN(nargs);
+ }
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ lenv = &Stack[saveSP+1];
+ PUSH(cdr(*lenv)); // add cloenv to new environment
+ e = car_(Stack[saveSP+1]);
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ if (tag(e)<0x2) ;
+ else e = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ if (tag(e)<0x2) return(e);
+ goto eval_top;
+ }
+ else {+ if (tag(e)<0x2) { SP=saveSP; return(e); }+ if (tail) {+ // ok to overwrite environment
+ nargs = (int)(&Stack[SP] - argenv);
+ for(i=0; i < nargs; i++)
+ penv[i] = argenv[i];
+ envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ goto eval_top;
+ }
+ else {+ v = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ return v;
+ }
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ u_int32_t saveSP = SP;
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-1]);
+ SP = saveSP;
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("; _ \n");+ printf("; |_ _ _ |_ _ | . _ _ 2\n");+ printf("; | (-||||_(_)|__|_)|_)\n");+ printf(";-------------------|----------------------------------------------------------\n\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v), 0);
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/femtolisp/tiny/lisp2.c.bak
@@ -1,0 +1,1448 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ This is a fork of femtoLisp with advanced reading and printing facilities:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and correctly printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+ The value of this extra complexity, and what makes this fork worthy of
+ the femtoLisp brand, is that the interpreter is fully "closed" in the
+ sense that all representable values can be read and printed.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
+ F_ASSOC, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn",
+ "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
+ "consp", "assoc" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 98304
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v, int princ);
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+value_t load_file(char *fname);
+value_t toplevel_eval(value_t expr);
+
+#include "flutils.c"
+
+typedef struct _readstate_t {+ ltable_t labels;
+ ltable_t exprs;
+ struct _readstate_t *prev;
+} readstate_t;
+static readstate_t *readstate = NULL;
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+
+ while (readstate) {+ free(readstate->labels.items);
+ free(readstate->exprs.items);
+ readstate = readstate->prev;
+ }
+
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got, 0); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 128*1024;//bytes
+static u_int32_t *consflags;
+static ltable_t printconses;
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = mk_bitvector(heapsize/sizeof(cons_t));
+
+ ltable_init(&printconses, 32);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ BACKQUOTE = symbol("backquote");+ COMMA = symbol("*comma*");+ COMMAAT = symbol("*comma-at*");+ COMMADOT = symbol("*comma-dot*");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+// allocate and link n consecutive conses
+// warning: only cdrs are initialized
+static value_t cons_reserve(int n)
+{+ cons_t *c, *first;
+
+ n--;
+ if ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(0);
+ while ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(1);
+ }
+ }
+ c = first = (cons_t*)curheap;
+ for(; n > 0; n--) {+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ c->cdr = NIL;
+ curheap = (unsigned char*)(c+1);
+ return tagptr(first, TAG_CONS);
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if (!iscons(v))
+ return v;
+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == UNBOUND) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = d;
+
+ return first;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+ readstate_t *rs;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+ rs = readstate;
+ while (rs) {+ for(i=0; i < rs->exprs.n; i++)
+ rs->exprs.items[i] = relocate(rs->exprs.items[i]);
+ rs = rs->prev;
+ }
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew) {+ heapsize*=2;
+ }
+ else {+ temp = (char*)bitvector_resize(consflags, heapsize/sizeof(cons_t));
+ if (temp == NULL)
+ lerror("out of memory\n");+ consflags = (u_int32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
+};
+
+static int symchar(char c)
+{+ static char *special = "()';`,\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c, int digits)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+ int ch;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '#') {+ ch = fgetc(f);
+ if (ch == EOF)
+ lerror("read: error: invalid read macro\n");+ if ((char)ch == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if ((char)ch == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if (isdigit((char)ch)) {+ read_token(f, (char)ch, 1);
+ c = fgetc(f);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror("read: error: invalid label\n");+ x = strtol(buf, &end, 10);
+ tokval = number(x);
+ }
+ else {+ lerror("read: error: unknown read macro\n");+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = fgetc(f);
+ if (ch == EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ungetc((char)ch, f);
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c, 0);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtol(buf, &end, 10);
+ if (*end != '\0')
+ lerror("read: error: invalid integer constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c, 0)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+static value_t do_read_sexpr(FILE *f, int fixup);
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval, int fixup)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = c;
+ }
+ *pc = c;
+ c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(f,-1);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+// fixup is the index of the label we'd like to fix up with this read
+static value_t do_read_sexpr(FILE *f, int fixup)
+{+ value_t v, *head;
+ u_int32_t t, l;
+ int i;
+
+ t = peek(f);
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ cons(head, cons(&NIL, &NIL));
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = Stack[SP-1];
+ v = do_read_sexpr(f,-1);
+ car_(Stack[SP-2]) = v;
+ v = Stack[SP-1];
+ POPN(2);
+ return v;
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(f, fixup);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], fixup);
+ return POP();
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ v = do_read_sexpr(f,-1);
+ return toplevel_eval(v);
+ case TOK_LABEL:
+ // create backreference label
+ l = numval(tokval);
+ if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
+ lerror("read: error: label %d redefined\n", l);+ ltable_insert(&readstate->labels, l);
+ i = readstate->exprs.n;
+ ltable_insert(&readstate->exprs, UNBOUND);
+ v = do_read_sexpr(f,i);
+ readstate->exprs.items[i] = v;
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ l = numval(tokval);
+ i = ltable_lookup(&readstate->labels, l);
+ if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
+ readstate->exprs.items[i] == UNBOUND)
+ lerror("read: error: undefined label %d\n", l);+ return readstate->exprs.items[i];
+ }
+ return NIL;
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+ readstate_t state;
+ state.prev = readstate;
+ ltable_init(&state.labels, 16);
+ ltable_init(&state.exprs, 16);
+ readstate = &state;
+
+ v = do_read_sexpr(f, -1);
+
+ readstate = state.prev;
+ free(state.labels.items);
+ free(state.exprs.items);
+ return v;
+}
+
+// print ----------------------------------------------------------------------
+
+static void print_traverse(value_t v)
+{+ while (iscons(v)) {+ if (ismarked(v)) {+ ltable_adjoin(&printconses, v);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+}
+
+static void print_symbol(FILE *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if (name[0] == '\0') {+ fprintf(f, "||");
+ return;
+ }
+ if (name[0] == '.' && name[1] == '\0') {+ fprintf(f, "|.|");
+ return;
+ }
+ if (name[0] == '#')
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ fprintf(f, "|");
+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ fprintf(f, "\\%c", name[i]);
+ else
+ fprintf(f, "%c", name[i]);
+ i++;
+ }
+ fprintf(f, "|");
+ }
+ else {+ fprintf(f, "|%s|", name);
+ }
+ }
+ else {+ fprintf(f, "%s", name);
+ }
+}
+
+static void do_print(FILE *f, value_t v, int princ)
+{+ value_t cd;
+ int label;
+ char *name;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM:
+ name = ((symbol_t*)ptr(v))->name;
+ if (princ)
+ fprintf(f, "%s", name);
+ else
+ print_symbol(f, name);
+ break;
+ case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {+ if (!ismarked(v)) {+ fprintf(f, "#%d#", label);
+ return;
+ }
+ fprintf(f, "#%d=", label);
+ }
+ fprintf(f, "(");+ while (1) {+ unmark_cons(v);
+ do_print(f, car_(v), princ);
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ else {+ if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ fprintf(f, ")");
+ break;
+ }
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+void print(FILE *f, value_t v, int princ)
+{+ ltable_clear(&printconses);
+ print_traverse(v);
+ do_print(f, v, princ);
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+// return a cons element of v whose car is item
+static value_t assoc(value_t item, value_t v)
+{+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return NIL;
+}
+
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define tail_eval(xpr) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); goto eval_top; } } while (0)+
+/* stack setup on entry:
+ n n+1 ...
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ | SYM | VAL | SYM | VAL | CLO | | | |
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ ^ ^ ^
+ | | |
+ penv envend SP (who knows where)
+
+ sym is an argument name and val is its binding. CLO is a closed-up
+ environment list (which can be empty, i.e. NIL).
+ CLO is always there, but there might be zero SYM/VAL pairs.
+
+ if tail==1, you are allowed (indeed encouraged) to overwrite this
+ environment, otherwise you have to put any new environment on the top
+ of the stack.
+*/
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+{+ value_t f, v, headsym, asym, labl, *pv, *argsyms, *body, *lenv, *argenv;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ while (issymbol(*penv)) { // 1. try lookup in argument env+ if (*penv == NIL)
+ goto get_global;
+ if (*penv == e)
+ return penv[1];
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) // 2. closure env
+ return cdr_(v);
+ get_global:
+ if ((v = sym->binding) == UNBOUND) // 3. global env
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ v = car_(e);
+ if (tag(v)<0x2) f = v;
+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
+ else f = eval_sexpr(v, penv, 0, envend);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v)) lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ if (issymbol(*penv)) {+ // cons up and save temporary environment
+ PUSH(Stack[envend-1]); // passed-in CLOENV
+ // find out how many new conses we need
+ nargs = ((int)(&Stack[envend] - penv - 1))>>1;
+ if (nargs) {+ lenv = penv;
+ v = Stack[SP-1] = cons_reserve(nargs*2);
+ while (1) {+ e = cdr_(cdr_(v));
+ car_(v) = cdr_(v);
+ car_(cdr_(v)) = penv[0];
+ cdr_(cdr_(v)) = penv[1];
+ nargs--;
+ if (nargs==0) break;
+ penv+=2;
+ cdr_(v) = e;
+ v = e;
+ }
+ // final cdr points to existing cloenv
+ cdr_(v) = Stack[envend-1];
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ *lenv = Stack[SP-1];
+ }
+ }
+ else {+ PUSH(*penv); // env has already been captured; recapture
+ }
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ v = cons_reserve(3);
+ car_(v) = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); f = cdr_(v);
+ car_(f) = Stack[SP-2]; f = cdr_(f); //argsyms
+ car_(f) = Stack[SP-1]; //body
+ cdr_(f) = Stack[SP-3]; //env
+ }
+ else {+ v = Stack[saveSP];
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ *body = eval(*body); // evaluate lambda
+ v = f = cons_reserve(3);
+ car_(f) = LABEL; f = cdr_(f);
+ car_(f) = Stack[SP-2]; f = cdr_(f); // name
+ car_(f) = *body; // lambda expr
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car);
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) != NIL) {+ SP = saveSP; return v;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond) != NIL) {+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body));
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ while (issymbol(*penv)) {+ if (*penv == NIL)
+ goto set_global;
+ if (*penv == e) {+ penv[1] = Stack[SP-1];
+ SP=saveSP; return penv[1];
+ }
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) {+ cdr_(v) = (e=Stack[SP-1]);
+ SP=saveSP; return e;
+ }
+ set_global:
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1) lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1) lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0) lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ // this implements generic comparison for all atoms
+ // strange comparisons (for example with builtins) are resolved
+ // arbitrarily but consistently.
+ // ordering: number < builtin < symbol < cons
+ if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {+ v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
+ }
+ else {+ switch (tag(Stack[SP-2])) {+ case TAG_NUM:
+ v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_SYM:
+ v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
+ ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
+ T : NIL;
+ break;
+ case TAG_BUILTIN:
+ v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_CONS:
+ lerror("<: error: expected atom\n");+ }
+ }
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ if (tag(v)<0x2) { SP=saveSP; return v; }+ if (tail) {+ *penv = NIL;
+ envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
+ e=v; goto eval_top;
+ }
+ else {+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ }
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1) lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_ASSOC:
+ argcount("assoc", nargs, 2);+ v = assoc(Stack[SP-2], Stack[SP-1]);
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ } else labl=0;
+ // apply lambda or macro expression
+ PUSH(cdr(cdr_(f)));
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ argenv = &Stack[SP]; // argument environment starts now
+ if (labl) {+ // add label binding to environment
+ PUSH(car_(cdr_(labl)));
+ PUSH(labl);
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ //else if (headsym != LAMBDA)
+ // lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (asym==NIL || iscons(asym))
+ lerror("apply: error: invalid formal argument\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v);
+ }
+ PUSH(asym);
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ PUSH(*argsyms);
+ if (noeval) {+ PUSH(Stack[saveSP]);
+ }
+ else {+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ PUSH(NIL);
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ PUSH(eval(car_(Stack[saveSP])));
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = v = cons_reserve(nargs);
+ for(; i < (int)SP; i++) {+ car_(v) = Stack[i];
+ v = cdr_(v);
+ }
+ POPN(nargs);
+ }
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ lenv = &Stack[saveSP+1];
+ PUSH(cdr(*lenv)); // add cloenv to new environment
+ e = car_(Stack[saveSP+1]);
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ if (tag(e)<0x2) ;
+ else e = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ if (tag(e)<0x2) return(e);
+ goto eval_top;
+ }
+ else {+ if (tag(e)<0x2) { SP=saveSP; return(e); }+ if (tail) {+ // ok to overwrite environment
+ nargs = (int)(&Stack[SP] - argenv);
+ for(i=0; i < nargs; i++)
+ penv[i] = argenv[i];
+ envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ goto eval_top;
+ }
+ else {+ v = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ return v;
+ }
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-1]);
+ POP();
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("; _ \n");+ printf("; |_ _ _ |_ _ | . _ _ 2\n");+ printf("; | (-||||_(_)|__|_)|_)\n");+ printf(";-------------------|----------------------------------------------------------\n\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v), 0);
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
binary files /dev/null b/femtolisp/tiny/lispf differ
--- /dev/null
+++ b/femtolisp/tiny/lispf.c
@@ -1,0 +1,1043 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ lispf is a fork that provides an #ifdef FLOAT option to use single-precision
+ floating point numbers instead of integers, albeit with even less precision
+ than usual---only 21 significant mantissa bits!
+
+ it is now also being used to test a tail-recursive evaluator.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+#ifdef FLOAT
+typedef float number_t;
+#else
+typedef int32_t number_t;
+#endif
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#ifdef FLOAT
+#define number(x) ((*(value_t*)&(x))&~0x3)
+#define numval(x) (*(number_t*)&(x))
+#define NUM_FORMAT "%f"
+extern float strtof(const char *nptr, char **endptr);
+#define strtonum(s, e) strtof(s, e)
+#else
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define NUM_FORMAT "%d"
+#define strtonum(s, e) strtol(s, e, 10)
+#endif
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons(); car_(nc) = NIL;
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return i;
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtonum(buf, &end);
+ if (*end != '\0')
+ lerror("read: error: invalid constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ read_token(f, c);
+ if (!strcmp(buf, ".")) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, penv) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv))
+#define tail_eval(xpr, env) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); *penv=(env); goto eval_top; } } while (0)+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *pv = eval(*body, penv);
+ *penv = Stack[saveSP+1];
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ PUSH(NIL);
+ v = eval(expr, &Stack[SP-1]);
+ POP();
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/femtolisp/tiny/scrap.c
@@ -1,0 +1,107 @@
+// code to relocate cons chains iteratively
+ pcdr = &cdr_(nc);
+ while (iscons(d)) {+ if (car_(d) == FWD) {+ *pcdr = cdr_(d);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ a = car_(d); v = cdr_(d);
+ car_(d) = FWD; cdr_(d) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ d = v;
+ }
+ *pcdr = d;
+
+/*
+ f = *rest;
+ *rest = NIL;
+ while (iscons(f)) { // nreverse!+ v = cdr_(f);
+ cdr_(f) = *rest;
+ *rest = f;
+ f = v;
+ }*/
+
+int favailable(FILE *f)
+{+ fd_set set;
+ struct timeval tv = {0, 0};+ int fd = fileno(f);
+
+ FD_ZERO(&set);
+ FD_SET(fd, &set);
+ return (select(fd+1, &set, NULL, NULL, &tv)!=0);
+}
+
+static void print_env(value_t *penv)
+{+ printf("<[ ");+ while (issymbol(*penv) && *penv!=NIL) {+ print(stdout, *penv, 0);
+ printf(" ");+ penv++;
+ print(stdout, *penv, 0);
+ printf(" ");+ penv++;
+ }
+ printf("] ");+ print(stdout, *penv, 0);
+ printf(">\n");+}
+
+#else
+ PUSH(NIL);
+ PUSH(NIL);
+ value_t *rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ POP();
+#endif
+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ i = SP;
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if ((int)SP==i) {+ PUSH(NIL);
+ }
+ else {+ e = v = cons_reserve(nargs=(SP-i));
+ for(; i < (int)SP; i++) {+ car_(v) = Stack[i];
+ v = cdr_(v);
+ }
+ POPN(nargs);
+ PUSH(e);
+ }
+
+value_t list_to_vector(value_t l)
+{+ value_t v;
+ size_t n = llength(l), i=0;
+ v = alloc_vector(n, 0);
+ while (iscons(l)) {+ vector_elt(v,i) = car_(l);
+ i++;
+ l = cdr_(l);
+ }
+ return v;
+}
--- /dev/null
+++ b/femtolisp/tiny/system.lsp
@@ -1,0 +1,426 @@
+; femtoLisp standard library
+; by Jeff Bezanson
+; Public Domain
+
+(set 'list (lambda args args))
+
+(set 'setq (macro (name val)
+ (list set (list quote name) val)))
+
+(setq sp '| |)
+(setq nl '|
+|)
+
+; 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)
+ (cond ((atom e) e)
+ ((eq (cdr e) ()) (car e))
+ (t (cons progn e)))))
+
+(setq defmacro
+ (macro (name args . body)
+ (list 'setq name (list 'macro args (f-body body)))))
+
+; support both CL defun and Scheme-style define
+(defmacro defun (name args . body)
+ (list 'setq name (list 'lambda args (f-body body))))
+
+(defmacro define (name . body)
+ (if (symbolp name)
+ (list 'setq name (car body))
+ (cons 'defun (cons (car name) (cons (cdr name) body)))))
+
+(defun identity (x) x)
+(setq null not)
+(defun consp (x) (not (atom x)))
+
+(defun map (f lst)
+ (if (atom lst) lst
+ (cons (f (car lst)) (map f (cdr lst)))))
+
+(defmacro let (binds . body)
+ (cons (list 'lambda (map car binds) (f-body body))
+ (map cadr binds)))
+
+(defun nconc lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (t ((lambda (l d) (if (null l) d
+ (prog1 l
+ (while (consp (cdr l)) (set 'l (cdr l)))
+ (rplacd l d))))
+ (car lsts) (apply nconc (cdr lsts))))))
+
+(defun append lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (t ((label append2 (lambda (l d)
+ (if (null l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (apply append (cdr lsts))))))
+
+(defun member (item lst)
+ (cond ((atom lst) ())
+ ((eq (car lst) item) lst)
+ (t (member item (cdr lst)))))
+
+(defun macrop (e) (and (consp e) (eq (car e) 'macro) e))
+(defun macrocallp (e) (and (symbolp (car e))
+ (boundp (car e))
+ (macrop (eval (car e)))))
+(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args))
+
+(defun macroexpand-1 (e)
+ (if (atom e) e
+ (let ((f (macrocallp e)))
+ (if f (macroapply f (cdr e))
+ e))))
+
+; convert to proper list, i.e. remove "dots", and append
+(defun append.2 (l tail)
+ (cond ((null l) tail)
+ ((atom l) (cons l tail))
+ (t (cons (car l) (append.2 (cdr l) tail)))))
+
+(defun macroexpand (e)
+ ((label mexpand
+ (lambda (e env f)
+ (progn
+ (while (and (consp e)
+ (not (member (car e) env))
+ (set 'f (macrocallp e)))
+ (set 'e (macroapply f (cdr e))))
+ (if (and (consp e)
+ (not (or (eq (car e) 'quote)
+ (eq (car e) quote))))
+ (let ((newenv
+ (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro))
+ (consp (cdr e)))
+ (append.2 (cadr e) env)
+ env)))
+ (map (lambda (x) (mexpand x newenv nil)) e))
+ e))))
+ e nil nil))
+
+; 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 (list 'lambda args (macroexpand (f-body body)))))
+
+; same thing for macros. enabled by default because macros are usually
+; defined at the top level.
+(defmacro defmacro (name args . body)
+ (list 'setq name (list 'macro args (macroexpand (f-body body)))))
+
+(setq = eq)
+(setq eql eq)
+(define (/= a b) (not (eq a b)))
+(define != /=)
+(define (> a b) (< b a))
+(define (<= a b) (not (< b a)))
+(define (>= a b) (not (< a b)))
+(define (mod x y) (- x (* (/ x y) y)))
+(define (abs x) (if (< x 0) (- x) x))
+(define (truncate x) x)
+(setq K prog1) ; K combinator ;)
+(define (funcall f . args) (apply f args))
+(define (symbol-function sym) (eval sym))
+(define (symbol-value sym) (eval sym))
+
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+
+(define (equal a b)
+ (if (and (consp a) (consp b))
+ (and (equal (car a) (car b))
+ (equal (cdr a) (cdr b)))
+ (eq a b)))
+
+; compare imposes an ordering on all values. yields -1 for a<b,
+; 0 for a==b, and 1 for a>b. lists are compared up to the first
+; point of difference.
+(defun compare (a b)
+ (cond ((eq a b) 0)
+ ((or (atom a) (atom b)) (if (< a b) -1 1))
+ (t (let ((c (compare (car a) (car b))))
+ (if (not (eq c 0))
+ c
+ (compare (cdr a) (cdr b)))))))
+
+(defun every (pred lst)
+ (or (atom lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(defun any (pred lst)
+ (and (consp lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(defun listp (a) (or (eq a ()) (consp a)))
+
+(defun length (l)
+ (if (null l) 0
+ (+ 1 (length (cdr l)))))
+
+(defun nthcdr (n lst)
+ (if (<= n 0) lst
+ (nthcdr (- n 1) (cdr lst))))
+
+(defun list-ref (lst n)
+ (car (nthcdr n lst)))
+
+(defun list* l
+ (if (atom (cdr l))
+ (car l)
+ (cons (car l) (apply list* (cdr l)))))
+
+(defun nlist* l
+ (if (atom (cdr l))
+ (car l)
+ (rplacd l (apply nlist* (cdr l)))))
+
+(defun lastcdr (l)
+ (if (atom l) l
+ (lastcdr (cdr l))))
+
+(defun last (l)
+ (cond ((atom l) l)
+ ((atom (cdr l)) l)
+ (t (last (cdr l)))))
+
+(defun map! (f lst)
+ (prog1 lst
+ (while (consp lst)
+ (rplaca lst (f (car lst)))
+ (set 'lst (cdr lst)))))
+
+(defun mapcar (f . lsts)
+ ((label mapcar-
+ (lambda (lsts)
+ (cond ((null lsts) (f))
+ ((atom (car lsts)) (car lsts))
+ (t (cons (apply f (map car lsts))
+ (mapcar- (map cdr lsts)))))))
+ lsts))
+
+(defun transpose (M) (apply mapcar (cons list M)))
+
+(defun filter (pred lst)
+ (cond ((null lst) ())
+ ((not (pred (car lst))) (filter pred (cdr lst)))
+ (t (cons (car lst) (filter pred (cdr lst))))))
+
+(define (foldr f zero lst)
+ (if (null lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (if (null lst) zero
+ (foldl f (f (car lst) zero) (cdr lst))))
+
+(define (reverse lst) (foldl cons nil lst))
+
+(define (reduce0 f zero lst)
+ (if (null lst) zero
+ (reduce0 f (f zero (car lst)) (cdr lst))))
+
+(defun reduce (f lst)
+ (reduce0 f (car lst) (cdr lst)))
+
+(define (copy-list l) (map identity l))
+(define (copy-tree l)
+ (if (atom l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (assoc item lst)
+ (cond ((atom lst) ())
+ ((eq (caar lst) item) (car lst))
+ (t (assoc item (cdr lst)))))
+
+(define (nreverse l)
+ (let ((prev nil))
+ (while (consp l)
+ (set 'l (prog1 (cdr l)
+ (rplacd l (prog1 prev
+ (set 'prev l))))))
+ prev))
+
+(defmacro let* (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons progn
+ (nconc (map (lambda (b) (cons 'setq b)) binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro labels (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons progn
+ (nconc (map (lambda (b)
+ (list 'setq (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro when (c . body) (list if c (f-body body) nil))
+(defmacro unless (c . body) (list if c nil (f-body body)))
+
+(defmacro dotimes (var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ (list 'let (list (list v 0))
+ (list while (list < v cnt)
+ (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
+
+(defun map-int (f n)
+ (let ((acc nil))
+ (dotimes (i n)
+ (setq acc (cons (f i) acc)))
+ (nreverse acc)))
+
+; property lists
+(setq *plists* nil)
+
+(defun symbol-plist (sym)
+ (cdr (or (assoc sym *plists*) '(()))))
+
+(defun set-symbol-plist (sym lst)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (cons sym lst) *plists*))
+ (rplacd p lst))))
+
+(defun get (sym prop)
+ (let ((pl (symbol-plist sym)))
+ (if pl
+ (let ((pr (member prop pl)))
+ (if pr (cadr pr) nil))
+ nil)))
+
+(defun put (sym prop val)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (list sym prop val) *plists*))
+ (let ((pr (member prop p)))
+ (if (null pr) ; sym doesn't have this property yet
+ (rplacd p (cons prop (cons val (cdr p))))
+ (rplaca (cdr pr) val)))))
+ val)
+
+; 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*
+ ; place mutator f
+ '((car rplaca identity)
+ (cdr rplacd identity)
+ (caar rplaca car)
+ (cadr rplaca cdr)
+ (cdar rplacd car)
+ (cddr rplacd cdr)
+ (caaar rplaca caar)
+ (caadr rplaca cadr)
+ (cadar rplaca cdar)
+ (caddr rplaca cddr)
+ (cdaar rplacd caar)
+ (cdadr rplacd cadr)
+ (cddar rplacd cdar)
+ (cdddr rplacd cddr)
+ (get put identity)
+ (aref aset identity)
+ (symbol-function set identity)
+ (symbol-value set identity)
+ (symbol-plist set-symbol-plist identity)))
+
+(defun setf-place-mutator (place val)
+ (if (symbolp place)
+ (list 'setq place val)
+ (let ((mutator (assoc (car place) *setf-place-list*)))
+ (if (null mutator)
+ (error '|setf: error: 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
+ (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))
+
+(defun builtinp (x)
+ (and (atom x)
+ (not (symbolp x))
+ (not (numberp x))))
+
+(defun self-evaluating-p (x)
+ (or (eq x nil)
+ (eq x t)
+ (and (atom x)
+ (not (symbolp x)))))
+
+; backquote
+(defmacro backquote (x) (bq-process x))
+
+(defun splice-form-p (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) x)
+ ((atom x) (list quote x))
+ ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
+ ((eq (car x) '*comma*) (cadr x))
+ ((not (any splice-form-p x))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null lc)
+ (cons 'list forms)
+ (nconc (cons 'nlist* forms) (list (bq-process lc))))))
+ (t (let ((p x) (q '()))
+ (while (and (consp p)
+ (not (eq (car p) '*comma*)))
+ (setq q (cons (bq-bracket (car p)) q))
+ (setq p (cdr p)))
+ (cons 'nconc
+ (cond ((consp p) (nreconc q (list (cadr p))))
+ ((null p) (nreverse q))
+ (t (nreconc q (list (bq-process p))))))))))
+
+(defun bq-bracket (x)
+ (cond ((atom x) (list cons (bq-process x) nil))
+ ((eq (car x) '*comma*) (list cons (cadr x) nil))
+ ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
+ ((eq (car x) '*comma-dot*) (cadr x))
+ (t (list cons (bq-process x) nil))))
+
+; bracket without splicing
+(defun bq-bracket1 (x)
+ (if (and (consp x) (eq (car x) '*comma*))
+ (cadr x)
+ (bq-process x)))
--- /dev/null
+++ b/femtolisp/todo
@@ -1,0 +1,840 @@
+* setf
+* plists
+* backquote
+* symbol< (make < generic), generic compare function
+? (cdr nil) should be nil
+* multiple-argument mapcar
+? multi-argument apply. for builtins, just push them. for lambdas, must
+ cons together the evaluated arguments.
+? option *print-shared*. if nil, it still handles circular references
+ but does not specially print non-circular shared structure
+? option *print-circle*
+* read support for #' for compatibility
+* #\c read character as code (including UTF-8 support!)
+* #| |# block comments
+- here-data for binary serialization. proposed syntax:
+ #>size:data, e.g. #>6:000000
+* use syntax environment concept for user-defined macros to plug
+ that hole in the semantics
+* make more builtins generic. if typecheck fails, call out to the
+ generic version to try supporting more types.
+ compare/equal
+ +-*/< for all numeric types
+ length for all sequences
+ ? aref/aset for all sequences (vector, list, c-array)
+ ? copy
+* fixnump, all numeric types should pass numberp
+- make sure all uses of symbols don't assume symbols are unmovable without
+ checking ismanaged()
+* eliminate compiler warnings
+* fix printing nan and inf
+- move to "2.5-bit" type tags
+? builtin abs()
+- try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
+ is acceptable
+* (syntax-environment) to return it as an assoc list
+* (environment) for variables, constantp
+* prettier printing
+
+* readable gensyms and #:
+ . #:n reads similar to #n=#.(gensym) the first time, and #n# after
+* circular equal
+* integer/truncate function
+? car-circularp, cdr-circularp, circularp
+- hashtable. plan as equal-hash, over three stages:
+ 1. first support symbol and fixnum keys, use ptrhash. only values get
+ relocated on GC.
+ 2. create a version of ptrhash that uses equal() and hash(). if a key is
+ inserted requiring this, switch vtable pointer to use these functions.
+ both keys and values get relocated on GC.
+ 3. write hash() for pairs and vectors. now everything works.
+- expose eq-hashtable to user
+- other backquote optimizations:
+ * (nconc x) => x for any x
+ . (copy-list (list|append|nconc ...)) => (list|append|nconc ...)
+ * (apply vector (list ...)) => (vector ...)
+ . (nconc (cons x nil) y) => (cons x y)
+* let form without initializers (let (a b) ...), defaults to nil
+* print (quote a) as 'a, same for ` etc.
+
+- template keyword arguments. you write
+(template (:test eq) (:key caar)
+ (defun assoc (item lst)
+ (cond ((atom lst) ())
+ ((:test (:key lst) item) (car lst))
+ (t (assoc item (cdr lst))))))
+
+This writes assoc as a macro that produces a call to a pre-specialized
+version of the function. For example
+ (assoc x l :test equal)
+first tries to look up the variant '(equal caar) in the dictionary for assoc.
+If it doesn't exist it gets generated and stored. The result is a lambda
+expression.
+The macro returns ((lambda (item lst) <code for assoc>) x l).
+We might have to require different syntax for template invocations inside
+template definitions, such as
+ ((t-instance assoc eq :key) item lst)
+which passes along the same key but always uses eq.
+Alternatively, we could use the keysyms without colons to name the values
+of the template arguments, so the keysyms are always used as markers and
+never appear to have values:
+(template (:test eq) (:key caar)
+ (defun assoc? (item lst)
+ (cond ((atom lst) ())
+ ((test (key lst) item) ...
+ ...
+ (assoc x y :test test :key key)
+This would be even easier if the keyword syntax were something like
+ (: test eq)
+
+
+possible optimizations:
+* delay environment creation. represent environment on the stack as
+ alternating symbols/values, or if cons instead of symbol then traverse
+ as assoc list. only explicitly cons the whole thing when making a closure
+* cons_reserve(n) interface, guarantees n conses available without gc.
+ it could even link them together for you more efficiently
+* assoc builtin
+* special check for constant symbol when evaluating head since that's likely
+* remove the loop from cons_reserve. move all initialization to the loops
+ that follow calls to cons_reserve.
+- case of lambda expression in head (as produced by let), can just modify
+ env in-place in tail position
+* represent lambda environment as a vector (in lispv)
+x setq builtin (didn't help)
+(- list builtin, to use cons_reserve)
+(- let builtin, to further avoid env consing)
+unconventional interpreter builtins that can be used as a compilation
+target without moving away from s-expressions:
+- (*global* . a) ; special form, don't look in local env first
+- (*local* . 2) ; direct stackframe access
+for internal use:
+- a special version of apply that takes arguments on the stack, to avoid
+ consing when implementing "call-with" style primitives like trycatch,
+ hashtable-foreach, or the fl_apply API
+
+
+bugs:
+* with the fully recursive (simpler) relocate(), the size of cons chains
+ is limited by the process stack size. with the iterative version we can
+ have unlimited cdr-deep structures.
+* in #n='e, the case that makes the cons for 'e needs to use label fixup
+* symbol token |.| does not work
+* ltable realloc not multiplying by sizeof(unsigned long)
+* not relocating final cdr in iterative version if it is a vector
+- (setf (car x) y) doesn't return y
+* reader needs to check errno in isnumtok
+* prettyprint size measuring is not utf-8 correct
+
+
+femtoLisp3...with symbolic C interface
+
+c values are builtins with value > N_BUILTINS
+((u_int32_t*)cvalue)[0] & 0x3 must always be 2 to distinguish from vectors
+
+typedef struct _cvtable_t {+ void (*relocate)(struct _cvalue_t *);
+ void (*free)(struct _cvalue_t *);
+ void (*print)(struct _cvalue_t *, FILE *);
+} cvtable_t;
+
+; remember: variable-length data preferred over variable-length arglists
+
+c type representations:
+symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short,
+[u]int, [u]long, lispvalue
+(c-function ret-type (argtype ...))
+(array type N)
+(struct ((name type) (name type) ...))
+(union ((name type) (name type) ...))
+(enum (name1 name2 ...))
+(pointer type)
+
+constructors:
+([u]int[8,16] n)
+([u]int32 hi lo)
+([u]int64 b3 b2 b1 b0)
+(float hi lo) or (float "3.14")
+(double b3 b2 b1 b0) or (double "3.14")
+(array ctype (val ...))
+(struct ((name type) ...) (val ...))
+(pointer cvalue) ; constructs pointer to the given value
+(pointer ctype ptr) ; copies/casts a pointer to a different type
+so (pointer 'int8 #int32(0)) doesn't make sense, but
+ (pointer 'int8 (pointer #int32(0))) does.
+(c-function ret-type (argtype ...) ld-symbol-name)
+
+? struct/enum tag:
+ (struct 'tag <initializer>) or (pointer (struct tag))
+ where tag is a global var with a value ((name type) ...)
+
+
+representing c data from lisp is the tricky part to make really elegant and
+efficient. the most elegant but too inefficient option is not to have opaque
+C values at all and always marshal to/from native lisp values like #int16[10].
+the next option is to have opaque values "sometimes", for example returning
+them from C functions but printing them using their lisp representations.
+the next option is to relax the idea that C values of a certain type have a
+specific lisp structure, and use a coercion system that "tries" to translate
+a lisp value to a specified C type. for example [0 1 2], (0 1 2),
+#string[0 1 2], etc. might all be accepted by a C function taking int8_t*.
+you could say (c-coerce <lispvalue> <typedesc>) and get a cvalue back or
+an error if the conversion fails.
+
+the final option is to have cvalues be the only officially-sanctioned
+representation of c data, and make them via constructors, like
+(int32 hi lo) returns an int32 cvalue
+(struct '((name type) (name type) ...) a b ...) makes a struct
+there is a constructor function for each primitive C type.
+you can print these by brute force as e.g. #.(int32 hi lo)
+then all checking just looks like functions checking their arguments
+
+this option seems almost ideal. what's wrong with it?
+. to construct cvalues from lisp you have to build code instead of data
+. it seems like it should take more explicit advantage of tagged vectors
+. should you accept multiple forms? for example
+ (array 'int8 0 1 2) or (array 'int8 [0 1 2])
+ if you're going to be that permissive, why not allow [0 1 2] to be passed
+ directly to a function that expects int8_t* and do the conversion
+ implicitly?
+ . even if these c-primitive-constructor functions exist, you can still
+ write things like c-coerce (in lisp, even) and hack in implicit
+ conversion attempts when something other than a cvalue is passed.
+. the printing code is annoying, because it's not enough to print readably,
+ you have to print evaluably.
+ . solution: constructor notation, #int32(hi lo)
+
+in any case, "opaque" cvalues will not really be opaque because we want to
+know their types and be able to take them apart on the byte level from lisp.
+C code can get references to lisp values and manipulate them using lisp
+operations like car, so to be fair it should work vice-versa; give
+c references to lisp code and let it use c operations like * on them.
+you can write lisp in c and c in lisp, though of course you don't usually
+want to. however, c written in lisp can be generated by a macro, printed,
+and fed to TCC for compilation.
+
+
+for a struct the names and types are parameters of the type, not the
+constructor, so it seems more correct to do
+
+((struct (name type) (name type) ...) (val val ...))
+
+where struct returns a constructor. but this isn't practical because it
+can't be printed in constructor notation and the type is a lambda rather
+than a more sensible expression.
+
+
+notice constructor calls and type representations are "similar". they
+should be related formally:
+
+(define (new type)
+ (if (symbolp type) (apply (eval type) ())
+ (apply (eval (car type)) (cdr type))))
+
+for aggregate types, you can keep a variable referring to the relevant
+piece:
+
+(setq point '((x int) (y int)))
+(struct point [2 3]) ; looks like c declaration 'struct point x;'
+
+a type is a function, so something similar to typedef is achieved by:
+
+(define (point_t vals) (struct point vals))
+
+design points:
+. type constructors will all be able to take 1 or 0 arguments, so i could say
+ (new (typeof val)) ; construct similar
+ (define (new type)
+ (if (symbolp type) (apply (eval type) ())
+ (apply (eval (car type)) (cdr type))))
+. values can be marked as autorelease (1) if user says so, (2) if we can
+ prove that it's ok (e.g. we only allocated the value using malloc because
+ it is too large to move on every GC).
+ in the future you should be able to specify an arbitrary finalization
+ function, not just free().
+. when calling a C function, a value of type_t can be passed to something
+ expecting a type_t* by taking the address of the representation. BUT
+ this is dangerous if the C function might save a reference.
+ a type_t* can be passed as a type_t by copying the representation.
+. you can use (pointer v) to switch v to "malloc'd representation", in
+ which case the value is no longer autoreleased, but you can do whatever
+ you want with the pointer. (other option is to COPY v when making a
+ pointer to it, but this still doesn't prevent C from holding a reference
+ too long)
+
+
+add a cfunction binding to symbols. you register in C simply by setting
+this binding to a function pointer, then
+
+(defun open (path flags)
+ ; could insert type checks here
+ (ccall 'int32 'open path flags))
+
+(setq fd (open "path" 0))
+
+using libdl you could even omit the registration step and extra binding
+
+this is possible:
+(defun malloc (size)
+ (ccall `(array int8 ,size) 'malloc size))
+ ;ret type ;f name ; . args
+
+
+vtable:
+we'd like to be able to define new lisp "types", like vectors
+and hash tables, using this. there needs to be a standard value interface
+you can implement in C and attach a vtable to some c values.
+interface: relocate, finalize, print(, copy)
+
+implementation plan:
+- write cvalue constructors
+- if a head evaluates to a cvalue, call the pointer directly with the arg array
+ . this is the "guest function" interface, a C function written specifically
+ to the femtolisp API. its type must be
+ '(c-function lispvalue ((pointer lispvalue) uint32))
+ which corresponds to
+ value_t func(value_t *args, u_int32_t nargs);
+ . this interface is useful for writing additional builtins, types,
+ interpreter extensions, etc. more efficient.
+ . one of these functions could also be called with
+ (defun func args
+ (ccall 'func 'lispvalue (array 'lispvalue args) (length args)))
+ - these functions are effectively builtins and should have names so they
+ can be printed as such.
+ . have a registration function
+ void guest_function(value_t (*f)(value_t*,u_int32_t), const char *name);
+ so at least the function type can be checked from C
+ . set a flags bit for functions registered this way so we can identify
+ them quickly
+
+- ccall lisp builtin, (ccall rettype name . args). if name has no cfunc
+ binding, looks it up lazily with dlsym and stores the result.
+ this is a guest function that handles type checking, translation, and
+ invocation of foreign c functions.
+
+- you could register builtins from lisp like this:
+ (defun dlopen (name flags) (ccall '(pointer void) 'dlopen name flags))
+ (defun dlsym (handle name type) (ccall type 'dlsym handle name))
+ (define lisp-process (dlopen nil 0))
+ (define vector-sym
+ (dlsym lisp-process 'int_vector
+ '(function lispvalue (pointer lispvalue) uint32)))
+ (ccall 'void 'guest_function vector-sym 'vector)
+
+- write c extensions cref, cset, typeof, sizeof, cvaluep
+* read, print, vectorp methods for vectors
+- quoted string "" reading, produces #(c c c c ...)
+* get rid of primitive builtins read,print,princ,load,exit,
+ implement using ccall
+
+
+other possible design:
+- just add two builtins, call and ccall.
+ (call 'name arg arg arg) lisp guest function interface
+ we can say e.g.
+ (defmacro vector args `(call 'vector ,.args))
+- basically the question is whether to introduce a new kind of callable
+ object or to do everything through the existing builtin mechanism
+ . macros cannot be applied, so without a new kind of callable 'vector'
+ would have to be a lisp function, entailing argument consing...
+ (defun builtin (name)
+ (guest-function name
+ (dlsym lisp-process name '(function value (pointer value) uint32))))
+ then you can print a guest function as e.g.
+ #.(builtin 'vector)
+
+#name(x y z) reads as a tagged vector
+#(x y z) is the same as #vector(x y z)
+should be internally the same as well, so non-taggedness does not formally
+exist.
+
+
+then we can write the vector clause in backquote as e.g.
+
+(if (vectorp x)
+ (let ((body (bq-process (vector-to-list x))))
+ (if (eq (tag x) 'vector)
+ (list 'list-to-vector body)
+ (list 'apply 'tagged-vector
+ (list cons (list quote (tag x)) body))))
+ (list quote x))
+
+
+setup plan:
+- create source directory and svn repository, move llt sources into it
+* write femtolisp.h, definitions for extensions to #include
+- add fl_ prefix to all exported functions
+- port read and print to jclib's iostreams
+* get rid of flutils; use ptrhash instead
+* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues
+* allocation and gc for cvalues
+- interface functions fl_list(...), fl_apply
+ e.g. fl_apply(fl_eval(fl_symbol("+")), fl_list(fl_number(2),fl_number(3)))+ and fl_symval("+"), fl_cons, etc.+
+-----------------------------------------------------------------------------
+
+vector todo:
+* compare for vectors
+- (aref v i j k) does (reduce aref v '(i j k)); therefore (aref v) => v
+- (aref v ... [1 2 3] ...) vectorized indexing
+- make (setf (aref v i j k) x) expand to (aset (aref v i j) k x)
+these should be done using the ccall interface:
+- concatenate
+- copy-vec
+- (range i j step) to make integer ranges
+- (rref v start stop), plus make it settable! (rset v start stop rhs)
+lower priority:
+- find (strstr)
+
+functions to be generic over vec/list:
+* compare, equal, length
+
+constructor notation:
+
+#func(a b c) does (apply func '(a b c))
+
+-----------------------------------------------------------------------------
+
+how we will allocate cvalues
+
+a vector's size will be a lisp-value number. we will set bit 0x2 to indicate
+a resize request, and bit 0x1 to indicate that it's actually a cvalue.
+
+every cvalue will have the following fields, followed by some number of
+words according to how much space is needed:
+
+ value_t size; // | 0x2
+ cvtable_t *vtable;
+ struct {+#ifdef BITS64
+ unsigned pad:32;
+#endif
+ unsigned whatever:27;
+ unsigned mark:1;
+ unsigned hasparent:1;
+ unsigned islispfunction:1;
+ unsigned autorelease:1;
+ unsigned inlined:1;
+ } flags;
+ value_t type;
+ size_t len; // length of *data in bytes
+ //void *data; // present if !inlined
+ //value_t parent; // present if hasparent
+
+size/vtable have the same meaning as vector size/elt[0] for relocation
+obviously we only relocate parent and type. if vtable->relocate is present,
+we call it at the end of the relocate process, and it must touch every
+lisp value reachable from it.
+
+when a cvalue is created with a finalizer, its address is added to a special
+list. before GC, everything in that list has its mark bit set. when
+we relocate a cvalue, clear the bit. then go through the list to call
+finalizers on dead values. this is O(n+m) where n is amt of live data and m
+is # of values needing finalization. we expect m << heapsize.
+
+-----------------------------------------------------------------------------
+
+Goal: bootstrap a lisp system where we can do "anything" purely in lisp
+starting with the minimal builtins needed for successive levels of
+completeness:
+
+1. Turing completeness
+quote, if, lambda, eq, atom, cons, car, cdr
+
+2. Naming
+set
+
+3. Control flow
+progn, prog1, apply, eval
+call/cc needed for true completeness, but we'll have attempt, raise
+
+4. Predicate completeness
+symbolp, numberp, builtinp
+
+5. Syntax
+macro
+
+6. I/O completeness
+read, print
+
+7. Mutable state
+rplaca, rplacd
+
+8. Arithmetic completeness
++, -, *, /, <
+
+9. The missing data structure(s): vector
+alloc, aref, aset, vectorp, length
+
+10. Real-world completeness (escape hatch)
+ccall
+
+---
+11. Misc unnecessary
+while, label, cond, and, or, not, boundp, vector
+
+-----------------------------------------------------------------------------
+
+exception todo:
+
+* silence 'in file' errors when user frame active
+* add more useful data to builtin exception types:
+ (UnboundError x)
+ (BoundsError vec index)
+ (TypeError fname expected got)
+ (Error v1 v2 v3 ...)
+* attempt/raise, rewrite (error) in lisp
+* more intelligent exception printers in toplevel handler
+
+-----------------------------------------------------------------------------
+
+lisp variant ideas
+
+- get rid of separate predicates and give every value the same structure
+ ala mathematica
+ . (tag 'a) => symbol
+ (tag '(a b)) => a
+ (tag 'symbol 'a) => a
+ (tag 'blah 3) => (blah 3)
+- have only vectors, not cons cells (sort of like julia)
+ . could have a separate tag field as above
+
+- easiest way to add vectors:
+ . allocate in same heap with conses, have a tag, size, then elements
+ (each elt must be touched on GC for relocation anyway, so might as well
+ copy collect it)
+ . tag pointers as builtins, we identify them as builtins with big values
+ . write (vector) in C, use it from read and eval
+
+8889314663 comcast net #
+
+-----------------------------------------------------------------------------
+
+cvalues reserves the following global symbols:
+
+int8, uint8, int16, uint16, int32, uint32, int64, uint64
+char, uchar, short, ushort, int, uint, long, ulong
+float, double
+struct, array, enum, union, function, void, pointer, lispvalue
+
+it defines (but doesn't reserve) the following:
+
+typeof, sizeof, autorelease, guestfunction, ccall
+
+
+user-defined types and typedefs:
+
+the rule is that a type should be viewed as a self-evaluating constant
+like a number. if i define a complex_t type of two doubles, then
+'complex_t is not a type any more than the symbol 'x could be added to
+something just because it happened to have the value 2.
+
+; typedefs from lisp
+(define wchar_t 'uint32)
+(define complex_t '(struct ((re double) (im double))))
+
+; use them
+(new complex_t)
+(new `(array ,complex_t 10))
+(array complex_t 10)
+
+BUT
+
+(array 'int32 10)
+
+because the primitive types *are* symbols. the fact that they have values is
+just a convenient coincidence that lets you do e.g. (int32 0)
+
+
+; size-annotate a pointer
+(setq p (ccall #c-function((pointer void) (ulong) malloc) n)
+(setq a (deref p `(array int8 ,n)))
+
+cvalues todo:
+
+- use uint32_t instead of wchar_t in C code
+- make sure empty arrays and 0-byte types really work
+* allow int constructors to accept other int cvalues
+* array constructor should accept any cvalue of the right size
+* make sure cvalues participate well in circular printing
+- lispvalue type
+ . keep track of whether a cvalue leads to any lispvalues, so they can
+ be automatically relocated (?)
+* float, double
+- struct, union
+- pointer type, function type
+- finalizers and lifetime dependency tracking
+- functions autorelease, guestfunction
+- cref/cset/byteref/byteset
+* wchar type, wide character strings as (array wchar)
+* printing and reading strings
+- ccall
+- anonymous unions
+* fix princ for cvalues
+
+- string constructor/concatenator:
+(string 'sym #char(65) #wchar(945) "blah" 23)
+ ; gives "symA\u03B1blah23"
+"ccc" reads to (array char)
+
+low-level functions:
+; these are type/bounds-checked accesses
+- (cref|ccopy cvalue key) ; key is field name or index
+- (cset cvalue key cvalue) ; key is field name, index, or struct offset
+- (get-[u]int[8,16,32,64] cvalue addr)
+ ; n is a lisp number or cvalue of size <= 8
+- (set-[u]int[8,16,32,64] cvalue addr n)
+- (c-struct-offset type field)
+- (c2lisp cvalue) ; convert to sexpr form
+- (autorelease cvalue) ; mark cvalue as free-on-gc
+* (typeof cvalue)
+* (sizeof cvalue|type)
+- (deref pointer[, type]) ; convert an unknown pointer to a safe cvalue
+- (ccopy cv)
+
+; (sizeof '(pointer type)) == sizeof(void*)
+; (sizeof '(array type N)) == N * sizeof(type)
+
+
+things you can do with cvalues:
+
+. call native C functions from lisp code without wrappers
+. wrap C functions in pure lisp, automatically inheriting some degree
+ of type safety
+. use lisp functions as callbacks from C code
+. use the lisp garbage collector to reclaim malloc'd storage
+. annotate C pointers with size information for bounds checking
+. attach symbolic type information to a C data structure, allowing it to
+ inherit lisp services such as printing a readable representation
+. add datatypes like strings to lisp
+. use more efficient represenations for your lisp programs' data
+
+
+family of cvalue representations.
+relevant attributes:
+ . large -- needs full size_t to represent size
+ . inline -- allocated along with metadata
+ . prim -- no stored type; uses primtype bits in flags
+ . hasdeps -- depends on other values to stay alive
+
+these attributes have the following dependencies:
+ . large -> !inline
+ . prim -> !hasdeps && !large
+
+so we have the following possibilities:
+
+large inline prim hasdeps rep#
+ 0 0 0 0 0
+ 0 0 0 1 1
+
+ 0 0 1 0 2
+ 0 1 0 0 3
+ 0 1 0 1 4
+ 0 1 1 0 5
+
+ 1 0 0 0 6
+ 1 0 0 1 7
+
+we need to be able to un-inline data, so we need:
+change 3 -> 0 (easy; write pointer over data)
+change 4 -> 1
+change 5 -> 2 (also easy)
+
+
+rep#0&1: (!large && !inline && !prim)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ void *data; /* points to malloc'd buffer */
+} cvalue_t;
+
+rep#3&4: (!large && inline && !prim)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ /* data goes here inlined */
+} cvalue_t;
+
+
+rep#2: (prim && !inline)
+typedef struct {+ cvflags_t flags;
+ void *data; /* points to (tiny!) malloc'd buffer */
+} cvalue_t;
+
+rep#5: (prim && inline)
+typedef struct {+ cvflags_t flags;
+ /* data goes here inlined */
+} cvalue_t;
+
+
+rep#6&7: (large)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ void *data; /* points to malloc'd buffer */
+ size_t len;
+} cvalue_t;
+
+-----------------------------------------------------------------------------
+
+times for lispv:
+
+color 2.286s
+sort 0.181s
+fib34 5.205s
+mexpa 0.329s
+
+-----------------------------------------------------------------------------
+
+finalization algorithm that allows finalizers written in lisp:
+
+right after GC, go through finalization list (a weak list) and find objects
+that didn't move. relocate them (bring them back to life) and push them
+all onto the stack. remove all from finalization list.
+
+call finalizer for each value.
+
+optional: after calling a finalizer, make sure the object didn't get put
+back on the finalization list, remove if it did.
+if you don't do this, you can make an unkillable object by registering a
+finalizer that re-registers itself. this could be considered a feature though.
+
+pop dead values off stack.
+
+
+-----------------------------------------------------------------------------
+
+femtolisp semantics
+
+eval* is an internal procedure of 2 arguments, expr and env, invoked
+implicitly on input.
+The user-visible procedure eval performs eval* e Env ()
+
+eval* Symbol s E => lookup* s E
+eval* Atom a E => a
+... special forms ... quote arg, if a b c, other symbols from syntax env.
+eval* Cons f args E =>
+
+First the head expression, f, is evaluated, yielding f-.
+Then control is passed to #.apply f- args
+ #.apply is the user-visible apply procedure.
+ (here we imagine there is a user-invisible environment where f- is
+ bound to the value of the car and args is bound to the cdr of the input)
+
+
+Now (apply b lst) where b is a procedure (i.e. satisfies functionp) is
+identical to
+(eval (map (lambda (e) `',e) (cons b lst)))
+
+-----------------------------------------------------------------------------
+
+design of new toplevel
+
+system.lsp is compiled into the executable, and contains definitions of
+(load) and (repl).
+
+start with load bound to bootstrap_load (in C)
+on startup we call load on system, then call it again afterwards
+
+(load) reads and evaluates every form, keeping track of defined functions
+and macros (at the top level), and grabs a (main ...) form if it sees
+one. it applies optimizations to every definition, then invokes main.
+
+an error E during load should rethrow `(load-error ,filename ,E)
+such exceptions can be printed recursively
+
+lerror() should make a lisp string S from the result of sprintf, then
+raise `(,e ,S). first argument e should be a symbol.
+
+-----------------------------------------------------------------------------
+
+String API
+
+*string - append/construct
+ string.inc - (string.inc s i [nchars])
+ string.dec
+ string.char - char at byte offset
+ string.count - # of chars between 2 byte offsets
+*string.sub - substring between 2 byte offsets, or nil for beginning/end
+*string.split - (string.split s sep-chars)
+ string.trim - (string.trim s chars-at-start chars-at-end)
+*string.reverse
+ string.find - (string.find s str|char), or nil if not found
+ string.map - (string.map f s)
+*string.encode - to utf8
+*string.decode - from utf8 to UCS
+ string.width - # columns
+
+
+IOStream API
+
+ read
+ print, sprint
+ princ, sprinc
+ stream - (stream cvalue-as-bytestream)
+ file
+ fifo
+ socket
+ stream.eof
+ stream.write - (stream.write cvalue)
+ stream.read - (stream.read ctype)
+ stream.copy - (stream.copy to from [nbytes])
+ stream.copyuntil - (stream.copy to from byte)
+ stream.flush
+ stream.pos
+ stream.seek
+ stream.trunc
+ stream.getc - get utf8 character(s)
+
+
+ path.combine
+ path.parts
+ path.absolute
+ path.simplify
+ path.tempdir
+ path.tempname
+ path.homedir
+*path.cwd
+
+
+*time.now
+ time.parts
+ time.fromparts
+*time.string
+ time.fromstring
+
+
+*os.name
+*os.getenv
+*os.setenv
+ os.execv
+
+
+*rand
+*rand.uint32
+*rand.uint64
+*rand.double
+
+-----------------------------------------------------------------------------
+
+prettyprint notes
+
+* if head of list causes VPOS to increase and HPOS is a bit large, then
+switch to miser mode, otherwise default is ok, for example:
+
+> '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+((lambda (x y)
+ (if (< x y) x y)) (a b c)
+ (d e f) 2 3
+ (r t y))
+
+* (if a b c) should always put newlines before b and c
+
+* write try_predict_len that gives a length for easy cases like
+ symbols, else -1. use it to avoid wrapping symbols around lines
--- /dev/null
+++ b/femtolisp/todo-scrap
@@ -1,0 +1,41 @@
+- readable gensyms. have uninterned symbols, but have all same-named
+ gensyms read to the same (eq) symbol within an expression.
+- fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit
+ integers too. the mind boggles at the possibilities.
+ (it would be great if everybody decided that pointer types should forever
+ be wider than address spaces, with some bits reserved for application use)
+- any way at all to provide O(1) computed lookups (i.e. indexing).
+ CL uses vectors for this. once you have it, it's sufficient to get
+ efficient hash tables and everything else.
+ - could be done just by generalizing cons cells to have more than
+ car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...)
+ all you need is a tag+size on the front of the object so the collector
+ knows how to deal with it.
+ (car x) == (ref x 0), etc.
+ (rplaca x v) == (rplac x 0 v), etc.
+ (size (cons 1 2)) == 2, etc.
+ - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM),
+ then the CDR is the size and the following words are the elements.
+ . this approach is especially good if vectors are separate types from
+ conses
+ - another: add u_int32_t size to cons_t, making them all 50% bigger.
+ access is simpler and more uniform, without fully doubling the size like
+ we'd get with fat pointers.
+
+Notice that the size is one byte more than the number of characters in
+the string. This is because femtoLisp adds a NUL terminator to make its
+strings compatible with C. No effort is made to hide this fact.
+But since femtoLisp tracks the sizes of cvalues, it doesn't need the
+terminator itself. Therefore it treats zero bytes specially as rarely
+as possible. In particular, zeros are only special in values whose type
+is exactly <tt>(array char)</tt>, and are only interpreted in the
+following cases:
+<ul>
+<li>When printing strings, a final NUL is never printed. NULs in the
+middle of a string are printed though.
+<li>String constructors NUL-terminate their output.
+<li>Explicit string functions (like <tt>strlen</tt>) treat NULs the same
+way equivalent C functions would.
+</ul>
+Arrays of uchar, int8, etc. are treated as raw data and zero bytes are
+never special.
--- /dev/null
+++ b/femtolisp/torus.lsp
@@ -1,0 +1,46 @@
+(defun maplist (f l)
+ (if (null l) ()
+ (cons (f l) (maplist f (cdr l)))))
+
+; produce a beautiful, toroidal cons structure
+; 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)
+ (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)
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (rplaca a b)
+ (setq a (cdr a))
+ (setq b (cdr b))))
+ l))
+
+(defun cyl (m n)
+ (let* ((l (map-int identity n))
+ (g l))
+ (dotimes (i (- m 1))
+ (setq g (maplist identity g)))
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (rplaca a b)
+ (setq a (cdr a))
+ (setq b (cdr b))))
+ l))
+
+(time (progn (print (torus 100 100)) nil))
+; with ltable
+; printing time: 0.415sec
+; reading time: 0.165sec
+
+; with ptrhash
+; printing time: 0.081sec
+; reading time: 0.0264sec
--- /dev/null
+++ b/femtolisp/unittest.lsp
@@ -1,0 +1,77 @@
+(define (every-int n)
+ (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
+ (int64 n) (uint64 n)))
+
+(define (every-sint n)
+ (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
+
+(define (each f l)
+ (if (atom l) ()
+ (progn (f (car l))
+ (each f (cdr l)))))
+
+(define (each^2 f l m)
+ (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
+
+(define (test-lt a b)
+ (each^2 (lambda (neg pos)
+ (progn
+ (eval `(assert (= -1 (compare ,neg ,pos))))
+ (eval `(assert (= 1 (compare ,pos ,neg))))))
+ a
+ b))
+
+(define (test-eq a b)
+ (each^2 (lambda (a b)
+ (progn
+ (eval `(assert (= 0 (compare ,a ,b))))))
+ a
+ b))
+
+(test-lt (every-sint -1) (every-int 1))
+(test-lt (every-int 0) (every-int 1))
+(test-eq (every-int 88) (every-int 88))
+(test-eq (every-sint -88) (every-sint -88))
+
+(define (test-square a)
+ (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
+ a))
+
+(test-square (every-sint -67))
+(test-square (every-int 3))
+(test-square (every-int 0x80000000))
+(test-square (every-sint 0x80000000))
+(test-square (every-sint -0x80000000))
+
+(assert (= (* 128 0x02000001) 0x100000080))
+
+(assert (= (/ 1) 1))
+(assert (= (/ -1) -1))
+(assert (= (/ 2) 0))
+(assert (= (/ 2.0) 0.5))
+
+; tricky cases involving INT_MIN
+(assert (< (- #uint32(0x80000000)) 0))
+(assert (> (- #int32(0x80000000)) 0))
+(assert (< (- #uint64(0x8000000000000000)) 0))
+(assert (> (- #int64(0x8000000000000000)) 0))
+
+(assert (not (equal #int64(0x8000000000000000) #uint64(0x8000000000000000))))
+(assert (equal (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+(assert (equal (* 2 #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+
+; ok, a couple end-to-end tests as well
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(assert (equal (fib 20) 6765))
+
+(load "color.lsp")
+(assert (equal (color-pairs (generate-5x5-pairs) '(a b c d e))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
+
+(princ "all tests pass\n")
+T
--- /dev/null
+++ b/femtolisp/wt.lsp
@@ -1,0 +1,8 @@
+(setq i 0)
+(defmacro while- (test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (progn ,@forms
+ (-loop-))
+ nil)))))
+(while (< i 10000000) (set 'i (+ i 1)))