smushed with branch, preserving changes made to stepper-tool. In sync now.
svn: r1555
This commit is contained in:
John Clements
parent
dfea5041f1
commit
5bc397e6b2
|
|
@ -215,6 +215,11 @@ stepper-test-suite-hint :
|
|||
be annotated, even though it's not in one of the expected top-level
|
||||
shapes.
|
||||
|
||||
stepper-highlight :
|
||||
this expression will be highlighted.
|
||||
(Not currently tranferred...?)
|
||||
|
||||
|
||||
STEPPER-HINT COLLISIONS
|
||||
|
||||
The major concern with the stepper-hint is that two of them may
|
||||
|
|
|
|||
|
|
@ -9,6 +9,11 @@
|
|||
"my-macros.ss"
|
||||
"xml-box.ss"
|
||||
(prefix beginner-defined: "beginner-defined.ss"))
|
||||
|
||||
(define-syntax (where stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body bindings)
|
||||
(syntax/loc stx (letrec bindings body))]))
|
||||
|
||||
; CONTRACTS
|
||||
|
||||
|
|
@ -277,15 +282,12 @@
|
|||
(define (double-break)
|
||||
(break (current-continuation-marks) 'double-break))
|
||||
|
||||
; here are the possible configurations of wcm's, pre-breaks, and breaks (not including late-let & double-breaks):
|
||||
|
||||
; (for full-on stepper)
|
||||
; wcm, result-break, normal-break
|
||||
; wcm, normal-break
|
||||
|
||||
; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr
|
||||
(define (wcm-pre-break-wrap debug-info exp)
|
||||
(wcm-wrap debug-info #`(begin (#,result-exp-break) #,exp)))
|
||||
(wcm-wrap debug-info (pre-break-wrap exp)))
|
||||
|
||||
(define (pre-break-wrap stx)
|
||||
#`(begin (#,result-exp-break) #,stx))
|
||||
|
||||
(define (break-wrap exp)
|
||||
#`(begin (#,normal-break) #,exp))
|
||||
|
|
@ -373,271 +375,317 @@
|
|||
(2vals (wcm-wrap 13 exp) null)]
|
||||
|
||||
[else
|
||||
(let* ([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)))]
|
||||
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))]
|
||||
; note: no pre-break for the body of a let; it's handled by the break for the
|
||||
; let itself.
|
||||
[let-body-recur (lambda (bindings)
|
||||
(lambda (exp)
|
||||
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))]
|
||||
[make-debug-info-normal (lambda (free-bindings)
|
||||
(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))]
|
||||
[make-debug-info-let (lambda (free-bindings binding-list let-counter)
|
||||
(make-debug-info exp
|
||||
(binding-set-union (list tail-bound
|
||||
binding-list
|
||||
(list let-counter)))
|
||||
(varref-set-union (list free-bindings
|
||||
binding-list
|
||||
(list let-counter))) ; NB using bindings as varrefs
|
||||
'let-body
|
||||
#t))]
|
||||
[outer-wcm-wrap (if pre-break?
|
||||
wcm-pre-break-wrap
|
||||
wcm-wrap)]
|
||||
[wcm-break-wrap (lambda (debug-info exp)
|
||||
(outer-wcm-wrap debug-info (break-wrap exp)))]
|
||||
|
||||
[normal-bundle
|
||||
(lambda (free-vars annotated)
|
||||
(2vals (outer-wcm-wrap (make-debug-info-normal free-vars)
|
||||
annotated)
|
||||
free-vars))]
|
||||
|
||||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(with-syntax ([(args-stx . bodies) clause])
|
||||
(let*-2vals ([(annotated-body free-varrefs)
|
||||
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
|
||||
; NB: CAN'T HAPPEN in beginner up through int/lambda
|
||||
(if (> (length (filter (lambda (clause)
|
||||
(not (syntax-property clause 'stepper-skip-completely)))
|
||||
(syntax->list (syntax bodies)))) 1)
|
||||
(lambda-body-recur (syntax (begin . bodies)))
|
||||
(let*-2vals ([(annotated-bodies free-var-sets)
|
||||
(2vals-map lambda-body-recur (syntax->list #`bodies))])
|
||||
(2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))]
|
||||
[new-free-varrefs (varref-set-remove-bindings free-varrefs
|
||||
(arglist-flatten #'args-stx))])
|
||||
(2vals (datum->syntax-object #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))]
|
||||
|
||||
[outer-lambda-abstraction
|
||||
(lambda (annotated-lambda free-varrefs)
|
||||
(let*
|
||||
([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)))]
|
||||
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))]
|
||||
; note: no pre-break for the body of a let; it's handled by the break for the
|
||||
; let itself.
|
||||
[let-body-recur (lambda (bindings)
|
||||
(lambda (exp)
|
||||
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))]
|
||||
[make-debug-info-normal (lambda (free-bindings)
|
||||
(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))]
|
||||
[make-debug-info-let (lambda (free-bindings binding-list let-counter)
|
||||
(make-debug-info exp
|
||||
(binding-set-union (list tail-bound
|
||||
binding-list
|
||||
(list let-counter)))
|
||||
(varref-set-union (list free-bindings
|
||||
binding-list
|
||||
(list let-counter))) ; NB using bindings as varrefs
|
||||
'let-body
|
||||
#t))]
|
||||
[outer-wcm-wrap (if pre-break?
|
||||
wcm-pre-break-wrap
|
||||
wcm-wrap)]
|
||||
[wcm-break-wrap (lambda (debug-info exp)
|
||||
(outer-wcm-wrap debug-info (break-wrap exp)))]
|
||||
|
||||
[normal-bundle
|
||||
(lambda (free-vars annotated)
|
||||
(2vals (outer-wcm-wrap (make-debug-info-normal free-vars)
|
||||
annotated)
|
||||
free-vars))]
|
||||
|
||||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(with-syntax ([(args-stx . bodies) clause])
|
||||
(let*-2vals ([(annotated-body free-varrefs)
|
||||
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
|
||||
; NB: CAN'T HAPPEN in beginner up through int/lambda
|
||||
(if (> (length (filter (lambda (clause)
|
||||
(not (syntax-property clause 'stepper-skip-completely)))
|
||||
(syntax->list (syntax bodies)))) 1)
|
||||
(lambda-body-recur (syntax (begin . bodies)))
|
||||
(let*-2vals ([(annotated-bodies free-var-sets)
|
||||
(2vals-map lambda-body-recur (syntax->list #`bodies))])
|
||||
(2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))]
|
||||
[new-free-varrefs (varref-set-remove-bindings free-varrefs
|
||||
(arglist-flatten #'args-stx))])
|
||||
(2vals (datum->syntax-object #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))]
|
||||
|
||||
[outer-lambda-abstraction
|
||||
(lambda (annotated-lambda free-varrefs)
|
||||
(let*-2vals
|
||||
([closure-info (make-debug-info-app 'all free-varrefs 'none)]
|
||||
[closure-name (if track-inferred-names?
|
||||
(cond [(syntax? procedure-name-info) procedure-name-info]
|
||||
[(pair? procedure-name-info) (car procedure-name-info)]
|
||||
[else #f])
|
||||
#f)]
|
||||
[closure-storing-proc
|
||||
(opt-lambda (closure debug-info [lifted-index #f])
|
||||
(closure-table-put! closure (make-closure-record
|
||||
closure-name
|
||||
debug-info
|
||||
#f
|
||||
lifted-index))
|
||||
closure)]
|
||||
[inferred-name-lambda
|
||||
(if closure-name
|
||||
(syntax-property annotated-lambda 'inferred-name (syntax-e closure-name))
|
||||
annotated-lambda)]
|
||||
[captured
|
||||
(cond [(pair? procedure-name-info)
|
||||
#`(#,closure-storing-proc #,inferred-name-lambda #,closure-info
|
||||
#,(cadr procedure-name-info))]
|
||||
[else
|
||||
#`(#,closure-storing-proc #,inferred-name-lambda #,closure-info)])])
|
||||
|
||||
(normal-bundle free-varrefs captured)))]
|
||||
|
||||
; The let transformation is complicated.
|
||||
; here's a sample transformation (not including 'break's):
|
||||
;(let-values ([(a b c) e1] [(d e) e2]) e3)
|
||||
;
|
||||
;turns into
|
||||
;
|
||||
;(let ([counter (<dynamic-counter-call>)])
|
||||
;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter)
|
||||
; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*
|
||||
; counter counter counter counter counter 0)])
|
||||
; (with-continuation-mark
|
||||
; key huge-value
|
||||
; (begin
|
||||
; (set!-values (a b c) e1)
|
||||
; (set! let-counter 1)
|
||||
; (set!-values (d e) e2)
|
||||
; (set! let-counter 2)
|
||||
; e3))))
|
||||
;
|
||||
; note that this elaboration looks exactly like the one for letrec, and that's
|
||||
; okay, becuase expand guarantees that reordering them will not cause capture.
|
||||
; this is because a bound variable answers is considered bound by a binding only when
|
||||
; the pair answers true to bound-identifier=?, which is determined during (the first)
|
||||
; expand.
|
||||
|
||||
; another irritating point: the mark and the break that must go immediately
|
||||
; around the body. Irritating because they will be instantly replaced by
|
||||
; the mark and the break produced by the annotated body itself. However,
|
||||
; they're necessary, because the body may not contain free references to
|
||||
; all of the variables defined in the let, and thus their values are not
|
||||
; known otherwise.
|
||||
; whoops! hold the phone. I think I can get away with a break before, and
|
||||
; a mark after, so only one of each. groovy, eh?
|
||||
|
||||
; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of
|
||||
; continuations; backing up a computation using a set! will not revert the
|
||||
; counter, and the stepper may think that the computation is in a different
|
||||
; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side.
|
||||
|
||||
|
||||
[let-abstraction
|
||||
(lambda (stx output-identifier make-init-list)
|
||||
(with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
|
||||
(let*-2vals
|
||||
([closure-info (make-debug-info-app 'all free-varrefs 'none)]
|
||||
[closure-name (if track-inferred-names?
|
||||
(cond [(syntax? procedure-name-info) procedure-name-info]
|
||||
[(pair? procedure-name-info) (car procedure-name-info)]
|
||||
[else #f])
|
||||
#f)]
|
||||
[closure-storing-proc
|
||||
(opt-lambda (closure debug-info [lifted-index #f])
|
||||
(closure-table-put! closure (make-closure-record
|
||||
closure-name
|
||||
debug-info
|
||||
#f
|
||||
lifted-index))
|
||||
closure)]
|
||||
[inferred-name-lambda
|
||||
(if closure-name
|
||||
(syntax-property annotated-lambda 'inferred-name (syntax-e closure-name))
|
||||
annotated-lambda)]
|
||||
[captured
|
||||
(cond [(pair? procedure-name-info)
|
||||
#`(#,closure-storing-proc #,inferred-name-lambda #,closure-info
|
||||
#,(cadr procedure-name-info))]
|
||||
[else
|
||||
#`(#,closure-storing-proc #,inferred-name-lambda #,closure-info)])])
|
||||
|
||||
(normal-bundle free-varrefs captured)))]
|
||||
|
||||
; The let transformation is complicated.
|
||||
; here's a sample transformation (not including 'break's):
|
||||
;(let-values ([(a b c) e1] [(d e) e2]) e3)
|
||||
;
|
||||
;turns into
|
||||
;
|
||||
;(let ([counter (<dynamic-counter-call>)])
|
||||
;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter)
|
||||
; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*
|
||||
; counter counter counter counter counter 0)])
|
||||
; (with-continuation-mark
|
||||
; key huge-value
|
||||
; (begin
|
||||
; (set!-values (a b c) e1)
|
||||
; (set! let-counter 1)
|
||||
; (set!-values (d e) e2)
|
||||
; (set! let-counter 2)
|
||||
; e3))))
|
||||
;
|
||||
; note that this elaboration looks exactly like the one for letrec, and that's
|
||||
; okay, becuase expand guarantees that reordering them will not cause capture.
|
||||
; this is because a bound variable answers is considered bound by a binding only when
|
||||
; the pair answers true to bound-identifier=?, which is determined during (the first)
|
||||
; expand.
|
||||
|
||||
; another irritating point: the mark and the break that must go immediately
|
||||
; around the body. Irritating because they will be instantly replaced by
|
||||
; the mark and the break produced by the annotated body itself. However,
|
||||
; they're necessary, because the body may not contain free references to
|
||||
; all of the variables defined in the let, and thus their values are not
|
||||
; known otherwise.
|
||||
; whoops! hold the phone. I think I can get away with a break before, and
|
||||
; a mark after, so only one of each. groovy, eh?
|
||||
|
||||
; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of
|
||||
; continuations; backing up a computation using a set! will not revert the
|
||||
; counter, and the stepper may think that the computation is in a different
|
||||
; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side.
|
||||
|
||||
|
||||
[let-abstraction
|
||||
(lambda (stx output-identifier make-init-list)
|
||||
(with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
|
||||
(let*-2vals
|
||||
([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[vals (syntax->list #'(val ...))]
|
||||
[lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)]
|
||||
[lifted-vars (apply append lifted-var-sets)]
|
||||
[(annotated-vals free-varref-sets-vals)
|
||||
(2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
|
||||
[(annotated-body free-varrefs-body)
|
||||
((let-body-recur binding-list)
|
||||
(if (= (length (syntax->list (syntax bodies))) 1)
|
||||
(car (syntax->list (syntax bodies)))
|
||||
(syntax (begin . bodies))))]
|
||||
[free-varrefs (varref-set-remove-bindings
|
||||
(varref-set-union (cons free-varrefs-body
|
||||
free-varref-sets-vals))
|
||||
binding-list)])
|
||||
|
||||
|
||||
(let* ([counter-id #`lifting-counter]
|
||||
[unevaluated-list (make-init-list binding-list)]
|
||||
[outer-initialization
|
||||
#`([(#,@lifted-vars #,@binding-list #,let-counter)
|
||||
(values #,@(append (map (lambda (dc_binding) counter-id)
|
||||
binding-list)
|
||||
unevaluated-list
|
||||
(list 0)))])]
|
||||
[counter-clauses (build-list
|
||||
(length binding-sets)
|
||||
(lambda (num)
|
||||
#`(set! #,let-counter #,(+ num 1))))]
|
||||
[set!-clauses
|
||||
(map (lambda (binding-set val)
|
||||
#`(set!-values #,binding-set #,val))
|
||||
binding-sets
|
||||
annotated-vals)]
|
||||
[exp-finished-clauses
|
||||
|
||||
(with-syntax ([(_ let-clauses . dc) stx]
|
||||
[((lifted-var ...) ...) lifted-var-sets])
|
||||
(with-syntax ([(exp-thunk ...) (map (lx (lambda () _))
|
||||
(syntax->list #`let-clauses))])
|
||||
#`(list (list exp-thunk
|
||||
(list lifted-var ...)
|
||||
(lambda () (list var ...))) ...)))]
|
||||
; time to work from the inside out again
|
||||
; without renaming, this would all be much much simpler.
|
||||
[wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs
|
||||
binding-list
|
||||
let-counter)
|
||||
(double-break-wrap
|
||||
#`(begin #,@(apply append (zip set!-clauses counter-clauses))
|
||||
(#,exp-finished-break #,exp-finished-clauses)
|
||||
#,annotated-body)))])
|
||||
(2vals (quasisyntax/loc
|
||||
([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[vals (syntax->list #'(val ...))]
|
||||
[lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)]
|
||||
[lifted-vars (apply append lifted-var-sets)]
|
||||
[(annotated-vals free-varref-sets-vals)
|
||||
(2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
|
||||
[(annotated-body free-varrefs-body)
|
||||
((let-body-recur binding-list)
|
||||
(if (= (length (syntax->list (syntax bodies))) 1)
|
||||
(car (syntax->list (syntax bodies)))
|
||||
(syntax (begin . bodies))))]
|
||||
[free-varrefs (varref-set-remove-bindings
|
||||
(varref-set-union (cons free-varrefs-body
|
||||
free-varref-sets-vals))
|
||||
binding-list)])
|
||||
|
||||
|
||||
(let* ([counter-id #`lifting-counter]
|
||||
[unevaluated-list (make-init-list binding-list)]
|
||||
[outer-initialization
|
||||
#`([(#,@lifted-vars #,@binding-list #,let-counter)
|
||||
(values #,@(append (map (lambda (dc_binding) counter-id)
|
||||
binding-list)
|
||||
unevaluated-list
|
||||
(list 0)))])]
|
||||
[counter-clauses (build-list
|
||||
(length binding-sets)
|
||||
(lambda (num)
|
||||
#`(set! #,let-counter #,(+ num 1))))]
|
||||
[set!-clauses
|
||||
(map (lambda (binding-set val)
|
||||
#`(set!-values #,binding-set #,val))
|
||||
binding-sets
|
||||
annotated-vals)]
|
||||
[exp-finished-clauses
|
||||
|
||||
(with-syntax ([(_ let-clauses . dc) stx]
|
||||
[((lifted-var ...) ...) lifted-var-sets])
|
||||
(with-syntax ([(exp-thunk ...) (map (lx (lambda () _))
|
||||
(syntax->list #`let-clauses))])
|
||||
#`(list (list exp-thunk
|
||||
(list lifted-var ...)
|
||||
(lambda () (list var ...))) ...)))]
|
||||
; time to work from the inside out again
|
||||
; without renaming, this would all be much much simpler.
|
||||
[wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs
|
||||
binding-list
|
||||
let-counter)
|
||||
(double-break-wrap
|
||||
#`(begin #,@(apply append (zip set!-clauses counter-clauses))
|
||||
(#,exp-finished-break #,exp-finished-clauses)
|
||||
#,annotated-body)))])
|
||||
(2vals (quasisyntax/loc
|
||||
exp
|
||||
(let ([#,counter-id (#,binding-indexer)])
|
||||
(#,output-identifier #,outer-initialization #,wrapped-begin)))
|
||||
free-varrefs)))))]
|
||||
|
||||
; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?))
|
||||
[if-abstraction
|
||||
(lambda (test then else)
|
||||
(let*-2vals
|
||||
([(annotated-test free-varrefs-test)
|
||||
(non-tail-recur test)]
|
||||
[(annotated-then free-varrefs-then)
|
||||
(tail-recur then)]
|
||||
[(annotated-else free-varrefs-else)
|
||||
(if else
|
||||
(tail-recur else)
|
||||
(2vals #f null))]
|
||||
[free-varrefs (varref-set-union (list free-varrefs-test
|
||||
free-varrefs-then
|
||||
free-varrefs-else))]
|
||||
[annotated-if
|
||||
#`(begin (set! #,if-temp #,annotated-test)
|
||||
(#,normal-break)
|
||||
#,(if else
|
||||
(quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else))
|
||||
(quasisyntax/loc exp (if #,if-temp #,annotated-then))))]
|
||||
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp)))
|
||||
(varref-set-union (list free-varrefs (list if-temp)))
|
||||
'none)
|
||||
annotated-if)])
|
||||
(2vals
|
||||
(with-syntax ([test-var if-temp]
|
||||
[wrapped-stx wrapped]
|
||||
[unevaluated-stx *unevaluated*])
|
||||
(syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
|
||||
free-varrefs)))]
|
||||
|
||||
[varref-abstraction
|
||||
(lambda (var)
|
||||
(let*-2vals ([free-varrefs (list var)]
|
||||
[varref-break-wrap
|
||||
(lambda ()
|
||||
(wcm-break-wrap (make-debug-info-normal free-varrefs)
|
||||
(return-value-wrap var)))]
|
||||
[varref-no-break-wrap
|
||||
(lambda ()
|
||||
(outer-wcm-wrap (make-debug-info-normal free-varrefs) var))]
|
||||
[top-level-varref-break-wrap
|
||||
(lambda ()
|
||||
(if (memq (syntax-e var) beginner-defined:must-reduce)
|
||||
(varref-break-wrap)
|
||||
(varref-no-break-wrap)))])
|
||||
(2vals
|
||||
(case (syntax-property var 'stepper-binding-type)
|
||||
((lambda-bound macro-bound) (varref-no-break-wrap))
|
||||
((let-bound) (varref-break-wrap))
|
||||
((non-lexical) ;; is it from this module or not?
|
||||
(match (identifier-binding var)
|
||||
(#f (top-level-varref-break-wrap))
|
||||
[`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4)
|
||||
(if (module-path-index? path-index-or-symbol)
|
||||
(let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)])
|
||||
(if module-path
|
||||
;; not a module-local variable:
|
||||
(top-level-varref-break-wrap)
|
||||
;; a module-local-variable:
|
||||
(varref-break-wrap)))
|
||||
(top-level-varref-break-wrap))]
|
||||
[else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)])))
|
||||
free-varrefs)))]
|
||||
|
||||
[recertifier
|
||||
(lambda (vals)
|
||||
(let*-2vals ([(new-exp bindings) vals])
|
||||
(2vals (syntax-recertify new-exp exp (current-code-inspector) #f)
|
||||
bindings)))]
|
||||
|
||||
)
|
||||
(let ([#,counter-id (#,binding-indexer)])
|
||||
(#,output-identifier #,outer-initialization #,wrapped-begin)))
|
||||
free-varrefs)))))]
|
||||
|
||||
;; pulling out begin abstraction!
|
||||
[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)])))
|
||||
|
||||
)]
|
||||
|
||||
; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?))
|
||||
[if-abstraction
|
||||
(lambda (test then else)
|
||||
(let*-2vals
|
||||
([(annotated-test free-varrefs-test)
|
||||
(non-tail-recur test)]
|
||||
[(annotated-then free-varrefs-then)
|
||||
(tail-recur then)]
|
||||
[(annotated-else free-varrefs-else)
|
||||
(if else
|
||||
(tail-recur else)
|
||||
(2vals #f null))]
|
||||
[free-varrefs (varref-set-union (list free-varrefs-test
|
||||
free-varrefs-then
|
||||
free-varrefs-else))]
|
||||
[annotated-if
|
||||
#`(begin (set! #,if-temp #,annotated-test)
|
||||
(#,normal-break)
|
||||
#,(if else
|
||||
(quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else))
|
||||
(quasisyntax/loc exp (if #,if-temp #,annotated-then))))]
|
||||
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp)))
|
||||
(varref-set-union (list free-varrefs (list if-temp)))
|
||||
'none)
|
||||
annotated-if)])
|
||||
(2vals
|
||||
(with-syntax ([test-var if-temp]
|
||||
[wrapped-stx wrapped]
|
||||
[unevaluated-stx *unevaluated*])
|
||||
(syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
|
||||
free-varrefs)))]
|
||||
|
||||
[varref-abstraction
|
||||
(lambda (var)
|
||||
(let*-2vals ([free-varrefs (list var)]
|
||||
[varref-break-wrap
|
||||
(lambda ()
|
||||
(wcm-break-wrap (make-debug-info-normal free-varrefs)
|
||||
(return-value-wrap var)))]
|
||||
[varref-no-break-wrap
|
||||
(lambda ()
|
||||
(outer-wcm-wrap (make-debug-info-normal free-varrefs) var))]
|
||||
[top-level-varref-break-wrap
|
||||
(lambda ()
|
||||
(if (memq (syntax-e var) beginner-defined:must-reduce)
|
||||
(varref-break-wrap)
|
||||
(varref-no-break-wrap)))])
|
||||
(2vals
|
||||
(case (syntax-property var 'stepper-binding-type)
|
||||
((lambda-bound macro-bound) (varref-no-break-wrap))
|
||||
((let-bound) (varref-break-wrap))
|
||||
((non-lexical) ;; is it from this module or not?
|
||||
(match (identifier-binding var)
|
||||
(#f (top-level-varref-break-wrap))
|
||||
[`(,path-index-or-symbol ,dc1 ,dc2 ,dc3 ,dc4)
|
||||
(if (module-path-index? path-index-or-symbol)
|
||||
(let-values ([(module-path dc5) (module-path-index-split path-index-or-symbol)])
|
||||
(if module-path
|
||||
;; not a module-local variable:
|
||||
(top-level-varref-break-wrap)
|
||||
;; a module-local-variable:
|
||||
(varref-break-wrap)))
|
||||
(top-level-varref-break-wrap))]
|
||||
[else (error 'annotate "unexpected value for identifier-binding: ~v" identifier-binding)])))
|
||||
free-varrefs)))]
|
||||
|
||||
[recertifier
|
||||
(lambda (vals)
|
||||
(let*-2vals ([(new-exp bindings) vals])
|
||||
(2vals (syntax-recertify new-exp exp (current-code-inspector) #f)
|
||||
bindings)))]
|
||||
|
||||
)
|
||||
; find the source expression and associate it with the parsed expression
|
||||
; (when (and red-exprs foot-wrap?)
|
||||
; (set-exp-read! exp (find-read-expr exp)))
|
||||
|
|
@ -645,156 +693,152 @@
|
|||
|
||||
(recertifier
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
|
||||
[(lambda . clause)
|
||||
(let*-2vals ([(annotated-clause free-varrefs)
|
||||
(lambda-clause-abstraction (syntax clause))]
|
||||
[annotated-lambda
|
||||
(with-syntax ([annotated-clause annotated-clause])
|
||||
(syntax/loc exp (lambda . annotated-clause)))])
|
||||
(outer-lambda-abstraction annotated-lambda free-varrefs))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(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))]
|
||||
|
||||
|
||||
|
||||
[(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))]
|
||||
[(if test then) (if-abstraction (syntax test) (syntax then) #f)]
|
||||
|
||||
[(lambda . clause)
|
||||
(let*-2vals ([(annotated-clause free-varrefs)
|
||||
(lambda-clause-abstraction (syntax clause))]
|
||||
[annotated-lambda
|
||||
(with-syntax ([annotated-clause annotated-clause])
|
||||
(syntax/loc exp (lambda . annotated-clause)))])
|
||||
(outer-lambda-abstraction annotated-lambda free-varrefs))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(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))]
|
||||
|
||||
|
||||
|
||||
[(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)
|
||||
(if (null? (syntax->list (syntax bodies-stx)))
|
||||
(normal-bundle null exp)
|
||||
(let*-2vals
|
||||
([reversed-bodies (reverse (syntax->list (syntax bodies-stx)))]
|
||||
[last-body (car reversed-bodies)]
|
||||
[all-but-last (reverse (cdr reversed-bodies))]
|
||||
[(annotated-a free-varrefs-a)
|
||||
(2vals-map non-tail-recur all-but-last)]
|
||||
[(annotated-final free-varrefs-final)
|
||||
(tail-recur last-body)])
|
||||
(normal-bundle (varref-set-union (cons free-varrefs-final free-varrefs-a))
|
||||
(quasisyntax/loc exp (begin #,@annotated-a #,annotated-final)))))]
|
||||
|
||||
[(begin0 . bodies-stx)
|
||||
(let*-2vals
|
||||
([bodies (syntax->list (syntax bodies-stx))]
|
||||
[(annotated-first free-varrefs-first)
|
||||
(result-recur (car bodies))]
|
||||
[(annotated-bodies free-varref-sets)
|
||||
(2vals-map non-tail-recur (cdr bodies))])
|
||||
[(begin . bodies-stx)
|
||||
(begin-abstraction (syntax->list #`bodies-stx))]
|
||||
|
||||
[(begin0 . bodies-stx)
|
||||
(let*-2vals
|
||||
([bodies (syntax->list (syntax bodies-stx))]
|
||||
[(annotated-first free-varrefs-first)
|
||||
(result-recur (car bodies))]
|
||||
[(annotated-bodies free-varref-sets)
|
||||
(2vals-map non-tail-recur (cdr bodies))])
|
||||
(normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets))
|
||||
(quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))]
|
||||
|
||||
[(let-values . _)
|
||||
(let-abstraction exp
|
||||
#`let-values
|
||||
(lambda (bindings)
|
||||
(map (lambda (_) *unevaluated*) bindings)))]
|
||||
|
||||
[(letrec-values . _)
|
||||
(let-abstraction exp
|
||||
#`letrec-values
|
||||
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
|
||||
|
||||
[(set! var val)
|
||||
(let*-2vals
|
||||
([(annotated-val val-free-varrefs)
|
||||
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
|
||||
[(#%top . real-var) (syntax-e (syntax real-var))]
|
||||
[else (syntax var)]))]
|
||||
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
|
||||
[annotated-set!
|
||||
#`(begin (set! #,set!-temp #,annotated-val)
|
||||
(#,normal-break)
|
||||
#,(return-value-wrap
|
||||
(quasisyntax/loc exp (set! var #,set!-temp))))]
|
||||
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list set!-temp)))
|
||||
(varref-set-union (list free-varrefs (list set!-temp)))
|
||||
'none)
|
||||
annotated-set!)])
|
||||
(2vals
|
||||
(with-syntax ([test-var set!-temp]
|
||||
[wrapped-stx wrapped]
|
||||
[unevaluated-stx *unevaluated*])
|
||||
(quasisyntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
|
||||
free-varrefs))]
|
||||
|
||||
|
||||
[(quote _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(quote-syntax _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(with-continuation-mark key mark body)
|
||||
;(let*-2vals ([(annotated-key free-varrefs-key)
|
||||
; (non-tail-recur (syntax key))]
|
||||
; [(annotated-mark free-varrefs-mark)
|
||||
; (non-tail-recur (syntax mark))]
|
||||
; [(annotated-body dc_free-varrefs-body)
|
||||
; (result-recur (syntax body))])
|
||||
(error 'annotate/inner "this region of code is still under construction")
|
||||
|
||||
; [annotated #`(let-values ([key-temp #,*unevaluated*]
|
||||
; [mark-temp #,*unevaluated*]
|
||||
;)
|
||||
]
|
||||
|
||||
; [foot-wrap?
|
||||
; (wcm-wrap debug-info annotated)])
|
||||
; free-bindings))]
|
||||
|
||||
; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
|
||||
; are temp identifiers that do not occur in the program:
|
||||
; (M0 ...)
|
||||
;
|
||||
; goes to
|
||||
;
|
||||
;(let ([t0 *unevaluated*]
|
||||
; ...)
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; huge-value
|
||||
; (set! t0 M0)
|
||||
; ...
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; much-smaller-value
|
||||
; (t0 ...))))
|
||||
;
|
||||
; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are
|
||||
; varrefs. In particular (where v0 ... are varrefs):
|
||||
; (v0 ...)
|
||||
;
|
||||
; goes to
|
||||
;
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; debug-value
|
||||
; (v0 ...))
|
||||
;
|
||||
; in other words, no real elaboration occurs. Note that this doesn't work as-is for the
|
||||
; stepper, because there's nowhere to hang the breakpoint; you want to see the break
|
||||
; 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.
|
||||
|
||||
[(#%app . terms)
|
||||
(let*-2vals
|
||||
([(annotated-terms free-varrefs-terms)
|
||||
(2vals-map non-tail-recur (syntax->list (syntax terms)))]
|
||||
[free-varrefs (varref-set-union free-varrefs-terms)])
|
||||
;; 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? (syntax-property exp 'stepper-hint) 'comes-from-begin)
|
||||
(begin-abstraction (syntax->list #`bodies-stx))]
|
||||
|
||||
[(let-values . _)
|
||||
(let-abstraction exp
|
||||
#`let-values
|
||||
(lambda (bindings)
|
||||
(map (lambda (_) *unevaluated*) bindings)))]
|
||||
|
||||
[(letrec-values . _)
|
||||
(let-abstraction exp
|
||||
#`letrec-values
|
||||
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
|
||||
|
||||
[(set! var val)
|
||||
(let*-2vals
|
||||
([(annotated-val val-free-varrefs)
|
||||
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
|
||||
[(#%top . real-var) (syntax-e (syntax real-var))]
|
||||
[else (syntax var)]))]
|
||||
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
|
||||
[annotated-set!
|
||||
#`(begin (set! #,set!-temp #,annotated-val)
|
||||
(#,normal-break)
|
||||
#,(return-value-wrap
|
||||
(quasisyntax/loc exp (set! var #,set!-temp))))]
|
||||
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list set!-temp)))
|
||||
(varref-set-union (list free-varrefs (list set!-temp)))
|
||||
'none)
|
||||
annotated-set!)])
|
||||
(2vals
|
||||
(with-syntax ([test-var set!-temp]
|
||||
[wrapped-stx wrapped]
|
||||
[unevaluated-stx *unevaluated*])
|
||||
(quasisyntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
|
||||
free-varrefs))]
|
||||
|
||||
|
||||
[(quote _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(quote-syntax _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(with-continuation-mark key mark body)
|
||||
;(let*-2vals ([(annotated-key free-varrefs-key)
|
||||
; (non-tail-recur (syntax key))]
|
||||
; [(annotated-mark free-varrefs-mark)
|
||||
; (non-tail-recur (syntax mark))]
|
||||
; [(annotated-body dc_free-varrefs-body)
|
||||
; (result-recur (syntax body))])
|
||||
(error 'annotate/inner "this region of code is still under construction")
|
||||
|
||||
; [annotated #`(let-values ([key-temp #,*unevaluated*]
|
||||
; [mark-temp #,*unevaluated*]
|
||||
;)
|
||||
]
|
||||
|
||||
; [foot-wrap?
|
||||
; (wcm-wrap debug-info annotated)])
|
||||
; free-bindings))]
|
||||
|
||||
; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
|
||||
; are temp identifiers that do not occur in the program:
|
||||
; (M0 ...)
|
||||
;
|
||||
; goes to
|
||||
;
|
||||
;(let ([t0 *unevaluated*]
|
||||
; ...)
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; huge-value
|
||||
; (set! t0 M0)
|
||||
; ...
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; much-smaller-value
|
||||
; (t0 ...))))
|
||||
;
|
||||
; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are
|
||||
; varrefs. In particular (where v0 ... are varrefs):
|
||||
; (v0 ...)
|
||||
;
|
||||
; goes to
|
||||
;
|
||||
; (with-continuation-mark
|
||||
; debug-key
|
||||
; debug-value
|
||||
; (v0 ...))
|
||||
;
|
||||
; in other words, no real elaboration occurs. Note that this doesn't work as-is for the
|
||||
; stepper, because there's nowhere to hang the breakpoint; you want to see the break
|
||||
; 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.
|
||||
|
||||
[(#%app . terms)
|
||||
(let*-2vals
|
||||
([(annotated-terms free-varrefs-terms)
|
||||
(2vals-map non-tail-recur (syntax->list (syntax terms)))]
|
||||
[free-varrefs (varref-set-union free-varrefs-terms)])
|
||||
(2vals
|
||||
(let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
|
||||
[tagged-arg-temps (map (lambda (var) (syntax-property var 'stepper-binding-type 'stepper-temp))
|
||||
arg-temps)]
|
||||
[let-clauses #`((#,tagged-arg-temps
|
||||
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
|
||||
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
|
||||
[set!-list (map (lambda (arg-symbol annotated-sub-exp)
|
||||
#`(set! #,arg-symbol #,annotated-sub-exp))
|
||||
tagged-arg-temps annotated-terms)]
|
||||
|
|
@ -814,19 +858,19 @@
|
|||
#`(let-values #,let-clauses #,let-body))
|
||||
;)
|
||||
free-varrefs))]
|
||||
|
||||
[(#%datum . _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(#%top . var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
|
||||
[var-stx
|
||||
(identifier? #`var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
|
||||
[else
|
||||
(error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))])))
|
||||
|
||||
[(#%datum . _)
|
||||
(normal-bundle null exp)]
|
||||
|
||||
[(#%top . var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
|
||||
[var-stx
|
||||
(identifier? #`var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
|
||||
[else
|
||||
(error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))])))
|
||||
|
||||
|
||||
;; annotate/top-level : syntax-> syntax
|
||||
|
|
|
|||
|
|
@ -173,6 +173,7 @@
|
|||
kept-vars)]
|
||||
[lifter-syms (map get-lifted-var let-bindings)])
|
||||
(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 source label kept-vars))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -53,8 +53,8 @@
|
|||
(or (and (procedure? val)
|
||||
(object-name val))
|
||||
(print-convert val)))))
|
||||
|
||||
; FIXME : #f totally unacceptable as 'render-to-string'
|
||||
|
||||
; FIXME : #f totally unacceptable as 'render-to-string'
|
||||
(define fake-beginner-render-settings
|
||||
(make-render-settings #t #t #f (make-fake-render-to-sexp #t #t #f) #t))
|
||||
|
||||
|
|
|
|||
|
|
@ -82,6 +82,52 @@
|
|||
|
||||
(define basic-eval (current-eval))
|
||||
|
||||
;; highlight-mutated-expressions :
|
||||
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) . -> . (list/c (listof syntax?) (listof syntax?)))
|
||||
;; highlights changes occurring due to mutation. This function accepts the left-hand-side
|
||||
;; expressions and the right-hand-side expressions, and matches them against each other
|
||||
;; to see which ones have changed due to mutation, and highlights these.
|
||||
;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5), should the 4 & 5 be
|
||||
;; highlighted individually or should the list as a whole be highlighted. Is either one "wrong?"
|
||||
;; equivalences between reduction semantics?
|
||||
;;
|
||||
;; 2005-11-14: punting. just highlight the whole damn thing if there are any differences.
|
||||
;; in fact, just test for eq?-ness.
|
||||
|
||||
#;(define (highlight-mutated-expressions lefts rights)
|
||||
(if (or (null? lefts) (null? rights))
|
||||
(list lefts rights)
|
||||
(let ([left-car (car lefts)]
|
||||
[right-car (car rights)])
|
||||
(if (eq? (syntax-property left-car 'user-source)
|
||||
(syntax-property right-car 'user-source))
|
||||
(let ([highlights-added (highlight-mutated-expression left-car right-car)]
|
||||
[rest (highlight-mutated-expressions (cdr lefts) (cdr rights))])
|
||||
(cons (cons (car highlights-added) (car rest))
|
||||
(cons (cadr highlights-added) (cadr rest))))))))
|
||||
|
||||
;; highlight-mutated-expression: syntax? syntax? -> syntax?
|
||||
;; given two expressions, highlight 'em both if they differ at all.
|
||||
|
||||
;; notes: wanted to use simple "eq?" test... but this will fail when a being-stepped definition (e.g.
|
||||
;; in a let) turns into a permanent one. We pay a terrible price for the lifting thing. And, for the fact
|
||||
;; that the highlighting follows from the reductions but can't obviously be deduced from them.
|
||||
|
||||
#;(define (highlight-mutated-expression left right)
|
||||
(cond
|
||||
;; if either one is already highlighted, leave them alone.
|
||||
[(or (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))
|
||||
(list left right)]
|
||||
|
||||
;; first pass: highlight if not eq?. Should be broken for local-bound things
|
||||
;; as they pass into permanence.
|
||||
[(eq? left right)
|
||||
(list left right)]
|
||||
|
||||
[else (list (syntax-property left 'stepper-highlight)
|
||||
(syntax-property right 'stepper-highlight))]))
|
||||
|
||||
;; REDIVIDE MAKES NO SENSE IN THE NEW INTERFACE. THIS WILL BE DELETED AFTER BEING PARTED OUT.
|
||||
; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists,
|
||||
; where the before and after sets are maximal-length lists where none of the s-expressions contain
|
||||
|
|
@ -120,9 +166,13 @@
|
|||
; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5))
|
||||
; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5))
|
||||
|
||||
(define (>>> x)
|
||||
(fprintf (current-output-port) ">>> ~v\n" x)
|
||||
x)
|
||||
|
||||
(define break
|
||||
(opt-lambda (mark-set break-kind [returned-value-list null])
|
||||
|
||||
|
||||
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
|
||||
|
||||
|
|
@ -190,7 +240,7 @@
|
|||
(receive-result result)))]
|
||||
|
||||
[(double-break)
|
||||
; a double-break occurs at the beginning of a let's evaluation.
|
||||
;; a double-break occurs at the beginning of a let's evaluation.
|
||||
(when (not (eq? held-exp-list no-sexp))
|
||||
(error 'break-reconstruction
|
||||
"held-exp-list not empty when a double-break occurred"))
|
||||
|
|
@ -216,6 +266,9 @@
|
|||
|
||||
[else (error 'break "unknown label on break")])))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (step-through-expression expanded expand-next-expression)
|
||||
(let* ([annotated (a:annotate expanded break track-inferred-names?)])
|
||||
(eval-syntax annotated)
|
||||
|
|
|
|||
|
|
@ -101,6 +101,10 @@
|
|||
; prints the name attached to the procedure, unless we're on the right-hand-side
|
||||
; of a let, or unless there _is_ no name.
|
||||
|
||||
(define (>>> x)
|
||||
(fprintf (current-error-port) ">>> ~v\n" x)
|
||||
x)
|
||||
|
||||
(define recon-value
|
||||
(opt-lambda (val render-settings [assigned-name #f])
|
||||
(if (hash-table-get finished-xml-box-table val (lambda () #f))
|
||||
|
|
@ -151,7 +155,11 @@
|
|||
[(normal-break)
|
||||
(skip-redex-step? mark-list render-settings)]
|
||||
[(double-break)
|
||||
(not (render-settings-lifting? render-settings))]
|
||||
(or
|
||||
;; don't stop for a double-break on a let that is the expansion of a 'begin'
|
||||
(let ([expr (mark-source (car mark-list))])
|
||||
(eq? (syntax-property expr 'stepper-hint) 'comes-from-begin))
|
||||
(not (render-settings-lifting? render-settings)))]
|
||||
[(expr-finished-break define-struct-break late-let-break) #f]))
|
||||
|
||||
(define (skip-redex-step? mark-list render-settings)
|
||||
|
|
@ -362,6 +370,9 @@
|
|||
[(comes-from-recur)
|
||||
(unwind-recur stx)]
|
||||
|
||||
[(comes-from-begin)
|
||||
(unwind-begin stx)]
|
||||
|
||||
(else (fall-through)))
|
||||
(fall-through))
|
||||
stx))
|
||||
|
|
@ -471,6 +482,12 @@
|
|||
(error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))])
|
||||
(syntax (cond . clauses))))
|
||||
|
||||
(define (unwind-begin stx)
|
||||
(syntax-case stx (let-values)
|
||||
[(let-values () body ...)
|
||||
(with-syntax ([(new-body ...) (map inner (syntax->list #`(body ...)))])
|
||||
#`(begin new-body ...))]))
|
||||
|
||||
(define (unwind-and/or stx user-source user-position label)
|
||||
(let ([clause-padder (case label
|
||||
[(and) #`true]
|
||||
|
|
@ -543,16 +560,18 @@
|
|||
#`(label #,@(map recur (filter-skipped (syntax->list (syntax bodies)))))))]
|
||||
[recon-let/rec
|
||||
(lambda (rec?)
|
||||
(with-syntax ([(label ((vars val) ...) body) expr])
|
||||
|
||||
(with-syntax ([(label ((vars val) ...) body ...) expr])
|
||||
(let* ([bindings (map syntax->list (syntax->list (syntax (vars ...))))]
|
||||
[binding-list (apply append bindings)]
|
||||
[recur-fn (if rec?
|
||||
(lambda (expr) (let-recur expr binding-list))
|
||||
recur)]
|
||||
[right-sides (map recur-fn (syntax->list (syntax (val ...))))]
|
||||
[recon-body (let-recur (syntax body) binding-list)])
|
||||
[recon-bodies (map (lambda (x) (let-recur x binding-list))
|
||||
(syntax->list #`(body ...)))])
|
||||
(with-syntax ([(recon-val ...) right-sides]
|
||||
[recon-body recon-body]
|
||||
[(recon-body ...) recon-bodies]
|
||||
[(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding)
|
||||
(bound-identifier=? binding _))
|
||||
use-lifted-names)
|
||||
|
|
@ -562,7 +581,7 @@
|
|||
_))
|
||||
_))
|
||||
bindings)])
|
||||
(syntax (label ((new-vars recon-val) ...) recon-body))))))]
|
||||
(syntax (label ((new-vars recon-val) ...) recon-body ...))))))]
|
||||
[recon-lambda-clause
|
||||
(lambda (clause)
|
||||
(with-syntax ([(args . bodies-stx) clause])
|
||||
|
|
@ -606,7 +625,7 @@
|
|||
#`(set! #,rendered-var #,(recur #'rhs)))]
|
||||
|
||||
; quote
|
||||
[(quote body) (recon-value (syntax-e (syntax body)) render-settings)]
|
||||
[(quote body) (recon-value (eval-quoted expr) render-settings)]
|
||||
|
||||
; quote-syntax : like set!, the current stepper cannot handle quote-syntax
|
||||
|
||||
|
|
@ -699,7 +718,18 @@
|
|||
(datum->syntax-object s (string->symbol (cadr m)) s s)
|
||||
s)))
|
||||
(define re:beginner: (regexp "^beginner:(.*)$"))
|
||||
; ;
|
||||
|
||||
|
||||
;; eval-quoted : take a syntax-object that is an application of quote, and evaluate it (for display)
|
||||
;; Frankly, I'm worried by the fact that this isn't done at expansion time.
|
||||
|
||||
(define (eval-quoted stx)
|
||||
(syntax-case stx (quote)
|
||||
[(quote . dont-care) (eval stx)]
|
||||
[else (error 'eval-quoted "eval-quoted called with syntax that is not a quote: ~v" stx)]))
|
||||
|
||||
|
||||
; ;
|
||||
; ; ; ; ;
|
||||
; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ;;; ; ;;; ;; ; ;;; ; ;;; ;;;; ;;; ;;; ;
|
||||
;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ;;
|
||||
|
|
@ -962,9 +992,45 @@
|
|||
exp)]
|
||||
|
||||
; quote : there is no break on a quote.
|
||||
|
||||
;; advanced-begin : okay, here comes advanced-begin.
|
||||
|
||||
; begin : may not occur directly, but will occur in the expansion of cond, now that I'm no longer
|
||||
; masking that out with stepper-skipto. Furthermore, exactly one expression can occur inside it.
|
||||
[(begin . terms)
|
||||
;; copied from app:
|
||||
|
||||
(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
|
||||
|
|
@ -975,6 +1041,14 @@
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@
|
|||
; get-binding-name
|
||||
; bogus-binding?
|
||||
if-temp
|
||||
begin-temp
|
||||
set!-temp
|
||||
; get-lifted-gensym
|
||||
; expr-read
|
||||
|
|
@ -216,6 +217,7 @@
|
|||
new-binding)))))))
|
||||
|
||||
(define if-temp (syntax-property (datum->syntax-object #`here `if-temp) 'stepper-binding-type 'stepper-temp))
|
||||
(define begin-temp (syntax-property (datum->syntax-object #`here `begin-temp) 'stepper-binding-type 'stepper-temp))
|
||||
(define set!-temp (syntax-property (datum->syntax-object #`here `set!-temp) 'stepper-binding-type 'stepper-temp))
|
||||
|
||||
; gensyms needed by many modules:
|
||||
|
|
|
|||
|
|
@ -197,6 +197,10 @@
|
|||
(lambda ()
|
||||
(simple-module-based-language-convert-value val simple-settings)))))
|
||||
|
||||
(define (>>> x)
|
||||
(fprintf (current-error-port) ">>> ~v\n" x)
|
||||
x)
|
||||
|
||||
; channel for incoming views
|
||||
(define view-channel (make-async-channel))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user