conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

every case-lambda case now has a label

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 20:13:21 -05:00
parent c54ade7cef
commit 36b3ec82d2
2 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

27
lib/libcompile.ss
View File

@ -231,7 +231,7 @@
(define-record fix (lhs* rhs* body)) (define-record fix (lhs* rhs* body))
(define-record seq (e0 e1)) (define-record seq (e0 e1))
(define-record case-info (args proper)) (define-record case-info (label args proper))
(define-record clambda-case (info body)) (define-record clambda-case (info body))
(define-record clambda (label cases free)) (define-record clambda (label cases free))
(define-record closure (code free*)) (define-record closure (code free*))
@ -348,6 +348,7 @@
(let ([body (E body (extend-env fml* nfml* env))]) (let ([body (E body (extend-env fml* nfml* env))])
(make-clambda-case (make-clambda-case
(make-case-info (make-case-info
(gensym)
(properize nfml*) (properize nfml*)
(list? fml*)) (list? fml*))
body))))) body)))))
@ -491,7 +492,7 @@
(record-case cls (record-case cls
[(clambda-case info body) [(clambda-case info body)
(record-case info (record-case info
[(case-info fml* proper) [(case-info label fml* proper)
(if proper (if proper
(and (fx= (length fml*) (length rand*)) (and (fx= (length fml*) (length rand*))
(make-bind fml* rand* body)) (make-bind fml* rand* body))
@ -1065,10 +1066,10 @@
(record-case cls (record-case cls
[(clambda-case info body) [(clambda-case info body)
(record-case info (record-case info
[(case-info fml* proper) [(case-info label fml* proper)
(let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)]) (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
(make-clambda-case (make-clambda-case
(make-case-info fml* proper) (make-case-info label fml* proper)
(bind-assigned a-lhs* a-rhs* (Expr body))))])])) (bind-assigned a-lhs* a-rhs* (Expr body))))])]))
cls*) cls*)
#f)] #f)]
@ -2062,11 +2063,12 @@
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case info body) [(clambda-case info body)
(let-values ([(fml* si r live) (record-case info
(bind-fml* (case-info-args info) r)]) [(case-info label fml* proper)
(let-values ([(fml* si r live) (bind-fml* fml* r)])
(make-clambda-case (make-clambda-case
(make-case-info fml* (case-info-proper info)) (make-case-info label fml* proper)
(Tail body si r live)))])))) (Tail body si r live)))])]))))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
@ -3736,9 +3738,10 @@
(define (Entry check? x ac) (define (Entry check? x ac)
(record-case x (record-case x
[(clambda-case info body) [(clambda-case info body)
(let ([ac (Tail body ac)])
(record-case info (record-case info
[(case-info fml* proper) [(case-info L fml* proper)
(let ([ac
(cons (label L) (Tail body ac))])
(cond (cond
[(and proper check?) [(and proper check?)
(list* (cmpl (int (argc-convention (length fml*))) eax) (list* (cmpl (int (argc-convention (length fml*))) eax)
@ -3746,7 +3749,7 @@
ac)] ac)]
[proper ac] [proper ac]
[else [else
(handle-vararg (length fml*) ac)])]))])) (handle-vararg (length fml*) ac)]))])]))
(define make-dispatcher (define make-dispatcher
(lambda (j? L L* x x* ac) (lambda (j? L L* x x* ac)
(cond (cond
@ -3755,7 +3758,7 @@
(record-case x (record-case x
[(clambda-case info _) [(clambda-case info _)
(record-case info (record-case info
[(case-info fml* proper) [(case-info _ fml* proper)
(cond (cond
[proper [proper
(list* (cmpl (int (argc-convention (length fml*))) eax) (list* (cmpl (int (argc-convention (length fml*))) eax)