lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

import femtolisp source

This commit is contained in:
JeffBezanson 2008-07-01 01:54:22 +00:00
parent 1f81d56b89
commit 0c9010a117
63 changed files with 17499 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
femtolisp/100x100.lsp Normal file
View File

File diff suppressed because one or more lines are too long

41
femtolisp/Makefile Normal file
View File

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

97
femtolisp/ast/asttools.lsp Normal file
View File

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

88
femtolisp/ast/asttools.scm Normal file
View File

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

181
femtolisp/ast/match.lsp Normal file
View File

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

181
femtolisp/ast/match.scm Normal file
View File

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

3
femtolisp/ast/out.lsp Normal file
View File

File diff suppressed because one or more lines are too long

23
femtolisp/ast/plambda-js.scm Normal file
View File

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

BIN
femtolisp/ast/rpasses.exe Executable file
View File

Binary file not shown.

121
femtolisp/ast/rpasses.lsp Normal file
View File

@ -0,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*))
;(print
; (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)

206
femtolisp/ast/rpasses.scm Normal file
View File

@ -0,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*))
;(print
; (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)

120
femtolisp/ast/starpR.lsp Normal file
View File

@ -0,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*) ())))

511
femtolisp/ast/system.lsp Normal file
View File

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

59
femtolisp/attic/flutils.c Normal file
View File

@ -0,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];
}

28
femtolisp/attic/plists.lsp Normal file
View File

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

212
femtolisp/attic/s.c Normal file
View File

@ -0,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
*/

25
femtolisp/attic/system-old.lsp Normal file
View File

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

117
femtolisp/attic/trash.c Normal file
View File

@ -0,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");
}

582
femtolisp/builtins.c Normal file
View File

@ -0,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));
}

94
femtolisp/color.lsp Normal file
View File

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

1368
femtolisp/cvalues.c Normal file
View File

File diff suppressed because it is too large Load Diff

51
femtolisp/dict.lsp Normal file
View File

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

253
femtolisp/equal.c Normal file
View File

@ -0,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
*/

68
femtolisp/equal.scm Normal file
View File

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

1471
femtolisp/flisp.c Normal file
View File

File diff suppressed because it is too large Load Diff

235
femtolisp/flisp.h Normal file
View File

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

8
femtolisp/pisum.lsp Normal file
View File

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

570
femtolisp/print.c Normal file
View File

@ -0,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);
}

21
femtolisp/printcases.lsp Normal file
View File

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

542
femtolisp/read.c Normal file
View File

@ -0,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 = &QUOTE;
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;
}

62
femtolisp/site/doc Normal file
View File

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

428
femtolisp/site/doc.html Normal file
View File

@ -0,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>#&lt;</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>

BIN
femtolisp/site/flbanner.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.7 KiB

BIN
femtolisp/site/flbanner.xcf Normal file
View File

Binary file not shown.

BIN
femtolisp/site/flbanner2.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.2 KiB

BIN
femtolisp/site/home.gif Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 969 B

206
femtolisp/site/index.html Normal file
View File

@ -0,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,
+, -, *, /, &lt;, 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,
=, !=, &gt;, &lt;=, &gt;=, 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 (&lt;= 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 = &amp;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&mdash;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>

BIN
femtolisp/site/software.gif Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 947 B

BIN
femtolisp/site/source.gif Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 408 B

BIN
femtolisp/site/text.gif Executable file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 936 B

466
femtolisp/system.lsp Normal file
View File

@ -0,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")))))

11
femtolisp/tcolor.lsp Normal file
View File

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

194
femtolisp/test.lsp Normal file
View File

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

22
femtolisp/tiny/Makefile Normal file
View File

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

390
femtolisp/tiny/eval1 Normal file
View File

@ -0,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;
}

407
femtolisp/tiny/eval2 Normal file
View File

@ -0,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;
}

443
femtolisp/tiny/evalt Normal file
View File

@ -0,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;
}

119
femtolisp/tiny/flutils.c Normal file
View File

@ -0,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;
}

BIN
femtolisp/tiny/lisp Executable file
View File

Binary file not shown.

975
femtolisp/tiny/lisp-nontail.c Normal file
View File

@ -0,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_(&QUOTE, 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;
}

1029
femtolisp/tiny/lisp.c Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
femtolisp/tiny/lisp2 Executable file
View File

Binary file not shown.

1434
femtolisp/tiny/lisp2.c Normal file
View File

File diff suppressed because it is too large Load Diff

1448
femtolisp/tiny/lisp2.c.bak Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
femtolisp/tiny/lispf Executable file
View File

Binary file not shown.

1043
femtolisp/tiny/lispf.c Normal file
View File

File diff suppressed because it is too large Load Diff

107
femtolisp/tiny/scrap.c Normal file
View File

@ -0,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;
}

426
femtolisp/tiny/system.lsp Normal file
View File

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

840
femtolisp/todo Normal file
View File

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

41
femtolisp/todo-scrap Normal file
View File

@ -0,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.

46
femtolisp/torus.lsp Normal file
View File

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

77
femtolisp/unittest.lsp Normal file
View File

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

8
femtolisp/wt.lsp Normal file
View File

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