suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

about to write the unsplicing code.

Browse Source
This commit is contained in:
Danny Yoo 2011-04-11 15:26:10 -04:00
parent f76bec0d13
commit c67fe8ab31
3 changed files with 102 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
compile.rkt
View File

@ -116,9 +116,10 @@
(append (map (lambda: ([d : Natural])
(list-ref cenv d))
(Lam-closure-map lam))
(build-list (Lam-num-parameters lam) (lambda: ([i : Natural]) '?))))
(build-list (if (Lam-rest? lam)
(add1 (Lam-num-parameters lam))
(Lam-num-parameters lam))
(lambda: ([i : Natural]) '?))))
@ -338,7 +339,9 @@
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (Lam-entry-label exp)
(Lam-num-parameters exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp))
(Lam-closure-map exp)
(Lam-name exp)))))))
@ -354,7 +357,9 @@
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedureShell (Lam-entry-label exp)
(Lam-num-parameters exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp))
(Lam-name exp)))))))
@ -362,22 +367,29 @@
;; Compiles the body of the lambda in the appropriate environment.
;; Closures will target their value to the 'val register, and use return linkage.
(define (compile-lambda-body exp cenv)
(append-instruction-sequences
(make-instruction-sequence
`(,(Lam-entry-label exp)))
(if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence)
(compile (Lam-body exp)
(append (map (lambda: ([d : Natural])
(list-ref cenv d))
(Lam-closure-map exp))
(build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?)))
'val
return-linkage)))
(let: ([maybe-unsplice-rest-argument : InstructionSequence
(if (Lam-rest? exp)
;; FIXME: we may need to unsplice the rest argument if this lambda is a rest
(error 'fixme)
empty-instruction-sequence)]
[maybe-install-closure-values : InstructionSequence
(if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence
`(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence)]
[lam-body-code : InstructionSequence
(compile (Lam-body exp)
(extract-lambda-cenv exp cenv)
'val
return-linkage)])
(append-instruction-sequences
(make-instruction-sequence
`(,(Lam-entry-label exp)))
maybe-unsplice-rest-argument
maybe-install-closure-values
lam-body-code)))

46
parse.rkt
View File

@ -183,12 +183,20 @@
(parse b body-cenv #f))
(lambda-body exp)))
mutated-parameters)])
(make-Lam (current-defined-name)
(length (lambda-parameters exp))
#f
lam-body
(map env-reference-depth closure-references)
(fresh-lam-label)))))
(cond [(lambda-has-rest-parameter? exp)
(make-Lam (current-defined-name)
(sub1 (length (lambda-parameters exp)))
#t
lam-body
(map env-reference-depth closure-references)
(fresh-lam-label))]
[else
(make-Lam (current-defined-name)
(length (lambda-parameters exp))
#f
lam-body
(map env-reference-depth closure-references)
(fresh-lam-label))]))))
(define lam-label-counter 0)
@ -378,7 +386,31 @@
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
;; lambda-parameters: lambda-expression -> (listof identifier)
(define (lambda-parameters exp)
(let loop ([params (cadr exp)])
(cond
[(null? params)
empty]
[(pair? params)
(cons (car params)
(loop (cdr params)))]
[else
(list params)])))
;; Produces true if the lambda's last parameter is a rest parameter.
(define (lambda-has-rest-parameter? exp)
(let loop ([params (cadr exp)])
(cond
[(null? params)
#f]
[(pair? params)
(loop (cdr params))]
[else
#t])))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)

30
test-parse.rkt
View File

@ -87,6 +87,36 @@
(make-ToplevelRef 0 1)
(make-Constant "ok"))))
(test (parse '(lambda () x))
(make-Top (make-Prefix '(x))
(make-Lam #f 0 #f (make-ToplevelRef 0 0)
'(0) 'lamEntry1)))
(test (parse '(lambda args args))
(make-Top (make-Prefix '())
(make-Lam #f 0 #t (make-LocalRef 0 #f)
'() 'lamEntry1)))
(test (parse '(lambda (x y . z) x))
(make-Top (make-Prefix '())
(make-Lam #f 2 #t
(make-LocalRef 0 #f)
'() 'lamEntry1)))
(test (parse '(lambda (x y . z) y))
(make-Top (make-Prefix '())
(make-Lam #f 2 #t
(make-LocalRef 1 #f)
'() 'lamEntry1)))
(test (parse '(lambda (x y . z) z))
(make-Top (make-Prefix '())
(make-Lam #f 2 #t
(make-LocalRef 2 #f)
'() 'lamEntry1)))
(test (parse '(lambda (x y z) x))
(make-Top (make-Prefix '())
(make-Lam #f 3 #f (make-LocalRef 0 #f) '() 'lamEntry1)))