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

applicable structs now working, closure table is gone

Browse Source
This commit is contained in:
John Clements 2010-12-07 20:35:50 -08:00
parent 9eaee0e6f1
commit fec54283fb
4 changed files with 40 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/stepper/private/annotate.rkt
View File

@ -521,20 +521,16 @@
[outer-lambda-abstraction [outer-lambda-abstraction
(lambda (annotated-lambda free-varrefs) (lambda (annotated-lambda free-varrefs)
(match-let* (let*-2vals
([closure-info (make-debug-info-app 'all free-varrefs 'none)] ([closure-info (make-debug-info-app 'all free-varrefs 'none)]
;; if we manually disable the storage of names, lambdas get rendered as lambdas.
[closure-name (if show-lambdas-as-lambdas?
#f
(cond [(syntax? procedure-name-info) procedure-name-info]
[(pair? procedure-name-info) (car procedure-name-info)]
[else #f]))]
;; if we manually disable the storage of #;[make-ap-struct
;; names, lambdas get rendered as lambdas.
[closure-name
(if show-lambdas-as-lambdas?
#f
(cond [(syntax? procedure-name-info) procedure-name-info]
[(pair? procedure-name-info)
(car procedure-name-info)]
[else #f]))]
[make-ap-struct
(lambda (clo debug-info maybe-index) (lambda (clo debug-info maybe-index)
(annotated-proc (annotated-proc
clo clo
@ -544,32 +540,37 @@
#f #f
maybe-index)))] maybe-index)))]
[ap-struct-maker
[closure-storing-proc
(lambda (clo debug-info maybe-index)
(annotated-proc
clo
(make-closure-record
closure-name
debug-info
#f
maybe-index)))]
[captured
(cond [(pair? procedure-name-info) (cond [(pair? procedure-name-info)
#`(#%plain-app #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info
#,make-ap-struct #,(cadr procedure-name-info))]
#,annotated-lambda
#,closure-info
#,(cadr procedure-name-info))]
[else [else
#`(#%plain-app #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info
#,make-ap-struct #f)])]
#,annotated-lambda
#,closure-info
#f)])]
;; gnarr! I can't find a test case ;; gnarr! I can't find a test case
;; that depends on the attachment of the inferred name... ;; that depends on the attachment of the inferred name...
[inferred-name-struct [inferred-name-struct
(if closure-name (if closure-name
(syntax-property (syntax-property
ap-struct-maker captured
'inferred-name 'inferred-name
(syntax-e closure-name)) (syntax-e closure-name))
ap-struct-maker)]) captured)])
(normal-bundle free-varrefs (normal-bundle free-varrefs inferred-name-struct)))]
inferred-name-struct)))]
; @@ ; @@
@ -853,24 +854,19 @@
(kernel:kernel-syntax-case exp #f (kernel:kernel-syntax-case exp #f
[(#%plain-lambda . clause) [(#%plain-lambda . clause)
(match-let* (let*-2vals ([(annotated-clause free-varrefs)
([(vector annotated-clause free-varrefs) (lambda-clause-abstraction (syntax clause))]
(lambda-clause-abstraction #'clause)] [annotated-lambda
[annotated-lambda (with-syntax ([annotated-clause annotated-clause])
(with-syntax ([annotated-clause annotated-clause]) (syntax/loc exp (#%plain-lambda . annotated-clause)))])
(syntax/loc exp
(#%plain-lambda . annotated-clause)))])
(outer-lambda-abstraction annotated-lambda free-varrefs))] (outer-lambda-abstraction annotated-lambda free-varrefs))]
[(case-lambda . clauses) [(case-lambda . clauses)
(match-let* (let*-2vals ([(annotated-cases free-varrefs-cases)
([(vector annotated-cases free-varrefs-cases) (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
(2vals-map lambda-clause-abstraction [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
(syntax->list (syntax clauses)))] (syntax/loc exp (case-lambda . annotated-cases)))]
[annotated-case-lambda [free-varrefs (varref-set-union free-varrefs-cases)])
(with-syntax ([annotated-cases annotated-cases])
(syntax/loc exp (case-lambda . annotated-cases)))]
[free-varrefs (varref-set-union free-varrefs-cases)])
(outer-lambda-abstraction annotated-case-lambda free-varrefs))] (outer-lambda-abstraction annotated-case-lambda free-varrefs))]
@ -1123,7 +1119,7 @@
#,(break-wrap #,(break-wrap
(wcm-wrap (wcm-wrap
app-debug-info app-debug-info
#`(if (#%plain-app #,in-closure-table #,(car tagged-arg-temps)) #`(if (#%plain-app #,annotated-proc? #,(car tagged-arg-temps))
#,app-term #,app-term
#,(return-value-wrap app-term))))))]) #,(return-value-wrap app-term))))))])
#`(let-values #,let-clauses #,let-body)) #`(let-values #,let-clauses #,let-body))

1
collects/stepper/private/model.rkt
View File

@ -322,7 +322,6 @@
(define (step-through-expression expanded expand-next-expression) (define (step-through-expression expanded expand-next-expression)
(let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?
language-level)]) language-level)])
(printf "annotated: ~v\n" (syntax->datum annotated))
(parameterize ([test-engine:test-silence #t]) (parameterize ([test-engine:test-silence #t])
(eval-syntax annotated)) (eval-syntax annotated))
(expand-next-expression))) (expand-next-expression)))

3
collects/stepper/private/reconstruct.rkt
View File

@ -110,8 +110,7 @@
(opt-lambda (val render-settings [assigned-name #f]) (opt-lambda (val render-settings [assigned-name #f])
(if (hash-ref finished-xml-box-table val (lambda () #f)) (if (hash-ref finished-xml-box-table val (lambda () #f))
(stepper-syntax-property #`(quote #,val) 'stepper-xml-value-hint 'from-xml-box) (stepper-syntax-property #`(quote #,val) 'stepper-xml-value-hint 'from-xml-box)
(let (#;[closure-record (closure-table-lookup val (lambda () #f))] (let ([closure-record (and (annotated-proc? val)
[closure-record (and (annotated-proc? val)
(annotated-proc-info val))]) (annotated-proc-info val))])
(if closure-record (if closure-record
(let* ([mark (closure-record-mark closure-record)] (let* ([mark (closure-record-mark closure-record)]

3
collects/stepper/private/shared.rkt
View File

@ -36,7 +36,6 @@
(provide (provide
skipto/auto skipto/auto
in-closure-table
sublist sublist
attach-info attach-info
transfer-info transfer-info
@ -60,8 +59,6 @@
struct-flag struct-flag
multiple-highlight multiple-highlight
flatten-take flatten-take
closure-table-put!
closure-table-lookup
get-lifted-var get-lifted-var
get-arg-var get-arg-var
begin0-temp begin0-temp