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

fixing bug in cond when condition wasn't followed by any forms 

fixing typo in cps.lsp
optimizing constant conditions in if
This commit is contained in:
JeffBezanson 2009-05-30 17:04:34 +00:00
parent e2c1d2ae9e
commit a23bee041f
4 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
femtolisp/compiler.lsp
View File

@ -180,19 +180,26 @@
(define (compile-if g env tail? x) (define (compile-if g env tail? x)
(let ((elsel (make-label g)) (let ((elsel (make-label g))
(endl (make-label g))) (endl (make-label g))
(compile-in g env #f (cadr x)) (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) (emit g :brf elsel)
(compile-in g env tail? (caddr x)) (compile-in g env tail? then)
(if tail? (if tail?
(emit g :ret) (emit g :ret)
(emit g :jmp endl)) (emit g :jmp endl))
(mark-label g elsel) (mark-label g elsel)
(compile-in g env tail? (compile-in g env tail? else)
(if (pair? (cdddr x)) (mark-label g endl)))))
(cadddr x)
#f))
(mark-label g endl)))
(define (compile-begin g env tail? forms) (define (compile-begin g env tail? forms)
(cond ((atom? forms) (compile-in g env tail? #f)) (cond ((atom? forms) (compile-in g env tail? #f))

7
femtolisp/cps.lsp
View File

@ -1,9 +1,4 @@
; -*- scheme -*- ; -*- scheme -*-
(define (cond-body e)
(cond ((atom? e) #f)
((null? (cdr e)) (car e))
(#t (cons 'begin e))))
(define (begin->cps forms k) (define (begin->cps forms k)
(cond ((atom? forms) `(,k ,forms)) (cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k)) ((null? (cdr forms)) (cps- (car forms) k))
@ -100,7 +95,7 @@
(cond ((atom? (cdr form)) `(,k #t)) (cond ((atom? (cdr form)) `(,k #t))
((atom? (cddr form)) (cps- (cadr form) k)) ((atom? (cddr form)) (cps- (cadr form) k))
(#t (#t
(if (atom k) (if (atom? k)
(cps- (cadr form) (cps- (cadr form)
`(lambda (,g) `(lambda (,g)
(if ,g ,(cps- `(and ,@(cddr form)) k) (if ,g ,(cps- `(and ,@(cddr form)) k)

4
femtolisp/flisp.boot
View File

@ -225,7 +225,7 @@ compile-let
compile-in 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])]) #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 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 compile-for
#function("n5e0f4316h0e1f0f1^f2342e1f0f1^f3342e1f0f1^f4342e2f0e342;e4c541;" [1arg-lambda? compile-in emit :for error "for: third form must be a 1-argument lambda"]) #function("n5e0f4316h0e1f0f1^f2342e1f0f1^f3342e1f0f1^f4342e2f0e342;e4c541;" [1arg-lambda? compile-in emit :for error "for: third form must be a 1-argument lambda"])
compile-f compile-f
@ -323,6 +323,6 @@ Instructions
*whitespace* *whitespace*
"\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　" "\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　"
*syntax-environment* *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* *banner*
"; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"

11
femtolisp/system.lsp
View File

@ -58,11 +58,18 @@
(let ((clause (car lst))) (let ((clause (car lst)))
(if (or (eq? (car clause) 'else) (if (or (eq? (car clause) 'else)
(eq? (car clause) #t)) (eq? (car clause) #t))
(cons 'begin (cdr clause)) (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 (list 'if
(car clause) (car clause)
(cons 'begin (cdr clause)) (cons 'begin (cdr clause))
(cond-clauses->if (cdr lst))))))) (cond-clauses->if (cdr lst))))))))
(cond-clauses->if clauses)) (cond-clauses->if clauses))
; standard procedures --------------------------------------------------------- ; standard procedures ---------------------------------------------------------