diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index 449353e213..eaf779f8e4 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -219,6 +219,9 @@ stepper-highlight : this expression will be highlighted. (Not currently tranferred...?) +stepper-fake-exp : + this expression does not occur directly in the source; reconstruct specially. + used for begin. STEPPER-HINT COLLISIONS diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 9d1df726ac..cbffe69163 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -31,6 +31,19 @@ (union any/c (symbols 'testing)); language-level . -> . syntax?)] ; results + + [annotate/not-top-level ;; SAME CONTRACT AS ANNOTATE! + (syntax? ; syntax to annotate + (((or/c continuation-mark-set? false/c) + break-kind?) + (list?) + . opt->* . + (any/c)) ; procedure for runtime break + boolean? ; track-inferred-name? + (union any/c (symbols 'testing)); language-level + . -> . + syntax?)] ; results + #;[top-level-rewrite (-> syntax? syntax?)]) ; ;; ;;;; ; @@ -255,13 +268,8 @@ ; - ; annotate takes - ; a) a list of syntax expressions - ; b) a break routine to be called at breakpoints, and - ; c) a boolean indicating whether to store inferred names. - ; - (define (annotate main-exp break track-inferred-names? language-level) + (define ((annotate/master input-is-top-level?) main-exp break track-inferred-names? language-level) #;(define _ (fprintf (current-error-port) "input to annotate: ~v\n" (syntax-object->datum main-exp))) (define binding-indexer @@ -331,7 +339,7 @@ (define (top-level-annotate/inner exp source-exp defined-name) (let*-2vals ([(annotated dont-care) - (annotate/inner exp 'all #f defined-name #f)]) + (annotate/inner exp 'all #f defined-name)]) #`(with-continuation-mark #,debug-key #,(make-top-level-mark source-exp) ;; inserting eta-expansion to prevent destruction of top-level mark @@ -373,7 +381,7 @@ (define annotate/inner #;(syntax? binding-set? boolean? (or/c false/c syntax? (list/p syntax? syntax?)) (or/c false/c integer?) . -> . (vector/p syntax? binding-set?)) - (lambda (exp tail-bound pre-break? procedure-name-info offset-counter) + (lambda (exp tail-bound pre-break? procedure-name-info) (cond [(syntax-property exp 'stepper-skipto) (let* ([free-vars-captured #f] ; this will be set!'ed @@ -383,7 +391,7 @@ exp 'rebuild (lambda (subterm) - (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info offset-counter)]) + (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) (set! free-vars-captured free-vars) stx)))]) (2vals (wcm-wrap @@ -397,50 +405,33 @@ [else (let* ;; recurrence procedures, used to recur on sub-expressions: - ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info #f))] - [non-tail-recur (lambda (exp) (annotate/inner exp null #f #f #f))] - [result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info #f))] - [set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name #f))] + ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))] + [non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))] + [result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))] + [set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))] [let-rhs-recur (lambda (exp binding-names dyn-index-syms) (let* ([proc-name-info (if (not (null? binding-names)) (list (car binding-names) (car dyn-index-syms)) #f)]) - (annotate/inner exp null #f proc-name-info #f)))] - [lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f #f))] + (annotate/inner exp null #f proc-name-info)))] + [lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))] ; let bodies have a startling number of recurrence patterns. ouch! + ;; ... looks like these can maybe be collapsed with a simpler desired reduction sequence + ;; (a.k.a. not safe-for-space). ;; no pre-break, tail w.r.t. new bindings: [let-body-recur/single (lambda (exp bindings) - (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info #f))] - - ;; no pre-break, non-tail w.r.t. new bindings - [let-body-recur/first - (lambda (exp-n-index) - (apply-to-first-of-2vals - normal-break/values-wrap - (annotate/inner (car exp-n-index) null #f #f (cadr exp-n-index))))] - - ;; yes pre-break, non-tail w.r.t. new bindings - [let-body-recur/middle - (lambda (exp-n-index) - (apply-to-first-of-2vals - normal-break/values-wrap - (annotate/inner (car exp-n-index) null #t #f (cadr exp-n-index))))] - - ;; yes pre-break, tail w.r.t. new bindings: - [let-body-recur/last - (lambda (exp-n-index bindings) - (annotate/inner (car exp-n-index) (binding-set-union (list tail-bound bindings)) #t procedure-name-info (cadr exp-n-index)))] + (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info))] ;; different flavors of make-debug-info allow users to provide only the needed fields: [make-debug-info-normal (lambda (free-bindings) - (make-debug-info exp tail-bound free-bindings 'none #t offset-counter))] + (make-debug-info exp tail-bound free-bindings 'none #t))] [make-debug-info-app (lambda (tail-bound free-bindings label) - (make-debug-info exp tail-bound free-bindings label #t offset-counter))] + (make-debug-info exp tail-bound free-bindings label #t))] [make-debug-info-let (lambda (free-bindings binding-list let-counter) (make-debug-info exp (binding-set-union (list tail-bound @@ -450,8 +441,11 @@ binding-list (list let-counter))) ; NB using bindings as varrefs 'let-body - #t - offset-counter))] + #t))] + [make-debug-info-fake-exp (lambda (exp free-bindings) + (make-debug-info (syntax-property exp 'stepper-fake-exp #t) + tail-bound free-bindings 'none #t))] + [outer-wcm-wrap (if pre-break? wcm-pre-break-wrap wcm-wrap)] @@ -463,14 +457,6 @@ (2vals (outer-wcm-wrap (make-debug-info-normal free-vars) annotated) free-vars))] - - ;; taken from SRFI 1: - [iota - (lambda (n) (build-list n (lambda (x) x)))] - - [with-indices - (lambda (exps) - (map list exps (iota (length exps))))] ; @@ @@ @@ @@ -600,24 +586,29 @@ [lifted-vars (apply append lifted-var-sets)] [(annotated-vals free-varref-sets-vals) (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)] - [bodies-list (with-indices (syntax->list #'bodies))] + [bodies-list (syntax->list #'bodies)] [(annotated-body free-varrefs-body) (if (= (length bodies-list) 1) - (let-body-recur/single (caar bodies-list) binding-list) - ;; like a map, but must special-case first and last exps: - (let*-2vals - ([first (car bodies-list)] - [reversed-rest (reverse (cdr bodies-list))] - [middle (reverse (cdr reversed-rest))] - [last (car reversed-rest)] - - [(first* fv-first) (let-body-recur/first first)] - [(middle* fv-middle) (2vals-map let-body-recur/middle middle)] - [(last* fv-last) (let-body-recur/last last binding-list)]) - - (2vals (quasisyntax/loc exp - (begin #,first* #,@middle* #,last*)) - (varref-set-union (cons fv-first (cons fv-last fv-middle))))))]) + (let-body-recur/single (car bodies-list) binding-list) + ;; oh dear lord, we have to unfold these like an application: + (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))])))]) ((2vals (quasisyntax/loc exp @@ -667,51 +658,13 @@ (#,exp-finished-break #,exp-finished-clauses) #,annotated-body)))])))))] - ;; pulling out begin abstraction! - ;;; bLECCh! I think I can do this with a MAP, rather than a fold. - #;[begin-abstraction - (lambda (bodies) - - (if - (null? bodies) - (normal-bundle null exp) - - ((outer-begin-wrap - (foldl another-body-wrap wrapped-final remaining-reversed-bodies index-list)) - - . where . - - ([another-body-wrap - (lambda (next-body index stx-n-freevars) - (let*-2vals - ([(seed-stx free-vars-so-far) stx-n-freevars] - [(annotated-next-body free-vars-next-body) (non-tail-recur next-body)] - [free-vars-union (varref-set-union (list free-vars-so-far free-vars-next-body))] - [inner-wrapped (wcm-wrap - (make-debug-info-app (binding-set-union (list tail-bound (list begin-temp))) - (varref-set-union (list free-vars-so-far (list begin-temp))) - (list 'begin index)) - (break-wrap (pre-break-wrap seed-stx)))]) - (2vals #`(let ([#,begin-temp #,annotated-next-body]) - #,inner-wrapped) - free-vars-union)))] - - [outer-begin-wrap - (lambda (stx-n-free-vars) - (let*-2vals ([(stx free-vars) stx-n-free-vars]) - (2vals (wcm-wrap - (make-debug-info-app tail-bound free-vars (list 'begin (length bodies))) - stx) - free-vars)))] - - [all-bodies-reversed (reverse bodies)] - [final-body (car all-bodies-reversed)] - [remaining-reversed-bodies (cdr all-bodies-reversed)] - [index-list (build-list (length remaining-reversed-bodies) (lambda (x) (+ x 1)))] - - [wrapped-final (tail-recur final-body)]))) - - )] + + + + + + + ; @ :@@$ @@ -830,12 +783,45 @@ [(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))] [(if test then) (if-abstraction (syntax test) (syntax then) #f)] + + + ; + ; + ; ; ; + ; ; + ; ; + ; ; ;; ;;; ;;;; ;;; ; ;; + ; ;; ; ; ; ; ; ; ;; ; + ; ; ; ;;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ;; ; ; ; + ; ;;;; ;;;; ;; ; ;;; ; ; + ; ; + ; ;;;; + ; + [(begin . bodies-stx) (begin (error 'annotate-inner "nothing expands into begin! : ~v" (syntax-object->datum exp)) #;(begin-abstraction (syntax->list #`bodies-stx)))] + + ; + ; + ; ; ; ;; + ; ; ; ; + ; ; ; ;; + ; ; ;; ;;; ;;;; ;;; ; ;; ; ; ; + ; ;; ; ; ; ; ; ; ;; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ;; ; + ; ; ; ; ; ;; ; ; ; ;; ; + ; ;;;; ;;;; ;; ; ;;; ; ; ;; + ; ; + ; ;;;; + ; + [(begin0 . bodies-stx) (let*-2vals ([bodies (syntax->list (syntax bodies-stx))] @@ -980,6 +966,9 @@ ; occur after all vars have been evaluated. I suppose you could do (wcm ... (begin v0 ... (v0 ...))) ; where the second set are not annotated ... but stepper runtime is not at a premium. + ;; the call/cc-safe version of this appears to work, and it lives in the definition of let. I should + ;; transfer that knowledge to here. -- JBC, 2006-10-11 + [(#%app . terms) (let*-2vals ([(annotated-terms free-varrefs-terms) @@ -1147,11 +1136,21 @@ #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax-object->datum exp))])]))) ; body of local - (let* ([annotated-exp (cond - [(and (not (eq? language-level 'testing)) - (string=? (language-level->name language-level) "ACL2 Beginner (beta 8)")) - (annotate/top-level/acl2 main-exp)] - [else - (annotate/top-level main-exp)])]) - #;(printf "annotated: \n~a\n" (syntax-object->datum annotated-exp)) - annotated-exp))) + (if input-is-top-level? + (let* ([annotated-exp (cond + [(and (not (eq? language-level 'testing)) + (string=? (language-level->name language-level) "ACL2 Beginner (beta 8)")) + (annotate/top-level/acl2 main-exp)] + [else + (annotate/top-level main-exp)])]) + #;(printf "annotated: \n~a\n" (syntax-object->datum annotated-exp)) + annotated-exp) + (annotate/inner main-exp 'all #f #f))) + + ;; !@#$ defs have to appear after annotate/master. + (define annotate (annotate/master #t)) + (define annotate/not-top-level (annotate/master #f)) + + + +) diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss index d9d3c36791..970c4d2128 100644 --- a/collects/stepper/private/lifting.ss +++ b/collects/stepper/private/lifting.ss @@ -48,6 +48,13 @@ (lambda (offset subtries) (try (lambda (index) (list (+ offset index))) subtries)))) + ;; WHOA: this code uses the template for fully-expanded syntax; what the code + ;; actually gets is reconstructed code. This is a problem, because you can't + ;; distinguish a top-level begin from one that's the result of some evaluation. + ;; I think for the moment that it will solve our problem simply to remove the + ;; special case for begin at the top level. JBC, 2006-10-09 + + (define (top-level-expr-iterator stx context-so-far) (let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))]) (kernel:kernel-syntax-case stx #f @@ -71,7 +78,9 @@ (try 2 `((,expr-iterator ,#'expr)))] [(define-syntaxes (var ...) expr) (try 2 `((,expr-iterator ,#'expr)))] - [(begin . top-level-exprs) + ;; this code is buggy, but I believe it doesn't belong here at all + ;; per above discussion. JBC, 2006-10-09 + #;[(begin . top-level-exprs) (try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr)) (syntax->list #'exprs)))] [(require . require-specs) diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss index a9b65fbae6..daebbba909 100644 --- a/collects/stepper/private/macro-unwind.ss +++ b/collects/stepper/private/macro-unwind.ss @@ -82,7 +82,7 @@ [(comes-from-or) (unwind-and/or 'or)] [(comes-from-local) unwind-local] [(comes-from-recur) unwind-recur] - [(comes-from-begin) unwind-begin] + ;;[(comes-from-begin) unwind-begin] [else fall-through])]) (process stx)))) stx)) @@ -246,12 +246,13 @@ (syntax-object->datum stx))))]) (syntax (cond . clauses))))) - (define (unwind-begin stx) - (syntax-case stx (let-values) - [(let-values () body ...) - (with-syntax ([(new-body ...) - (map unwind (syntax->list #`(body ...)))]) - #`(begin new-body ...))])) + ;; unused: the fake-exp begin takes care of this for us... + #;(define (unwind-begin stx) + (syntax-case stx (let-values) + [(let-values () body ...) + (with-syntax ([(new-body ...) + (map unwind (syntax->list #`(body ...)))]) + #`(begin new-body ...))])) (define ((unwind-and/or label) stx) (let ([user-source (syntax-property stx 'user-source)] diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss index 182a6db992..20bb4a60ec 100644 --- a/collects/stepper/private/marks.ss +++ b/collects/stepper/private/marks.ss @@ -13,7 +13,7 @@ (define mark-list? (listof procedure?)) (provide/contract - ;[make-debug-info (-> any/c binding-set? varref-set? any/c boolean? syntax?)] ; (location tail-bound free label lifting? offset-index -> mark-stx) + ;[make-debug-info (any/c binding-set? varref-set? any/c boolean? . -> . syntax?)] ; (location tail-bound free label lifting? -> mark-stx) [expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))] [make-top-level-mark (syntax? . -> . syntax?)] [lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))] @@ -159,7 +159,7 @@ ;; ;;;;;;;;;; - (define (make-debug-info source tail-bound free-vars label lifting? offset-index) + (define (make-debug-info source tail-bound free-vars label lifting?) (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) (if lifting? (let*-2vals ([let-bindings (filter (lambda (var) @@ -172,9 +172,9 @@ (syntax-property var 'stepper-binding-type))))) kept-vars)] [lifter-syms (map get-lifted-var let-bindings)]) - (make-full-mark (syntax-property source 'stepper-offset-index offset-index) label (append kept-vars lifter-syms))) + (make-full-mark source label (append kept-vars lifter-syms))) ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC - (make-full-mark (syntax-property source 'stepper-offset-index offset-index) label kept-vars)))) + (make-full-mark source label kept-vars)))) (define (make-top-level-mark source-expr) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 1bb381aeab..569c1d115b 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -330,11 +330,5 @@ (if (eof-object? expanded) (begin (receive-result (make-finished-stepping))) - (step-through-expression expanded continue-thunk))))) - - - (define (first-of-one x) - (unless (and (pair? x) (null? (cdr x))) - (error 'first-of-one "expected a list of length one in: ~v" x)) - (car x))) + (step-through-expression expanded continue-thunk)))))) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 826936d76a..231ec93ed3 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -682,162 +682,173 @@ bodies (iota (length bodies)))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) - (kernel:kernel-syntax-case exp #f - ; variable references - [id - (identifier? (syntax id)) - (if (eq? so-far nothing-so-far) - (recon-source-current-marks exp) - (error 'recon-inner "variable reference given as context: ~a" exp))] - - [(#%top . id) - (if (eq? so-far nothing-so-far) - (recon-source-current-marks exp) - (error 'recon-inner "variable reference given as context: ~a" exp))] - - ; applications - [(#%app . terms) - (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 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp)))) - exp)] - - ; define-struct - ; - ; [(z:struct-form? expr) - ; (if (comes-from-define-struct? expr) - ; so-far - ; (let ([super-expr (z:struct-form-super expr)] - ; [raw-type (utils:read->raw (z:struct-form-type expr))] - ; [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) - ; (if super-expr - ; `(struct (,raw-type ,so-far) - ; ,raw-fields) - ; `(struct ,raw-type ,raw-fields))))] - - ; if - [(if test then else) - (begin - (when (eq? so-far nothing-so-far) - (error 'reconstruct "breakpoint before an if reduction should have a result value")) - (attach-info - #`(if #,so-far - #,(recon-source-current-marks (syntax then)) - #,(recon-source-current-marks (syntax else))) - exp))] - - ; one-armed if - - [(if test then) - (begin - (when (eq? so-far nothing-so-far) - (error 'reconstruct "breakpoint before an if reduction should have a result value")) - (attach-info - #`(if #,so-far #,(recon-source-current-marks (syntax then))) - exp))] - - ; quote : there is no break on a quote. - - ;; 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)] - - ; begin : in the current expansion of begin, there are only two-element begin's, one-element begins, and - ;; zero-element begins - - [(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) - (attach-info - (if (eq? so-far nothing-so-far) - #`(begin #,(recon-source-current-marks (syntax clause))) - (error - 'recon-inner - "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) - exp)] - - [(begin) - (attach-info - (if (eq? so-far nothing-so-far) - #`(begin) - (error - 'recon-inner - "stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax-object->datum exp))))] - - ; begin0 : may not occur directly except in advanced - - ; let-values - - [(let-values . rest) (recon-let)] - - [(letrec-values . rest) (recon-let)] - - [(set! var rhs) - (begin - (when (eq? so-far nothing-so-far) - (error 'reconstruct "breakpoint before an if reduction should have a result value")) - (attach-info - (let ([rendered-var (reconstruct-set!-var mark-list #`var)]) - #`(set! #,rendered-var #,so-far)) - exp))] - - ; lambda : there is no break on a lambda - - [else - (error - 'recon-inner - "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum exp))]))) + (if (syntax-property exp 'stepper-fake-exp) + + (syntax-case exp () + [(begin . bodies) + (if (eq? so-far nothing-so-far) + (error 'recon-inner "breakpoint before a begin reduction should have a result value in exp: ~a" (syntax-object->datum exp)) + #`(begin #,so-far #,@(map recon-source-current-marks (cdr (syntax->list #'bodies)))))] + [else + (error 'recon-inner "unexpected fake-exp expression: ~a" (syntax-object->datum exp))]) + + (kernel:kernel-syntax-case exp #f + ; variable references + [id + (identifier? (syntax id)) + (if (eq? so-far nothing-so-far) + (recon-source-current-marks exp) + (error 'recon-inner "variable reference given as context: ~a" exp))] + + [(#%top . id) + (if (eq? so-far nothing-so-far) + (recon-source-current-marks exp) + (error 'recon-inner "variable reference given as context: ~a" exp))] + + ; applications + [(#%app . terms) + (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 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp)))) + exp)] + + ; define-struct + ; + ; [(z:struct-form? expr) + ; (if (comes-from-define-struct? expr) + ; so-far + ; (let ([super-expr (z:struct-form-super expr)] + ; [raw-type (utils:read->raw (z:struct-form-type expr))] + ; [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) + ; (if super-expr + ; `(struct (,raw-type ,so-far) + ; ,raw-fields) + ; `(struct ,raw-type ,raw-fields))))] + + ; if + [(if test then else) + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + #`(if #,so-far + #,(recon-source-current-marks (syntax then)) + #,(recon-source-current-marks (syntax else))) + exp))] + + ; one-armed if + + [(if test then) + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + #`(if #,so-far #,(recon-source-current-marks (syntax then))) + exp))] + + ; quote : there is no break on a quote. + + ;; 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)] + + ; 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) + (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) + (attach-info + (if (eq? so-far nothing-so-far) + #`(begin #,(recon-source-current-marks (syntax clause))) + (error + 'recon-inner + "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) + exp)] + + [(begin) + (attach-info + (if (eq? so-far nothing-so-far) + #`(begin) + (error + 'recon-inner + "stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax-object->datum exp))))] + + ; begin0 : may not occur directly except in advanced + #;[(begin0 )] + + ; let-values + + [(let-values . rest) (recon-let)] + + [(letrec-values . rest) (recon-let)] + + [(set! var rhs) + (begin + (when (eq? so-far nothing-so-far) + (error 'reconstruct "breakpoint before an if reduction should have a result value")) + (attach-info + (let ([rendered-var (reconstruct-set!-var mark-list #`var)]) + #`(set! #,rendered-var #,so-far)) + exp))] + + ; lambda : there is no break on a lambda + + [else + (error + 'recon-inner + "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum exp))])))) ; the main recursive reconstruction loop is in recon: ; recon : (syntax-object mark-list boolean -> syntax-object)