support for begin, minor refactoring, cleanup, etc.
svn: r4589
This commit is contained in:
John Clements
parent
530e39c5be
commit
4d4db929ca
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user