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

allowing form (define x) 

error checking define a bit better
fixing a small bug in expand-lambda
This commit is contained in:
JeffBezanson 2009-08-12 05:15:21 +00:00
parent 332235231c
commit 43b6029727
3 changed files with 18 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
femtolisp/compiler.lsp
View File

@ -426,11 +426,18 @@
(compile-builtin-call g env tail? x head b nargs) (compile-builtin-call g env tail? x head b nargs)
(emit g (if tail? 'tcall 'call) nargs)))))))))) (emit g (if tail? 'tcall 'call) nargs))))))))))
(define (expand-define form body) (define (expand-define x)
(let ((form (cadr x))
(body (if (pair? (cddr x))
(cddr x)
(if (symbol? (cadr x))
'(#f)
(error "compile error: invalid syntax "
(print-to-string x))))))
(if (symbol? form) (if (symbol? form)
`(set! ,form ,(car body)) `(set! ,form ,(car body))
`(set! ,(car form) `(set! ,(car form)
(lambda ,(cdr form) ,@body . ,(car form))))) (lambda ,(cdr form) ,@body . ,(car form))))))
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127))) (define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
@ -470,7 +477,7 @@
(set! (compile-in g env #f (caddr x)) (set! (compile-in g env #f (caddr x))
(compile-sym g env (cadr x) [seta setc setg])) (compile-sym g env (cadr x) [seta setc setg]))
(define (compile-in g env tail? (define (compile-in g env tail?
(expand-define (cadr x) (cddr x)))) (expand-define x)))
(trycatch (compile-in g env #f `(lambda () ,(cadr x))) (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
(unless (1arg-lambda? (caddr x)) (unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda")) (error "trycatch: second form must be a 1-argument lambda"))

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

6
femtolisp/system.lsp
View File

@ -735,7 +735,7 @@
(lastcdr l))) (lastcdr l)))
(define (l-vars l) (define (l-vars l)
(cond ((atom? l) l) (cond ((atom? l) (list l))
((pair? (car l)) (cons (caar l) (l-vars (cdr l)))) ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
(else (cons (car l) (l-vars (cdr l)))))) (else (cons (car l) (l-vars (cdr l))))))
@ -787,7 +787,9 @@
(default (lambda () (default (lambda ()
(let loop ((e e)) (let loop ((e e))
(if (atom? e) e (if (atom? e) e
(cons (expand-in (car e) env) (cons (if (atom? (car e))
(car e)
(expand-in (car e) env))
(loop (cdr e)))))))) (loop (cdr e))))))))
(cond ((and bnd (pair? (cdr bnd))) ; local macro (cond ((and bnd (pair? (cdr bnd))) ; local macro
(expand-in (apply (cadr bnd) (cdr e)) (expand-in (apply (cadr bnd) (cdr e))