Keep track of lambda's with continuations

This commit is contained in:
Justin Ethier 2017-05-04 06:50:09 +00:00
parent c7aa3700ea
commit 3bd5d52671
3 changed files with 20 additions and 10 deletions

View file

@ -21,16 +21,21 @@
ast:set-lambda-args!
ast:lambda-body
ast:set-lambda-body!
ast:lambda-has-cont
ast:set-lambda-has-cont!
)
(begin
(define *lambda-id* 0)
(define-record-type <lambda-ast>
(ast:%make-lambda id args body)
(ast:%make-lambda id args body has-cont)
ast:lambda?
(id ast:lambda-id)
(args ast:lambda-args ast:set-lambda-args!)
(body ast:lambda-body ast:set-lambda-body!))
(define (ast:make-lambda args body)
(set! *lambda-id* (+ 1 *lambda-id*))
(ast:%make-lambda *lambda-id* args body))
(body ast:lambda-body ast:set-lambda-body!)
(has-cont ast:lambda-has-cont ast:set-lambda-has-cont!)
)
(define (ast:make-lambda args body . opts)
(let ((has-cont (if (pair? opts) (car opts) #f)))
(set! *lambda-id* (+ 1 *lambda-id*))
(ast:%make-lambda *lambda-id* args body has-cont)))
))

View file

@ -598,7 +598,8 @@
(ast:%make-lambda
(ast:lambda-id exp)
(ast:lambda-args exp)
(opt:contract (ast:lambda-body exp))))))
(opt:contract (ast:lambda-body exp))
(ast:lambda-has-cont exp)))))
((const? exp) exp)
((ref? exp)
(let ((var (adb:get/default exp #f)))
@ -652,7 +653,8 @@
(ast:%make-lambda
(ast:lambda-id fnc)
(reverse new-params)
(ast:lambda-body fnc))
(ast:lambda-body fnc)
(ast:lambda-has-cont fnc))
(map
opt:contract
(reverse new-args)))))
@ -683,7 +685,8 @@
(ast:%make-lambda
(ast:lambda-id exp)
(ast:lambda-args exp)
(map (lambda (b) (opt:inline-prims b refs)) (ast:lambda-body exp))))
(map (lambda (b) (opt:inline-prims b refs)) (ast:lambda-body exp))
(ast:lambda-has-cont exp)))
((const? exp) exp)
((quote? exp) exp)
((define? exp)

View file

@ -1300,7 +1300,8 @@
(let ((k (gensym 'k)))
(list (ast:make-lambda
(list k)
(list (xform k)))
(list (xform k))
#t)
cont-ast)))))
((prim-call? ast)
@ -1327,7 +1328,8 @@
(if (equal? ltype 'args:varargs)
'args:fixed-with-varargs ;; OK? promote due to k
ltype))
(list (cps-seq (cddr ast) k))))))
(list (cps-seq (cddr ast) k))
#t))))
((app? ast)
;; Syntax check the function