some cleanup, removing some unnecessary global bindings
This commit is contained in:
parent
43cb51f640
commit
ea5d334626
|
@ -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]);
|
||||||
|
|
|
@ -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,7 +260,8 @@
|
||||||
(cons elt
|
(cons elt
|
||||||
(delete-duplicates tail))))))
|
(delete-duplicates tail))))))
|
||||||
|
|
||||||
(define (get-defined-vars- expr)
|
(letrec ((get-defined-vars-
|
||||||
|
(lambda (expr)
|
||||||
(cond ((atom? expr) ())
|
(cond ((atom? expr) ())
|
||||||
((and (eq? (car expr) 'define)
|
((and (eq? (car expr) 'define)
|
||||||
(pair? (cdr expr)))
|
(pair? (cdr expr)))
|
||||||
|
@ -263,20 +273,21 @@
|
||||||
()))
|
()))
|
||||||
((eq? (car expr) 'begin)
|
((eq? (car expr) 'begin)
|
||||||
(apply append (map get-defined-vars- (cdr expr))))
|
(apply append (map get-defined-vars- (cdr expr))))
|
||||||
(else ())))
|
(else ())))))
|
||||||
(define (get-defined-vars expr)
|
(set! get-defined-vars
|
||||||
(delete-duplicates (get-defined-vars- expr)))
|
(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 (e)
|
||||||
((lambda (B)
|
((lambda (B)
|
||||||
((lambda (V)
|
((lambda (V)
|
||||||
(if (null? V)
|
(if (null? V)
|
||||||
B
|
B
|
||||||
(cons (list 'lambda V B) (map (lambda (x) #f) V))))
|
(cons (list 'lambda V B) (map (lambda (x) #f) V))))
|
||||||
(get-defined-vars B)))
|
(get-defined-vars B)))
|
||||||
(f-body- e)))
|
(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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue