ref: a23bee041f11b50fe0208a81e7b3690c9661c7ff
parent: e2c1d2ae9ec513b392cc6741fed640e7d87e546a
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat May 30 13:04:34 EDT 2009
fixing bug in cond when condition wasn't followed by any forms fixing typo in cps.lsp optimizing constant conditions in if
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -180,19 +180,26 @@
(define (compile-if g env tail? x)
(let ((elsel (make-label g))
- (endl (make-label g)))
- (compile-in g env #f (cadr x))
- (emit g :brf elsel)
- (compile-in g env tail? (caddr x))
- (if tail?
- (emit g :ret)
- (emit g :jmp endl))
- (mark-label g elsel)
- (compile-in g env tail?
- (if (pair? (cdddr x))
- (cadddr x)
- #f))
- (mark-label g endl)))
+ (endl (make-label g))
+ (test (cadr x))
+ (then (caddr x))
+ (else (if (pair? (cdddr x))
+ (cadddr x)
+ #f)))
+ (cond ((eq? test #t)
+ (compile-in g env tail? then))
+ ((eq? test #f)
+ (compile-in g env tail? else))
+ (else
+ (compile-in g env #f test)
+ (emit g :brf elsel)
+ (compile-in g env tail? then)
+ (if tail?
+ (emit g :ret)
+ (emit g :jmp endl))
+ (mark-label g elsel)
+ (compile-in g env tail? else)
+ (mark-label g endl)))))
(define (compile-begin g env tail? forms)
(cond ((atom? forms) (compile-in g env tail? #f))
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -1,9 +1,4 @@
; -*- scheme -*-
-(define (cond-body e)
- (cond ((atom? e) #f)
- ((null? (cdr e)) (car e))
- (#t (cons 'begin e))))
-
(define (begin->cps forms k)
(cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k))
@@ -100,7 +95,7 @@
(cond ((atom? (cdr form)) `(,k #t))
((atom? (cddr form)) (cps- (cadr form) k))
(#t
- (if (atom k)
+ (if (atom? k)
(cps- (cadr form)
`(lambda (,g)
(if ,g ,(cps- `(and ,@(cddr form)) k)
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -225,7 +225,7 @@
compile-in
#function("n4f3C6E0e0f0f1f3c144;f3?6\xba0f3`<6[0e2f0e342;f3a<6k0e2f0e442;f3]<6{0e2f0e542;f3^<6\x8b0e2f0e642;f3_<6\x9b0e2f0e742;e8f3316\xaf0e2f0e9f343;e2f0e:f343;c;f3Mq42;" [compile-sym [:loada :loadc :loadg] emit :load0 :load1 :loadt :loadf :loadnil fits-i8 :loadi8 :loadv #function("rf0c0=6J0e1g00e2e3g033143;f0c4=6c0e5g00g01g02g0344;f0c6=6}0e7g00g01g02g03N44;f0c8=6\x930e9g00g01g0343;f0c:=6\xb90e1g00e2e;g01g0332332e1g00e<42;f0c==6\xd30e>g00g01g02g03N44;f0c?=6\xed0e@g00g01g02g03N44;f0cA=6\x110eBg00g01e3g0331c6eCg0331K44;f0cD=691eEg00g01e3g0331eFg0331eGg033145;f0cH=6^1eIg00g01]e3g0331342e1g00eJ42;f0cK=6\x8d1eIg00g01^eFg0331342eLg00g01e3g0331cM44;f0cN=6\xe31eIg00g01^c:_e3g0331L3342eOeFg0331316\xbf1^5\xc51ePcQ312eIg00g01^eFg0331342e1g00eR42;eSg00g01g02g0344;" [quote emit :loadv cadr if compile-if begin compile-begin prog1 compile-prog1 lambda compile-f :closure and compile-and or compile-or while compile-while cddr for compile-for caddr cadddr return compile-in :ret set! compile-sym [:seta :setc :setg] trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda" :trycatch compile-app])])compile-if
-#function("n4c0e1f031e1f031q43;" [#function("re0g00g01^e1g0331342e2g00e3f0332e0g00g01g02e4g0331342g026w0e2g00e5325\x820e2g00e6f1332e7g00f0322e0g00g01g02e8g0331F6\xad0e9g03315\xae0^342e7g00f142;" [compile-in cadr emit :brf caddr :ret :jmp mark-label cdddr cadddr]) make-label])+#function("n4c0e1f031e1f031e2f331e3f331e4f331F6_0e5f3315`0^q46;" [#function("rf2]<6H0e0g00g01g02f344;f2^<6_0e0g00g01g02f444;e0g00g01^f2342e1g00e2f0332e0g00g01g02f3342g026\x9b0e1g00e3325\xa60e1g00e4f1332e5g00f0322e0g00g01g02f4342e5g00f142;" [compile-in emit :brf :ret :jmp mark-label]) make-label cadr caddr cdddr cadddr])compile-for
#function("n5e0f4316h0e1f0f1^f2342e1f0f1^f3342e1f0f1^f4342e2f0e342;e4c541;" [1arg-lambda? compile-in emit :for error "for: third form must be a 1-argument lambda"])compile-f
@@ -323,6 +323,6 @@
*whitespace*
"\t\n\v\f\r \u0085 \u2028\u2029 "
*syntax-environment*
-#table(define #function("o1f0C6B0c0f0f1ML3;c0f0Mc1f0Nf1KKL3;" [set! lambda]) letrec #function("o1c0e1e2f032e3e1c4mf032f132KKe1c5mf032K;" [lambda map car nconc #function("n1c0f0K;" [set!]) #function("n1^;" [])]) backquote #function("n1e0f041;" [bq-process]) assert #function("n1c0f0]c1c2c3f0L2L2L2L4;" [if raise quote assert-failed]) label #function("n2c0f0L1c1f0f1L3L3^L2;" [lambda set!]) do #function("o2c0e130f1Me2e3f032e2e4f032e2c5mf032q46;" [#function("rc0f0c1f2c2f1e3c4L1e5g01N3132e3c4L1e5g0231e3f0L1e5f43132L133L4L3L2L1e3f0L1e5f33132L3;" [letrec lambda if nconc begin copy-list]) gensym map car cadr #function("n1e0f031F6C0e1f041;f0M;" [cddr caddr])]) when #function("o1c0f0c1f1K^L4;" [if begin]) unwind-protect #function("n2c0e130e130q43;" [#function("rc0f1c1_g01L3L2L1c2c3g00c1f0L1c4f1L1c5f0L2L3L3L3f1L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function("o1c0f0Me1f031q43;" [#function("rc0`c1f1aL3e2c3L1f0L1L1e4g013133L4;" [for - nconc lambda copy-list]) cadr]) define-macro #function("o1c0c1f0ML2c2f0Nf1KKL3;" [set-syntax! quote lambda]) unless #function("o1c0f0^c1f1KL4;" [if begin]) let #function("o1c0^q42;" [#function("rg00C6P0g00j02g01Mk002g01Nk015Q0^2c0c1e2c3mg0032g01KKe2c4mg0032q43;" [#function("rg006C0c0g00f0L35E0f0f1K;" [label]) lambda map #function("n1f0F6<0f0M;f0;" []) #function("n1f0F6?0e0f041;^;" [cadr])])]) cond #function("o0c0^q42;" [#function("rc0mj02f0g0041;" [#function("n1f0?6:0^;c0f0Mq42;" [#function("rf0Mc0<17A02f0M]<6K0c1f0NK;c2f0Mc1f0NKg10g00N31L4;" [else begin if])])])]) throw #function("n2c0c1c2c3L2f0f1L4L2;" [raise list quote thrown-value]) time #function("n1c0e130q42;" [#function("rc0f0c1L1L2L1c2g00c3c4c5c1L1f0L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("o1f0?6L0e0c1L1_L1e2f13133L1;e0c1L1e3f031L1L1e2f0NF6}0e0c4L1f0NL1e2f13133L15\x7F0f13133e5f031L2;" [nconc lambda copy-list caar let* cadar]) case #function("o1c0^q42;" [#function("rc0mj02c1e230q42;" [#function("n2f1c0<6=0c0;f1A6E0^;f1?6X0c1f0e2f131L3;f1NA6m0c1f0e2f1M31L3;c3f0c4f1L2L3;" [else eqv? quote-value memv quote]) #function("rc0f0g10L2L1e1c2L1e3e4c5mg11323132L3;" [let nconc cond copy-list map #function("n1g10g00f0M32f0NK;" [])]) gensym])]) catch #function("n2c0e130q42;" [#function("rc0g01c1f0L1c2c3c4f0L2c5c6f0L2c7c8L2L3c5c9f0L2g00L3L4c:f0L2c;f0L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))+#table(define #function("o1f0C6B0c0f0f1ML3;c0f0Mc1f0Nf1KKL3;" [set! lambda]) letrec #function("o1c0e1e2f032e3e1c4mf032f132KKe1c5mf032K;" [lambda map car nconc #function("n1c0f0K;" [set!]) #function("n1^;" [])]) backquote #function("n1e0f041;" [bq-process]) assert #function("n1c0f0]c1c2c3f0L2L2L2L4;" [if raise quote assert-failed]) label #function("n2c0f0L1c1f0f1L3L3^L2;" [lambda set!]) do #function("o2c0e130f1Me2e3f032e2e4f032e2c5mf032q46;" [#function("rc0f0c1f2c2f1e3c4L1e5g01N3132e3c4L1e5g0231e3f0L1e5f43132L133L4L3L2L1e3f0L1e5f33132L3;" [letrec lambda if nconc begin copy-list]) gensym map car cadr #function("n1e0f031F6C0e1f041;f0M;" [cddr caddr])]) when #function("o1c0f0c1f1K^L4;" [if begin]) unwind-protect #function("n2c0e130e130q43;" [#function("rc0f1c1_g01L3L2L1c2c3g00c1f0L1c4f1L1c5f0L2L3L3L3f1L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function("o1c0f0Me1f031q43;" [#function("rc0`c1f1aL3e2c3L1f0L1L1e4g013133L4;" [for - nconc lambda copy-list]) cadr]) define-macro #function("o1c0c1f0ML2c2f0Nf1KKL3;" [set-syntax! quote lambda]) unless #function("o1c0f0^c1f1KL4;" [if begin]) let #function("o1c0^q42;" [#function("rg00C6P0g00j02g01Mk002g01Nk015Q0^2c0c1e2c3mg0032g01KKe2c4mg0032q43;" [#function("rg006C0c0g00f0L35E0f0f1K;" [label]) lambda map #function("n1f0F6<0f0M;f0;" []) #function("n1f0F6?0e0f041;^;" [cadr])])]) cond #function("o0c0^q42;" [#function("rc0mj02f0g0041;" [#function("n1f0?6:0^;c0f0Mq42;" [#function("rf0Mc0<17A02f0M]<6V0f0NA6O0f0M;c1f0NK;f0NA6n0c2f0Mg10g00N31L3;c3f0Mc1f0NKg10g00N31L4;" [else begin or if])])])]) throw #function("n2c0c1c2c3L2f0f1L4L2;" [raise list quote thrown-value]) time #function("n1c0e130q42;" [#function("rc0f0c1L1L2L1c2g00c3c4c5c1L1f0L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("o1f0?6L0e0c1L1_L1e2f13133L1;e0c1L1e3f031L1L1e2f0NF6}0e0c4L1f0NL1e2f13133L15\x7F0f13133e5f031L2;" [nconc lambda copy-list caar let* cadar]) case #function("o1c0^q42;" [#function("rc0mj02c1e230q42;" [#function("n2f1c0<6=0c0;f1A6E0^;f1?6X0c1f0e2f131L3;f1NA6m0c1f0e2f1M31L3;c3f0c4f1L2L3;" [else eqv? quote-value memv quote]) #function("rc0f0g10L2L1e1c2L1e3e4c5mg11323132L3;" [let nconc cond copy-list map #function("n1g10g00f0M32f0NK;" [])]) gensym])]) catch #function("n2c0e130q42;" [#function("rc0g01c1f0L1c2c3c4f0L2c5c6f0L2c7c8L2L3c5c9f0L2g00L3L4c:f0L2c;f0L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))*banner*
"; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -58,11 +58,18 @@
(let ((clause (car lst)))
(if (or (eq? (car clause) 'else)
(eq? (car clause) #t))
- (cons 'begin (cdr clause))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst)))))))
+ (if (null? (cdr clause))
+ (car clause)
+ (cons 'begin (cdr clause)))
+ (if (null? (cdr clause))
+ ; test by itself
+ (list 'or
+ (car clause)
+ (cond-clauses->if (cdr lst)))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst))))))))
(cond-clauses->if clauses))
; standard procedures ---------------------------------------------------------