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

removed clambda-code record type

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 19:05:02 -05:00
parent 307b166f38
commit b8b4172797
2 changed files with 31 additions and 27 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.

58
lib/libcompile.ss
View File

@ -232,8 +232,7 @@
(define-record seq (e0 e1)) (define-record seq (e0 e1))
(define-record clambda-case (arg* proper body)) (define-record clambda-case (arg* proper body))
(define-record clambda (label cases)) (define-record clambda (label cases free))
(define-record clambda-code (label cases free))
(define-record closure (code free*)) (define-record closure (code free*))
(define-record funcall (op rand*)) (define-record funcall (op rand*))
(define-record appcall (op rand*)) (define-record appcall (op rand*))
@ -352,7 +351,7 @@
(list? fml*) (list? fml*)
body))))) body)))))
(cdr x))]) (cdr x))])
(make-clambda (gensym) cls*))] (make-clambda (gensym) cls* #f))]
[(foreign-call) [(foreign-call)
(let ([name (quoted-string (cadr x))] [arg* (cddr x)]) (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
(make-forcall name (make-forcall name
@ -437,7 +436,7 @@
`(clambda-case ,(E-args proper args) ,(E body))] `(clambda-case ,(E-args proper args) ,(E body))]
[(clambda g cls*) [(clambda g cls*)
`(case-lambda . ,(map E cls*))] `(case-lambda . ,(map E cls*))]
[(clambda-code label clauses free) [(clambda label clauses free)
`(code ,label . ,(map E clauses))] `(code ,label . ,(map E clauses))]
[(closure code free*) [(closure code free*)
`(closure ,(E code) ,(map E free*))] `(closure ,(E code) ,(map E free*))]
@ -526,7 +525,8 @@
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
(make-clambda-case fml* proper (Expr body))])) (make-clambda-case fml* proper (Expr body))]))
cls*))] cls*)
#f)]
[(primcall rator rand*) [(primcall rator rand*)
(make-primcall rator (map Expr rand*))] (make-primcall rator (map Expr rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -725,7 +725,8 @@
(let ([h (make-hash-table)]) (let ([h (make-hash-table)])
(let ([body (E body (extend-hash fml* h ref) void)]) (let ([body (E body (extend-hash fml* h ref) void)])
(make-clambda-case fml* proper body)))])) (make-clambda-case fml* proper body)))]))
cls*))] cls*)
#f)]
[(primcall rator rand*) [(primcall rator rand*)
(when (memq rator '(call/cc call/cf)) (when (memq rator '(call/cc call/cf))
(comp)) (comp))
@ -793,7 +794,8 @@
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case fml* proper body)
(make-clambda-case fml* proper (Expr body))])) (make-clambda-case fml* proper (Expr body))]))
cls*))] cls*)
#f)]
[(primcall rator rand*) [(primcall rator rand*)
(make-primcall rator (map Expr rand*))] (make-primcall rator (map Expr rand*))]
[(funcall rator rand*) [(funcall rator rand*)
@ -922,7 +924,8 @@
[(clambda-case arg* proper body) [(clambda-case arg* proper body)
(make-clambda-case arg* proper (make-clambda-case arg* proper
(Value body))])) (Value body))]))
cls*))) cls*)
#f))
(define (Effect x) (define (Effect x)
(record-case x (record-case x
[(constant) the-void] [(constant) the-void]
@ -1058,7 +1061,8 @@
(let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)]) (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
(make-clambda-case fml* proper (make-clambda-case fml* proper
(bind-assigned a-lhs* a-rhs* (Expr body))))])) (bind-assigned a-lhs* a-rhs* (Expr body))))]))
cls*))] cls*)
#f)]
[(primcall op rand*) [(primcall op rand*)
(make-primcall op (map Expr rand*))] (make-primcall op (map Expr rand*))]
[(forcall op rand*) [(forcall op rand*)
@ -1107,7 +1111,7 @@
cls*) cls*)
(union (difference body-free fml*) (union (difference body-free fml*)
cls*-free)))])]))]) cls*-free)))])]))])
(values (make-closure (make-clambda-code g cls* free) free) (values (make-closure (make-clambda g cls* free) free)
free))])) free))]))
(define (Expr ex) (define (Expr ex)
(record-case ex (record-case ex
@ -1176,7 +1180,7 @@
[else #f])) [else #f]))
(define (trim/lift-code code free*) (define (trim/lift-code code free*)
(record-case code (record-case code
[(clambda-code label cls* free*/dropped) [(clambda label cls* free*/dropped)
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(record-case x (record-case x
@ -1187,7 +1191,7 @@
cls*)]) cls*)])
(let ([g (make-code-loc label)]) (let ([g (make-code-loc label)])
(set! all-codes (set! all-codes
(cons (make-clambda-code label cls* free*) all-codes)) (cons (make-clambda label cls* free*) all-codes))
g))])) g))]))
(define (optimize-one-closure code free) (define (optimize-one-closure code free)
(let ([free (trim-vars free)]) (let ([free (trim-vars free)])
@ -1298,7 +1302,7 @@
(define all-codes '()) (define all-codes '())
(define (do-code x) (define (do-code x)
(record-case x (record-case x
[(clambda-code label cls* free) [(clambda label cls* free)
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(record-case x (record-case x
@ -1307,7 +1311,7 @@
cls*)]) cls*)])
(let ([g (make-code-loc label)]) (let ([g (make-code-loc label)])
(set! all-codes (set! all-codes
(cons (make-clambda-code label cls* free) all-codes)) (cons (make-clambda label cls* free) all-codes))
g))])) g))]))
(define (E x) (define (E x)
(record-case x (record-case x
@ -1533,8 +1537,8 @@
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(make-clambda-code L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -1614,8 +1618,8 @@
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L clauses free) [(clambda L clauses free)
(make-clambda-code L (map CaseExpr clauses) free)])) (make-clambda L (map CaseExpr clauses) free)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -1668,8 +1672,8 @@
x)])) x)]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(make-clambda-code L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -1814,8 +1818,8 @@
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(make-clambda-code L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -2054,9 +2058,9 @@
(make-clambda-case fml* proper (Tail body si r live)))])))) (make-clambda-case fml* proper (Tail body si r live)))]))))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(let ([r (bind-free* free)]) (let ([r (bind-free* free)])
(make-clambda-code L (map (CaseExpr r) cases) free))])) (make-clambda L (map (CaseExpr r) cases) free))]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -2156,8 +2160,8 @@
(make-clambda-case fml* proper (Tail body 0))]))) (make-clambda-case fml* proper (Tail body 0))])))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(make-clambda-code L (map CaseExpr cases) free)])) (make-clambda L (map CaseExpr cases) free)]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
@ -3762,7 +3766,7 @@
(f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) (f (car x*) (cdr x*) (car L*) (cdr L*))))])))))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda-code L cases free) [(clambda L cases free)
(list* (list*
(length free) (length free)
(label L) (label L)