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

some cleanup, removing some unnecessary global bindings

This commit is contained in:
JeffBezanson 2009-04-08 18:17:02 +00:00
parent 43cb51f640
commit ea5d334626
3 changed files with 88 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
femtolisp/flisp.c
View File

@ -1337,6 +1337,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
goto eval_top; goto eval_top;
} }
else { else {
PUSH(fixnum(2));
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
v = eval_sexpr(v, &Stack[SP-2], 1); v = eval_sexpr(v, &Stack[SP-2], 1);
@ -1371,8 +1372,8 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
} }
break; break;
case F_SPECIAL_APPLY: case F_SPECIAL_APPLY:
f = Stack[bp-4]; f = Stack[bp-5];
v = Stack[bp-3]; v = Stack[bp-4];
PUSH(f); PUSH(f);
PUSH(v); PUSH(v);
nargs = 2; nargs = 2;
@ -1592,6 +1593,7 @@ value_t toplevel_eval(value_t expr)
{ {
value_t v; value_t v;
uint32_t saveSP = SP; uint32_t saveSP = SP;
PUSH(fixnum(2));
PUSH(NIL); PUSH(NIL);
PUSH(NIL); PUSH(NIL);
v = topeval(expr, &Stack[SP-2]); v = topeval(expr, &Stack[SP-2]);

160
femtolisp/system.lsp
View File

@ -21,8 +21,6 @@
(list 'set! form (car body)) (list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body body))))) (list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
(define-macro (body . forms) (f-body forms))
(define (set s v) (eval (list 'set! s (list 'quote v)))) (define (set s v) (eval (list 'set! s (list 'quote v))))
(define (map f lst) (define (map f lst)
@ -50,16 +48,25 @@
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))) (map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
#f)) #f))
(define-macro (letrec binds . body)
(cons (list 'lambda (map car binds)
(f-body
(nconc (map (lambda (b) (cons 'set! b)) binds)
body)))
(map (lambda (x) #f) binds)))
; standard procedures --------------------------------------------------------- ; standard procedures ---------------------------------------------------------
(define (append2 l d)
(if (null? l) d
(cons (car l)
(append2 (cdr l) d))))
(define (append . lsts) (define (append . lsts)
(cond ((null? lsts) ()) (cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(#t ((label append2 (lambda (l d) (#t (append2 (car lsts)
(if (null? l) d (apply append (cdr lsts))))))
(cons (car l)
(append2 (cdr l) d)))))
(car lsts) (apply append (cdr lsts))))))
(define (member item lst) (define (member item lst)
(cond ((atom? lst) #f) (cond ((atom? lst) #f)
@ -130,10 +137,9 @@
(define (listp a) (or (null? a) (pair? a))) (define (listp a) (or (null? a) (pair? a)))
(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a))))) (define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
(define (nthcdr lst n) (define (list-tail lst n)
(if (<= n 0) lst (if (<= n 0) lst
(nthcdr (cdr lst) (- n 1)))) (list-tail (cdr lst) (- n 1))))
(define list-tail nthcdr)
(define (list-head lst n) (define (list-head lst n)
(if (<= n 0) () (if (<= n 0) ()
@ -141,7 +147,7 @@
(list-head (cdr lst) (- n 1))))) (list-head (cdr lst) (- n 1)))))
(define (list-ref lst n) (define (list-ref lst n)
(car (nthcdr lst n))) (car (list-tail lst n)))
; bounded length test ; bounded length test
; use this instead of (= (length lst) n), since it avoids unnecessary ; use this instead of (= (length lst) n), since it avoids unnecessary
@ -166,11 +172,10 @@
(if (atom? l) l (if (atom? l) l
(lastcdr (cdr l)))) (lastcdr (cdr l))))
(define (last l) (define (last-pair l)
(cond ((atom? l) l) (cond ((atom? l) l)
((atom? (cdr l)) l) ((atom? (cdr l)) l)
(#t (last (cdr l))))) (#t (last-pair (cdr l)))))
(define last-pair last)
(define (to-proper l) (define (to-proper l)
(cond ((null? l) l) (cond ((null? l) l)
@ -183,32 +188,36 @@
(set-car! lst (f (car lst))) (set-car! lst (f (car lst)))
(set! lst (cdr lst))))) (set! lst (cdr lst)))))
(define (mapcar f . lsts) (letrec ((mapcar-
((label mapcar-
(lambda (f lsts) (lambda (f lsts)
(cond ((null? lsts) (f)) (cond ((null? lsts) (f))
((atom? (car lsts)) (car lsts)) ((atom? (car lsts)) (car lsts))
(#t (cons (apply f (map car lsts)) (#t (cons (apply f (map car lsts))
(mapcar- f (map cdr lsts))))))) (mapcar- f (map cdr lsts))))))))
f lsts)) (set! mapcar
(lambda (f . lsts) (mapcar- f lsts))))
(define (transpose M) (apply mapcar (cons list M))) (define (transpose M) (apply mapcar (cons list M)))
(define (filter pred lst) (filter- pred lst ())) (letrec ((filter-
(define (filter- pred lst accum) (lambda (pred lst accum)
(cond ((null? lst) accum) (cond ((null? lst) accum)
((pred (car lst)) ((pred (car lst))
(filter- pred (cdr lst) (cons (car lst) accum))) (filter- pred (cdr lst) (cons (car lst) accum)))
(#t (#t
(filter- pred (cdr lst) accum)))) (filter- pred (cdr lst) accum))))))
(set! filter
(lambda (pred lst) (filter- pred lst ()))))
(define (separate pred lst) (separate- pred lst () ())) (letrec ((separate-
(define (separate- pred lst yes no) (lambda (pred lst yes no)
(cond ((null? lst) (cons yes no)) (cond ((null? lst) (cons yes no))
((pred (car lst)) ((pred (car lst))
(separate- pred (cdr lst) (cons (car lst) yes) no)) (separate- pred (cdr lst) (cons (car lst) yes) no))
(#t (#t
(separate- pred (cdr lst) yes (cons (car lst) no))))) (separate- pred (cdr lst) yes (cons (car lst) no)))))))
(set! separate
(lambda (pred lst) (separate- pred lst () ()))))
(define (nestlist f zero n) (define (nestlist f zero n)
(if (<= n 0) () (if (<= n 0) ()
@ -251,32 +260,34 @@
(cons elt (cons elt
(delete-duplicates tail)))))) (delete-duplicates tail))))))
(define (get-defined-vars- expr) (letrec ((get-defined-vars-
(cond ((atom? expr) ()) (lambda (expr)
((and (eq? (car expr) 'define) (cond ((atom? expr) ())
(pair? (cdr expr))) ((and (eq? (car expr) 'define)
(or (and (symbol? (cadr expr)) (pair? (cdr expr)))
(list (cadr expr))) (or (and (symbol? (cadr expr))
(and (pair? (cadr expr)) (list (cadr expr)))
(symbol? (caadr expr)) (and (pair? (cadr expr))
(list (caadr expr))) (symbol? (caadr expr))
())) (list (caadr expr)))
((eq? (car expr) 'begin) ()))
(apply append (map get-defined-vars- (cdr expr)))) ((eq? (car expr) 'begin)
(else ()))) (apply append (map get-defined-vars- (cdr expr))))
(define (get-defined-vars expr) (else ())))))
(delete-duplicates (get-defined-vars- expr))) (set! get-defined-vars
(lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
; redefine f-body to support internal define ; redefine f-body to support internal define
(define f-body- f-body) (let ((f-body- f-body))
(define (f-body e) (set! f-body
((lambda (B) (lambda (e)
((lambda (V) ((lambda (B)
(if (null? V) ((lambda (V)
B (if (null? V)
(cons (list 'lambda V B) (map (lambda (x) #f) V)))) B
(get-defined-vars B))) (cons (list 'lambda V B) (map (lambda (x) #f) V))))
(f-body- e))) (get-defined-vars B)))
(f-body- e)))))
; backquote ------------------------------------------------------------------- ; backquote -------------------------------------------------------------------
@ -352,13 +363,6 @@
(let* ,(cdr binds) ,@body)) (let* ,(cdr binds) ,@body))
,(cadar binds)))) ,(cadar binds))))
(define-macro (letrec binds . body)
(cons (list 'lambda (map car binds)
(f-body
(nconc (map (lambda (b) (cons 'set! b)) binds)
body)))
(map (lambda (x) #f) binds)))
(define-macro (when c . body) (list 'if c (f-body body) #f)) (define-macro (when c . body) (list 'if c (f-body body) #f))
(define-macro (unless c . body) (list 'if c #f (f-body body))) (define-macro (unless c . body) (list 'if c #f (f-body body)))
@ -468,7 +472,7 @@
(let ((lam (eval sym))) (let ((lam (eval sym)))
(if (eq? (car lam) 'trace-lambda) (if (eq? (car lam) 'trace-lambda)
(set sym (set sym
(cadr (caar (last (caddr lam)))))))) (cadr (caar (last-pair (caddr lam))))))))
(define-macro (time expr) (define-macro (time expr)
(let ((t0 (gensym))) (let ((t0 (gensym)))
@ -555,27 +559,27 @@
(define (string.trim s at-start at-end) (define (string.trim s at-start at-end)
(define (trim-start s chars i L) (define (trim-start s chars i L)
(if (and (#.< i L) (if (and (< i L)
(#.string.find chars (#.string.char s i))) (string.find chars (string.char s i)))
(trim-start s chars (#.string.inc s i) L) (trim-start s chars (string.inc s i) L)
i)) i))
(define (trim-end s chars i) (define (trim-end s chars i)
(if (and (> i 0) (if (and (> i 0)
(#.string.find chars (#.string.char s (#.string.dec s i)))) (string.find chars (string.char s (string.dec s i))))
(trim-end s chars (#.string.dec s i)) (trim-end s chars (string.dec s i))
i)) i))
(let ((L (#.length s))) (let ((L (length s)))
(string.sub s (string.sub s
(trim-start s at-start 0 L) (trim-start s at-start 0 L)
(trim-end s at-end L)))) (trim-end s at-end L))))
(define (string.map f s) (define (string.map f s)
(let ((b (buffer)) (let ((b (buffer))
(n (#.length s))) (n (length s)))
(let ((i 0)) (let ((i 0))
(while (#.< i n) (while (< i n)
(begin (#.io.putc b (f (#.string.char s i))) (begin (io.putc b (f (string.char s i)))
(set! i (#.string.inc s i))))) (set! i (string.inc s i)))))
(io.tostring! b))) (io.tostring! b)))
(define (string.rep s k) (define (string.rep s k)

4
femtolisp/torus.lsp
View File

@ -14,8 +14,8 @@
(dotimes (i (- m 1)) (dotimes (i (- m 1))
(set! prev g) (set! prev g)
(set! g (maplist identity g)) (set! g (maplist identity g))
(set-cdr! (last prev) prev)) (set-cdr! (last-pair prev) prev))
(set-cdr! (last g) g) (set-cdr! (last-pair g) g)
(let ((a l) (let ((a l)
(b g)) (b g))
(dotimes (i n) (dotimes (i n)