lassik
/
upscheme
1
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;
}
else {
PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
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;
case F_SPECIAL_APPLY:
f = Stack[bp-4];
v = Stack[bp-3];
f = Stack[bp-5];
v = Stack[bp-4];
PUSH(f);
PUSH(v);
nargs = 2;
@ -1592,6 +1593,7 @@ value_t toplevel_eval(value_t expr)
{
value_t v;
uint32_t saveSP = SP;
PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
v = topeval(expr, &Stack[SP-2]);

102
femtolisp/system.lsp
View File

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

4
femtolisp/torus.lsp
View File

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