From fec54283fb120467680c4b8af1cecfaaf84c5cd5 Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 7 Dec 2010 20:35:50 -0800 Subject: [PATCH] applicable structs now working, closure table is gone --- collects/stepper/private/annotate.rkt | 82 +++++++++++------------- collects/stepper/private/model.rkt | 1 - collects/stepper/private/reconstruct.rkt | 3 +- collects/stepper/private/shared.rkt | 3 - 4 files changed, 40 insertions(+), 49 deletions(-) diff --git a/collects/stepper/private/annotate.rkt b/collects/stepper/private/annotate.rkt index 0a5fe417e9..729b22e53c 100644 --- a/collects/stepper/private/annotate.rkt +++ b/collects/stepper/private/annotate.rkt @@ -521,20 +521,16 @@ [outer-lambda-abstraction (lambda (annotated-lambda free-varrefs) - (match-let* + (let*-2vals ([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 - ;; 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 + #;[make-ap-struct (lambda (clo debug-info maybe-index) (annotated-proc clo @@ -544,32 +540,37 @@ #f 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) - #`(#%plain-app - #,make-ap-struct - #,annotated-lambda - #,closure-info - #,(cadr procedure-name-info))] + #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info + #,(cadr procedure-name-info))] [else - #`(#%plain-app - #,make-ap-struct - #,annotated-lambda - #,closure-info - #f)])] + #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info + #f)])] ;; gnarr! I can't find a test case ;; that depends on the attachment of the inferred name... [inferred-name-struct (if closure-name (syntax-property - ap-struct-maker + captured 'inferred-name (syntax-e closure-name)) - ap-struct-maker)]) + captured)]) - (normal-bundle free-varrefs - inferred-name-struct)))] + (normal-bundle free-varrefs inferred-name-struct)))] ; @@ @@ -853,24 +854,19 @@ (kernel:kernel-syntax-case exp #f [(#%plain-lambda . clause) - (match-let* - ([(vector annotated-clause free-varrefs) - (lambda-clause-abstraction #'clause)] - [annotated-lambda - (with-syntax ([annotated-clause annotated-clause]) - (syntax/loc exp - (#%plain-lambda . annotated-clause)))]) + (let*-2vals ([(annotated-clause free-varrefs) + (lambda-clause-abstraction (syntax clause))] + [annotated-lambda + (with-syntax ([annotated-clause annotated-clause]) + (syntax/loc exp (#%plain-lambda . annotated-clause)))]) (outer-lambda-abstraction annotated-lambda free-varrefs))] [(case-lambda . clauses) - (match-let* - ([(vector annotated-cases free-varrefs-cases) - (2vals-map lambda-clause-abstraction - (syntax->list (syntax clauses)))] - [annotated-case-lambda - (with-syntax ([annotated-cases annotated-cases]) - (syntax/loc exp (case-lambda . annotated-cases)))] - [free-varrefs (varref-set-union free-varrefs-cases)]) + (let*-2vals ([(annotated-cases free-varrefs-cases) + (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] + [annotated-case-lambda (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))] @@ -1123,7 +1119,7 @@ #,(break-wrap (wcm-wrap app-debug-info - #`(if (#%plain-app #,in-closure-table #,(car tagged-arg-temps)) + #`(if (#%plain-app #,annotated-proc? #,(car tagged-arg-temps)) #,app-term #,(return-value-wrap app-term))))))]) #`(let-values #,let-clauses #,let-body)) diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index a4733a1848..2dc76a4be1 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -322,7 +322,6 @@ (define (step-through-expression expanded expand-next-expression) (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas? language-level)]) - (printf "annotated: ~v\n" (syntax->datum annotated)) (parameterize ([test-engine:test-silence #t]) (eval-syntax annotated)) (expand-next-expression))) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 46f39acb06..6c714627bc 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -110,8 +110,7 @@ (opt-lambda (val render-settings [assigned-name #f]) (if (hash-ref finished-xml-box-table val (lambda () #f)) (stepper-syntax-property #`(quote #,val) 'stepper-xml-value-hint 'from-xml-box) - (let (#;[closure-record (closure-table-lookup val (lambda () #f))] - [closure-record (and (annotated-proc? val) + (let ([closure-record (and (annotated-proc? val) (annotated-proc-info val))]) (if closure-record (let* ([mark (closure-record-mark closure-record)] diff --git a/collects/stepper/private/shared.rkt b/collects/stepper/private/shared.rkt index ecc0523c5e..5cf1c49360 100644 --- a/collects/stepper/private/shared.rkt +++ b/collects/stepper/private/shared.rkt @@ -36,7 +36,6 @@ (provide skipto/auto - in-closure-table sublist attach-info transfer-info @@ -60,8 +59,6 @@ struct-flag multiple-highlight flatten-take - closure-table-put! - closure-table-lookup get-lifted-var get-arg-var begin0-temp