working on begin0
svn: r4914
This commit is contained in:
John Clements
parent
da1163561f
commit
5a795b614c
|
|
@ -452,6 +452,7 @@
|
|||
[wcm-break-wrap (lambda (debug-info exp)
|
||||
(outer-wcm-wrap debug-info (break-wrap exp)))]
|
||||
|
||||
;; used for things that are values:
|
||||
[normal-bundle
|
||||
(lambda (free-vars annotated)
|
||||
(2vals (outer-wcm-wrap (make-debug-info-normal free-vars)
|
||||
|
|
@ -574,6 +575,9 @@
|
|||
; do the whole expansion here. Also, I'm going to make this expansion call/cc-clean,
|
||||
; because I think it'll actually be easier to state & read this way.
|
||||
|
||||
; 2006-11: appears to work now. I'm about to try to transfer this new idiom to begin0;
|
||||
; wish me luck.
|
||||
|
||||
|
||||
[let-abstraction
|
||||
(lambda (stx output-identifier make-init-list)
|
||||
|
|
@ -702,14 +706,21 @@
|
|||
free-varrefs)))]
|
||||
|
||||
|
||||
; :@@$
|
||||
; @:
|
||||
; @@@ @@@ $@$: @@-$+ @@-$+ -@@$ @@@@@
|
||||
; $ $ -@ @$ : @$ : $ -$ @
|
||||
; +: ++ -$@$@ @ @ @@@@@ @
|
||||
; $ $ $* @ @ @ $ @
|
||||
; $:+ @- *@ @ @ +: @
|
||||
; :@ -$$-@@ @@@@@ @@@@@ $@@+ @@@@@
|
||||
|
||||
;
|
||||
;
|
||||
; ;;;
|
||||
; ;
|
||||
; ;
|
||||
; ; ; ;;;; ; ;;; ; ;;; ;;; ;;;;;;
|
||||
; ; ; ; ; ;; ; ;; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;;;;; ;
|
||||
; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ;; ; ; ; ;
|
||||
; ; ;; ; ; ; ;;;; ;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
[varref-abstraction
|
||||
|
|
@ -822,7 +833,45 @@
|
|||
; ;;;;
|
||||
;
|
||||
|
||||
[(begin0 . bodies-stx)
|
||||
;; one-element begin0 is a special case, because in this case only
|
||||
;; the body of the begin0 is in tail position.
|
||||
|
||||
[(begin0 body)
|
||||
(let*-2vals ([(annotated-body free-vars-body)
|
||||
(tail-recur #'body)])
|
||||
(2vals (wcm-break-wrap (make-debug-info-normal free-vars-body)
|
||||
(quasisyntax/loc exp (begin0 #,annotated-body)))
|
||||
free-vars-body))]
|
||||
|
||||
#;(let unroll-loop ([bodies-list bodies-list] [outermost? #t])
|
||||
(cond [(null? bodies-list)
|
||||
(error 'annotate "no bodies in let")]
|
||||
[(null? (cdr bodies-list))
|
||||
(tail-recur (car bodies-list))]
|
||||
[else
|
||||
(let*-2vals
|
||||
([(rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)]
|
||||
[(this-one free-vars-this) (non-tail-recur (car bodies-list))]
|
||||
[free-vars-all (varref-set-union (list free-vars-rest free-vars-this))]
|
||||
[debug-info (make-debug-info-fake-exp
|
||||
#`(begin #,@bodies-list)
|
||||
free-vars-all)]
|
||||
[begin-form #`(begin #,(normal-break/values-wrap this-one) #,rest)])
|
||||
(2vals (if outermost?
|
||||
(wcm-wrap debug-info begin-form)
|
||||
(wcm-pre-break-wrap debug-info begin-form))
|
||||
free-vars-all))]))
|
||||
|
||||
#;[(begin0 first-body . bodies-stx)
|
||||
(let*-2vals ([(annotated-first free-vars-first) (result-recur first-body)])
|
||||
#`(let ([,begin0-temp #,annotated-first])
|
||||
#,unrolled-rest))
|
||||
(let unroll-loop ([bodies-list (syntax->list #`(first-body . bodies-stx))] [outermost? #t])
|
||||
(cond [(null? bodies-list)
|
||||
(error 'annotate "this case should have been handled by the zero-body annotation")]
|
||||
[(null? (cdr bodies-list))
|
||||
(let*-2vals
|
||||
([(this-one free-vars-this) (non-tail-recur)]))]))
|
||||
(let*-2vals
|
||||
([bodies (syntax->list (syntax bodies-stx))]
|
||||
[(annotated-first free-varrefs-first)
|
||||
|
|
@ -832,13 +881,22 @@
|
|||
(normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets))
|
||||
(quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))]
|
||||
|
||||
;; special case for the expansion of begin.
|
||||
;; more efficient, but disabled because of difficulties in threading it through the
|
||||
;; reconstruction. Easier to undo in the macro-unwind phase.
|
||||
#;[(let-values () . bodies-stx)
|
||||
(eq? (stepper-syntax-property exp 'stepper-hint) 'comes-from-begin)
|
||||
(begin-abstraction (syntax->list #`bodies-stx))]
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;; ;;;
|
||||
; ; ; ;
|
||||
; ; ; ;
|
||||
; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;; ; ; ;; ; ; ;
|
||||
; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
[(let-values . _)
|
||||
(let-abstraction exp
|
||||
#`let-values
|
||||
|
|
|
|||
|
|
@ -772,44 +772,21 @@
|
|||
;; advanced-begin : okay, here comes advanced-begin.
|
||||
|
||||
[(begin . terms)
|
||||
;; copied from app:
|
||||
(error 'reconstruct/inner "how did we get here?")
|
||||
|
||||
#;(attach-info
|
||||
(let* ([sub-exprs (syntax->list (syntax terms))]
|
||||
[arg-temps (build-list (length sub-exprs) get-arg-var)]
|
||||
[arg-vals (map (lambda (arg-temp)
|
||||
(lookup-binding mark-list arg-temp))
|
||||
arg-temps)])
|
||||
(case (mark-label (car mark-list))
|
||||
((not-yet-called)
|
||||
(let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
|
||||
(zip sub-exprs arg-vals))]
|
||||
[rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))])
|
||||
(if (null? unevaluated)
|
||||
#`(#%app . #,rectified-evaluated)
|
||||
#`(#%app
|
||||
#,@rectified-evaluated
|
||||
#,so-far
|
||||
#,@(map recon-source-current-marks (cdr (map car unevaluated)))))))
|
||||
((called)
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code
|
||||
(datum->syntax-object #'here `(,#'#%app ... ,so-far ...))))
|
||||
(else
|
||||
(error "bad label in application mark in expr: ~a" exp))))
|
||||
exp)]
|
||||
;; even in advanced, begin expands into a let-values.
|
||||
(error 'reconstruct/inner "begin in non-teaching-languages not implemented in reconstruct")]
|
||||
|
||||
; begin : in the current expansion of begin, there are only two-element begin's, one-element begins, and
|
||||
;; zero-element begins; these arise as the expansion of ... ?
|
||||
|
||||
[(begin stx-a stx-b)
|
||||
;; these are all dead code, right?
|
||||
|
||||
#;[(begin stx-a stx-b)
|
||||
(attach-info
|
||||
(if (eq? so-far nothing-so-far)
|
||||
#`(begin #,(recon-source-current-marks #`stx-a) #,(recon-source-current-marks #`stx-b))
|
||||
#`(begin #,so-far #,(recon-source-current-marks #`stx-b))))]
|
||||
|
||||
[(begin clause)
|
||||
#;[(begin clause)
|
||||
(attach-info
|
||||
(if (eq? so-far nothing-so-far)
|
||||
#`(begin #,(recon-source-current-marks (syntax clause)))
|
||||
|
|
@ -818,7 +795,7 @@
|
|||
"stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp)))
|
||||
exp)]
|
||||
|
||||
[(begin)
|
||||
#;[(begin)
|
||||
(attach-info
|
||||
(if (eq? so-far nothing-so-far)
|
||||
#`(begin)
|
||||
|
|
@ -826,8 +803,13 @@
|
|||
'recon-inner
|
||||
"stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax-object->datum exp))))]
|
||||
|
||||
; begin0 : may not occur directly except in advanced
|
||||
#;[(begin0 )]
|
||||
; begin0 :
|
||||
;; one-body begin0: perhaps this will turn out to be a special case of the
|
||||
;; many-body case.
|
||||
[(begin0 body)
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(recon-source-current-marks exp)
|
||||
(error 'recon-inner "one-body begin0 given as context: ~a" exp))]
|
||||
|
||||
; let-values
|
||||
|
||||
|
|
|
|||
|
|
@ -21,18 +21,18 @@
|
|||
(and (syntax? v)
|
||||
((flat-contract-predicate (cons/c identifier? arglist?)) (syntax-e v)))))
|
||||
|
||||
(provide/contract
|
||||
;[varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)]
|
||||
;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
|
||||
;[binding-set-union (-> (listof binding-set?) binding-set?)]
|
||||
;[varref-set-union (-> (listof varref-set?) varref-set?)]
|
||||
#;[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)]
|
||||
#;[in-closure-table (-> any/c boolean?)]
|
||||
#;[sublist (-> number? number? list? list?)]
|
||||
#;[attach-info (-> syntax? syntax? syntax?)]
|
||||
#;[transfer-info (-> syntax? syntax? syntax?)]
|
||||
#;[arglist->ilist (-> arglist? any)]
|
||||
#;[arglist-flatten (-> arglist? (listof identifier?))])
|
||||
#;(provide/contract
|
||||
[varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)]
|
||||
[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
|
||||
[binding-set-union (-> (listof binding-set?) binding-set?)]
|
||||
[varref-set-union (-> (listof varref-set?) varref-set?)]
|
||||
[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)]
|
||||
[in-closure-table (-> any/c boolean?)]
|
||||
[sublist (-> number? number? list? list?)]
|
||||
[attach-info (-> syntax? syntax? syntax?)]
|
||||
[transfer-info (-> syntax? syntax? syntax?)]
|
||||
[arglist->ilist (-> arglist? any)]
|
||||
[arglist-flatten (-> arglist? (listof identifier?))])
|
||||
|
||||
(provide
|
||||
skipto/auto
|
||||
|
|
@ -66,6 +66,7 @@
|
|||
closure-table-lookup
|
||||
get-lifted-var
|
||||
get-arg-var
|
||||
begin0-temp
|
||||
zip
|
||||
let-counter
|
||||
syntax-pair-map
|
||||
|
|
@ -174,6 +175,7 @@
|
|||
; (eq? arg2 arg2p)
|
||||
; (not (eq? arg1 arg2p)))))
|
||||
|
||||
(define begin0-temp (create-bogus-binding "begin0-temp"))
|
||||
|
||||
; get-lifted-var maintains the mapping between let-bindings and the syntax object
|
||||
; which is used to capture its index at runtime.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user