retabbing, dumping a 'local', no longer using parenthesized module form
This commit is contained in:
John Clements
parent
53db721ee9
commit
2cebd8f4cb
|
|
@ -762,375 +762,371 @@
|
||||||
; highlight-placeholder --- and a list of sexps which go in the holes
|
; highlight-placeholder --- and a list of sexps which go in the holes
|
||||||
|
|
||||||
(define (reconstruct-current mark-list break-kind returned-value-list render-settings)
|
(define (reconstruct-current mark-list break-kind returned-value-list render-settings)
|
||||||
(local
|
|
||||||
(
|
|
||||||
|
|
||||||
; ;; ;;; ;;; ;;; ; ;; ; ; ;; ; ;; ;;; ; ;;
|
; ;; ;;; ;;; ;;; ; ;; ; ; ;; ; ;; ;;; ; ;;
|
||||||
;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ;;
|
;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ;
|
; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;;; ;;; ;;; ; ; ; ; ; ; ; ;;;; ;
|
; ;;;; ;;; ;;; ; ; ; ; ; ; ; ;;;; ;
|
||||||
|
|
||||||
|
|
||||||
(define (recon-inner mark-list so-far)
|
(define (recon-inner mark-list so-far)
|
||||||
(let* ([recon-source-current-marks
|
(let* ([recon-source-current-marks
|
||||||
(lambda (expr)
|
(lambda (expr)
|
||||||
(recon-source-expr expr mark-list null null render-settings))]
|
(recon-source-expr expr mark-list null null render-settings))]
|
||||||
[top-mark (car mark-list)]
|
[top-mark (car mark-list)]
|
||||||
[exp (mark-source top-mark)]
|
[exp (mark-source top-mark)]
|
||||||
[iota (lambda (x) (build-list x (lambda (x) x)))]
|
[iota (lambda (x) (build-list x (lambda (x) x)))]
|
||||||
|
|
||||||
[recon-let
|
[recon-let
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-syntax ([(label ((vars rhs) ...) . bodies) exp])
|
(with-syntax ([(label ((vars rhs) ...) . bodies) exp])
|
||||||
(match-let*
|
(match-let*
|
||||||
([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
||||||
[binding-list (apply append binding-sets)]
|
[binding-list (apply append binding-sets)]
|
||||||
[glumps
|
[glumps
|
||||||
(map (lambda (binding-set rhs)
|
(map (lambda (binding-set rhs)
|
||||||
(make-let-glump
|
(make-let-glump
|
||||||
(map (lambda (binding)
|
(map (lambda (binding)
|
||||||
(stepper-syntax-property binding
|
(stepper-syntax-property binding
|
||||||
'stepper-lifted-name
|
'stepper-lifted-name
|
||||||
(binding-lifted-name mark-list binding)))
|
(binding-lifted-name mark-list binding)))
|
||||||
binding-set)
|
binding-set)
|
||||||
rhs
|
rhs
|
||||||
(map (lambda (arg-binding)
|
(map (lambda (arg-binding)
|
||||||
(lookup-binding mark-list arg-binding))
|
(lookup-binding mark-list arg-binding))
|
||||||
binding-set)))
|
binding-set)))
|
||||||
binding-sets
|
binding-sets
|
||||||
(syntax->list #`(rhs ...)))]
|
(syntax->list #`(rhs ...)))]
|
||||||
[num-defns-done (lookup-binding mark-list let-counter)]
|
[num-defns-done (lookup-binding mark-list let-counter)]
|
||||||
[(vector done-glumps not-done-glumps)
|
[(vector done-glumps not-done-glumps)
|
||||||
(n-split-list num-defns-done glumps)]
|
(n-split-list num-defns-done glumps)]
|
||||||
[recon-lifted
|
[recon-lifted
|
||||||
(lambda (names expr)
|
(lambda (names expr)
|
||||||
#`(#,names #,expr))]
|
#`(#,names #,expr))]
|
||||||
[before-bindings
|
[before-bindings
|
||||||
(map
|
(map
|
||||||
(lambda (glump)
|
(lambda (glump)
|
||||||
(let* ([name-set (let-glump-name-set glump)]
|
(let* ([name-set (let-glump-name-set glump)]
|
||||||
[rhs-val-set (map (lambda (val)
|
[rhs-val-set (map (lambda (val)
|
||||||
(if (> (length name-set) 0)
|
(if (> (length name-set) 0)
|
||||||
(recon-value val render-settings (car name-set))
|
(recon-value val render-settings (car name-set))
|
||||||
(recon-value val render-settings)))
|
(recon-value val render-settings)))
|
||||||
(let-glump-val-set glump))])
|
(let-glump-val-set glump))])
|
||||||
(if (= (length rhs-val-set) 1)
|
(if (= (length rhs-val-set) 1)
|
||||||
#`(#,name-set #,@rhs-val-set)
|
#`(#,name-set #,@rhs-val-set)
|
||||||
#`(#,name-set (values #,rhs-val-set)))))
|
#`(#,name-set (values #,rhs-val-set)))))
|
||||||
done-glumps)]
|
done-glumps)]
|
||||||
[reconstruct-remaining-def
|
[reconstruct-remaining-def
|
||||||
(lambda (glump)
|
(lambda (glump)
|
||||||
(let ([rhs-source (let-glump-exp glump)]
|
(let ([rhs-source (let-glump-exp glump)]
|
||||||
[rhs-name-set (let-glump-name-set glump)])
|
[rhs-name-set (let-glump-name-set glump)])
|
||||||
(recon-lifted rhs-name-set
|
(recon-lifted rhs-name-set
|
||||||
(recon-source-current-marks rhs-source))))]
|
(recon-source-current-marks rhs-source))))]
|
||||||
[after-bindings
|
[after-bindings
|
||||||
(if (pair? not-done-glumps)
|
(if (pair? not-done-glumps)
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
(map reconstruct-remaining-def not-done-glumps)
|
(map reconstruct-remaining-def not-done-glumps)
|
||||||
(cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far)
|
(cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far)
|
||||||
(map reconstruct-remaining-def (cdr not-done-glumps))))
|
(map reconstruct-remaining-def (cdr not-done-glumps))))
|
||||||
null)]
|
null)]
|
||||||
[recon-bindings (append before-bindings after-bindings)]
|
[recon-bindings (append before-bindings after-bindings)]
|
||||||
;; JBC: deleted a bunch of dead code here referring to a never-set "stepper-offset" index...
|
;; JBC: deleted a bunch of dead code here referring to a never-set "stepper-offset" index...
|
||||||
;; frightening.
|
;; frightening.
|
||||||
[rectified-bodies
|
[rectified-bodies
|
||||||
(for/list ([body (in-list (syntax->list #'bodies))])
|
(for/list ([body (in-list (syntax->list #'bodies))])
|
||||||
(recon-source-expr body mark-list binding-list binding-list render-settings))])
|
(recon-source-expr body mark-list binding-list binding-list render-settings))])
|
||||||
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
|
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
|
||||||
|
|
||||||
; STC: cache any running promises in the top mark
|
; STC: cache any running promises in the top mark
|
||||||
; Means that promise is being evaluated.
|
; Means that promise is being evaluated.
|
||||||
; NOTE: This wont wind running promises nested in another promise.
|
; NOTE: This wont wind running promises nested in another promise.
|
||||||
; Those wont be detected until the outer promise is being
|
; Those wont be detected until the outer promise is being
|
||||||
; reconed, so we cant handle it until then.
|
; reconed, so we cant handle it until then.
|
||||||
(let ([maybe-running-promise
|
(let ([maybe-running-promise
|
||||||
(findf (λ (f) (and (promise? f) (nested-promise-running? f)))
|
(findf (λ (f) (and (promise? f) (nested-promise-running? f)))
|
||||||
(map mark-binding-value (mark-bindings top-mark)))])
|
(map mark-binding-value (mark-bindings top-mark)))])
|
||||||
(when (and maybe-running-promise
|
(when (and maybe-running-promise
|
||||||
(not (hash-has-key? partially-evaluated-promises-table
|
(not (hash-has-key? partially-evaluated-promises-table
|
||||||
maybe-running-promise))
|
maybe-running-promise))
|
||||||
(not (eq? so-far nothing-so-far)))
|
(not (eq? so-far nothing-so-far)))
|
||||||
(hash-set! partially-evaluated-promises-table
|
(hash-set! partially-evaluated-promises-table
|
||||||
maybe-running-promise so-far)))
|
maybe-running-promise so-far)))
|
||||||
|
|
||||||
(if (stepper-syntax-property exp 'stepper-fake-exp)
|
(if (stepper-syntax-property exp 'stepper-fake-exp)
|
||||||
|
|
||||||
(kernel:kernel-syntax-case exp #f
|
(kernel:kernel-syntax-case
|
||||||
[(begin . bodies)
|
exp #f
|
||||||
(if (eq? so-far nothing-so-far)
|
[(begin . bodies)
|
||||||
(error 'recon-inner "breakpoint before a begin reduction should have a result value in exp: ~a" (syntax->datum exp))
|
(if (eq? so-far nothing-so-far)
|
||||||
#`(begin #,so-far #,@(map recon-source-current-marks (cdr (syntax->list #'bodies)))))]
|
(error 'recon-inner "breakpoint before a begin reduction should have a result value in exp: ~a" (syntax->datum exp))
|
||||||
[(begin0 first-body . rest-bodies)
|
#`(begin #,so-far #,@(map recon-source-current-marks (cdr (syntax->list #'bodies)))))]
|
||||||
(if (eq? so-far nothing-so-far)
|
[(begin0 first-body . rest-bodies)
|
||||||
(error 'recon-inner "breakpoint before a begin0 reduction should have a result value in exp: ~a" (syntax->datum exp))
|
(if (eq? so-far nothing-so-far)
|
||||||
#`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings)
|
(error 'recon-inner "breakpoint before a begin0 reduction should have a result value in exp: ~a" (syntax->datum exp))
|
||||||
#,so-far
|
#`(begin0 #,(recon-value (lookup-binding mark-list begin0-temp) render-settings)
|
||||||
#,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
|
#,so-far
|
||||||
[else
|
#,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
|
||||||
(error 'recon-inner "unexpected fake-exp expression: ~a" (syntax->datum exp))])
|
[else
|
||||||
|
(error 'recon-inner "unexpected fake-exp expression: ~a" (syntax->datum exp))])
|
||||||
|
|
||||||
(kernel:kernel-syntax-case exp #f
|
(kernel:kernel-syntax-case
|
||||||
; variable references
|
exp #f
|
||||||
[id
|
; variable references
|
||||||
(identifier? (syntax id))
|
[id
|
||||||
(if (eq? so-far nothing-so-far)
|
(identifier? (syntax id))
|
||||||
(recon-source-current-marks exp)
|
(if (eq? so-far nothing-so-far)
|
||||||
(error 'recon-inner "variable reference given as context: ~a" exp))]
|
(recon-source-current-marks exp)
|
||||||
|
(error 'recon-inner "variable reference given as context: ~a" exp))]
|
||||||
|
|
||||||
[(#%top . id)
|
[(#%top . id)
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
(recon-source-current-marks exp)
|
(recon-source-current-marks exp)
|
||||||
(error 'recon-inner "variable reference given as context: ~a" exp))]
|
(error 'recon-inner "variable reference given as context: ~a" exp))]
|
||||||
|
|
||||||
; applications
|
; applications
|
||||||
[(#%plain-app . terms)
|
[(#%plain-app . terms)
|
||||||
(attach-info
|
(attach-info
|
||||||
(match-let*
|
(match-let*
|
||||||
([sub-exprs (syntax->list (syntax terms))]
|
([sub-exprs (syntax->list (syntax terms))]
|
||||||
[arg-temps (build-list (length sub-exprs) get-arg-var)]
|
[arg-temps (build-list (length sub-exprs) get-arg-var)]
|
||||||
[arg-vals (map (lambda (arg-temp)
|
[arg-vals (map (lambda (arg-temp)
|
||||||
(lookup-binding mark-list arg-temp))
|
(lookup-binding mark-list arg-temp))
|
||||||
arg-temps)]
|
arg-temps)]
|
||||||
[(vector evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
|
[(vector evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
|
||||||
(zip sub-exprs arg-vals))]
|
(zip sub-exprs arg-vals))]
|
||||||
[rectified-evaluated (map (lx (recon-value _ render-settings #f so-far))
|
[rectified-evaluated (map (lx (recon-value _ render-settings #f so-far))
|
||||||
(map cadr evaluated))])
|
(map cadr evaluated))])
|
||||||
(case (mark-label (car mark-list))
|
(case (mark-label (car mark-list))
|
||||||
((not-yet-called)
|
((not-yet-called)
|
||||||
(if (null? unevaluated)
|
(if (null? unevaluated)
|
||||||
#`(#%plain-app . #,rectified-evaluated)
|
#`(#%plain-app . #,rectified-evaluated)
|
||||||
#`(#%plain-app
|
#`(#%plain-app
|
||||||
#,@rectified-evaluated
|
#,@rectified-evaluated
|
||||||
#,so-far
|
#,so-far
|
||||||
#,@(map recon-source-current-marks (cdr (map car unevaluated))))))
|
#,@(map recon-source-current-marks (cdr (map car unevaluated))))))
|
||||||
((called) ; unevaluated = null
|
((called) ; unevaluated = null
|
||||||
(stepper-syntax-property
|
(stepper-syntax-property
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur?
|
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur?
|
||||||
; dont show ellipses for force (and other lazy fns)
|
; dont show ellipses for force (and other lazy fns)
|
||||||
; object-name is good enough here, so dont need to add another "special val"
|
; object-name is good enough here, so dont need to add another "special val"
|
||||||
(let ([obj-name (object-name (car arg-vals))])
|
(let ([obj-name (object-name (car arg-vals))])
|
||||||
(cond [(ormap
|
(cond [(ormap
|
||||||
(lx (eq? obj-name _))
|
(lx (eq? obj-name _))
|
||||||
'(force ! !! !list !!list
|
'(force ! !! !list !!list
|
||||||
caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
|
caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
|
||||||
cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||||
first second third fourth fifth sixth seventh eighth take
|
first second third fourth fifth sixth seventh eighth take
|
||||||
eq? eqv? equal? list? length list-ref list-tail append reverse
|
eq? eqv? equal? list? length list-ref list-tail append reverse
|
||||||
empty? assoc assq assv cons? remove remq remv member memq memv))
|
empty? assoc assq assv cons? remove remq remv member memq memv))
|
||||||
#`(#%plain-app . #,rectified-evaluated)]
|
#`(#%plain-app . #,rectified-evaluated)]
|
||||||
[else
|
[else
|
||||||
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))])))
|
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))])))
|
||||||
'stepper-args-of-call
|
'stepper-args-of-call
|
||||||
rectified-evaluated))
|
rectified-evaluated))
|
||||||
(else
|
(else
|
||||||
(error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp))))
|
(error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp))))
|
||||||
exp)]
|
exp)]
|
||||||
|
|
||||||
; define-struct
|
; define-struct
|
||||||
;
|
;
|
||||||
; [(z:struct-form? expr)
|
; [(z:struct-form? expr)
|
||||||
; (if (comes-from-define-struct? expr)
|
; (if (comes-from-define-struct? expr)
|
||||||
; so-far
|
; so-far
|
||||||
; (let ([super-expr (z:struct-form-super expr)]
|
; (let ([super-expr (z:struct-form-super expr)]
|
||||||
; [raw-type (utils:read->raw (z:struct-form-type expr))]
|
; [raw-type (utils:read->raw (z:struct-form-type expr))]
|
||||||
; [raw-fields (map utils:read->raw (z:struct-form-fields expr))])
|
; [raw-fields (map utils:read->raw (z:struct-form-fields expr))])
|
||||||
; (if super-expr
|
; (if super-expr
|
||||||
; `(struct (,raw-type ,so-far)
|
; `(struct (,raw-type ,so-far)
|
||||||
; ,raw-fields)
|
; ,raw-fields)
|
||||||
; `(struct ,raw-type ,raw-fields))))]
|
; `(struct ,raw-type ,raw-fields))))]
|
||||||
|
|
||||||
; if
|
; if
|
||||||
[(if test then else)
|
[(if test then else)
|
||||||
(begin
|
(begin
|
||||||
(when (eq? so-far nothing-so-far)
|
(when (eq? so-far nothing-so-far)
|
||||||
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
||||||
(attach-info
|
(attach-info
|
||||||
#`(if #,so-far
|
#`(if #,so-far
|
||||||
#,(recon-source-current-marks (syntax then))
|
#,(recon-source-current-marks (syntax then))
|
||||||
#,(recon-source-current-marks (syntax else)))
|
#,(recon-source-current-marks (syntax else)))
|
||||||
exp))]
|
exp))]
|
||||||
|
|
||||||
; one-armed if
|
; one-armed if
|
||||||
|
|
||||||
[(if test then)
|
[(if test then)
|
||||||
(begin
|
(begin
|
||||||
(when (eq? so-far nothing-so-far)
|
(when (eq? so-far nothing-so-far)
|
||||||
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
||||||
(attach-info
|
(attach-info
|
||||||
#`(if #,so-far #,(recon-source-current-marks (syntax then)))
|
#`(if #,so-far #,(recon-source-current-marks (syntax then)))
|
||||||
exp))]
|
exp))]
|
||||||
|
|
||||||
; quote : there is no break on a quote.
|
; quote : there is no break on a quote.
|
||||||
|
|
||||||
;; advanced-begin : okay, here comes advanced-begin.
|
;; advanced-begin : okay, here comes advanced-begin.
|
||||||
|
|
||||||
[(begin . terms)
|
[(begin . terms)
|
||||||
;; even in advanced, begin expands into a let-values.
|
;; even in advanced, begin expands into a let-values.
|
||||||
(error 'reconstruct/inner "begin in non-teaching-languages not implemented in reconstruct")]
|
(error 'reconstruct/inner "begin in non-teaching-languages not implemented in reconstruct")]
|
||||||
|
|
||||||
; begin : in the current expansion of begin, there are only two-element begin's, one-element begins, and
|
; 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 ... ?
|
;; zero-element begins; these arise as the expansion of ... ?
|
||||||
|
|
||||||
;; these are all dead code, right?
|
;; these are all dead code, right?
|
||||||
|
|
||||||
#;[(begin stx-a stx-b)
|
#;[(begin stx-a stx-b)
|
||||||
(attach-info
|
(attach-info
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
#`(begin #,(recon-source-current-marks #`stx-a) #,(recon-source-current-marks #`stx-b))
|
#`(begin #,(recon-source-current-marks #`stx-a) #,(recon-source-current-marks #`stx-b))
|
||||||
#`(begin #,so-far #,(recon-source-current-marks #`stx-b))))]
|
#`(begin #,so-far #,(recon-source-current-marks #`stx-b))))]
|
||||||
|
|
||||||
#;[(begin clause)
|
#;[(begin clause)
|
||||||
(attach-info
|
(attach-info
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
#`(begin #,(recon-source-current-marks (syntax clause)))
|
#`(begin #,(recon-source-current-marks (syntax clause)))
|
||||||
(error
|
(error
|
||||||
'recon-inner
|
'recon-inner
|
||||||
"stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax->datum exp)))
|
"stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax->datum exp)))
|
||||||
exp)]
|
exp)]
|
||||||
|
|
||||||
#;[(begin)
|
#;[(begin)
|
||||||
(attach-info
|
(attach-info
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
#`(begin)
|
#`(begin)
|
||||||
(error
|
(error
|
||||||
'recon-inner
|
'recon-inner
|
||||||
"stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax->datum exp))))]
|
"stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax->datum exp))))]
|
||||||
|
|
||||||
; begin0 :
|
; begin0 :
|
||||||
;; one-body begin0: perhaps this will turn out to be a special case of the
|
;; one-body begin0: perhaps this will turn out to be a special case of the
|
||||||
;; many-body case.
|
;; many-body case.
|
||||||
[(begin0 body)
|
[(begin0 body)
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
(recon-source-current-marks exp)
|
(recon-source-current-marks exp)
|
||||||
(error 'recon-inner "one-body begin0 given as context: ~a" exp))]
|
(error 'recon-inner "one-body begin0 given as context: ~a" exp))]
|
||||||
|
|
||||||
;; the only time begin0 shows up other than in a fake-exp is when the first
|
;; the only time begin0 shows up other than in a fake-exp is when the first
|
||||||
;; term is being evaluated
|
;; term is being evaluated
|
||||||
[(begin0 first-body . rest-bodies)
|
[(begin0 first-body . rest-bodies)
|
||||||
(if (eq? so-far nothing-so-far)
|
(if (eq? so-far nothing-so-far)
|
||||||
(error 'foo "not implemented")
|
(error 'foo "not implemented")
|
||||||
;; don't know what goes hereyet
|
;; don't know what goes hereyet
|
||||||
#`(begin0 #,so-far #,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
|
#`(begin0 #,so-far #,@(map recon-source-current-marks (syntax->list #`rest-bodies))))]
|
||||||
|
|
||||||
; let-values
|
; let-values
|
||||||
|
|
||||||
[(let-values . rest) (recon-let)]
|
[(let-values . rest) (recon-let)]
|
||||||
|
|
||||||
[(letrec-values . rest) (recon-let)]
|
[(letrec-values . rest) (recon-let)]
|
||||||
|
|
||||||
[(set! var rhs)
|
[(set! var rhs)
|
||||||
(begin
|
(begin
|
||||||
(when (eq? so-far nothing-so-far)
|
(when (eq? so-far nothing-so-far)
|
||||||
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
(error 'reconstruct "breakpoint before an if reduction should have a result value"))
|
||||||
(attach-info
|
(attach-info
|
||||||
(let ([rendered-var (reconstruct-set!-var mark-list #`var)])
|
(let ([rendered-var (reconstruct-set!-var mark-list #`var)])
|
||||||
#`(set! #,rendered-var #,so-far))
|
#`(set! #,rendered-var #,so-far))
|
||||||
exp))]
|
exp))]
|
||||||
|
|
||||||
; lambda : there is no break on a lambda
|
; lambda : there is no break on a lambda
|
||||||
|
|
||||||
[else
|
[else
|
||||||
(error
|
(error
|
||||||
'recon-inner
|
'recon-inner
|
||||||
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
|
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
|
||||||
|
|
||||||
; the main recursive reconstruction loop is in recon:
|
; the main recursive reconstruction loop is in recon:
|
||||||
; recon : (syntax mark-list boolean -> syntax)
|
; recon : (syntax mark-list boolean -> syntax)
|
||||||
|
|
||||||
(define (recon so-far mark-list first)
|
(define (recon so-far mark-list first)
|
||||||
(cond [(null? mark-list) ; now taken to indicate a callback:
|
(cond [(null? mark-list) ; now taken to indicate a callback:
|
||||||
(unless (eq? so-far nothing-so-far)
|
(unless (eq? so-far nothing-so-far)
|
||||||
(set! last-so-far so-far))
|
(set! last-so-far so-far))
|
||||||
so-far
|
so-far
|
||||||
;(error `recon "expcted a top-level mark at the end of the mark list.")
|
;(error `recon "expcted a top-level mark at the end of the mark list.")
|
||||||
]
|
]
|
||||||
|
[else
|
||||||
|
(case (mark-label (car mark-list))
|
||||||
|
[(top-level)
|
||||||
|
(if (null? (cdr mark-list))
|
||||||
|
(reconstruct-top-level (mark-source (car mark-list)) so-far)
|
||||||
|
(error 'recon "top-level-define mark found at non-end of mark list"))]
|
||||||
[else
|
[else
|
||||||
(case (mark-label (car mark-list))
|
(let ([reconstructed (recon-inner mark-list so-far)])
|
||||||
[(top-level)
|
(recon
|
||||||
(if (null? (cdr mark-list))
|
(if first
|
||||||
(reconstruct-top-level (mark-source (car mark-list)) so-far)
|
(mark-as-highlight reconstructed)
|
||||||
(error 'recon "top-level-define mark found at non-end of mark list"))]
|
reconstructed)
|
||||||
[else
|
(cdr mark-list)
|
||||||
(let ([reconstructed (recon-inner mark-list so-far)])
|
#f))])]))
|
||||||
(recon
|
|
||||||
(if first
|
|
||||||
(mark-as-highlight reconstructed)
|
|
||||||
reconstructed)
|
|
||||||
(cdr mark-list)
|
|
||||||
#f))])]))
|
|
||||||
|
|
||||||
; uncomment to see all breaks coming in:
|
; uncomment to see all breaks coming in:
|
||||||
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n"
|
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n"
|
||||||
break-kind
|
break-kind
|
||||||
(and (pair? mark-list)
|
(and (pair? mark-list)
|
||||||
(syntax->datum (mark-source (car mark-list))))
|
(syntax->datum (mark-source (car mark-list))))
|
||||||
returned-value-list))
|
returned-value-list))
|
||||||
|
|
||||||
(define answer
|
(define answer
|
||||||
(begin
|
(begin
|
||||||
; STC: reset partial-eval-promise table on each call to recon
|
; STC: reset partial-eval-promise table on each call to recon
|
||||||
(set! partially-evaluated-promises-table (make-weak-hash))
|
(set! partially-evaluated-promises-table (make-weak-hash))
|
||||||
(set! last-so-far null)
|
(set! last-so-far null)
|
||||||
|
|
||||||
(case break-kind
|
|
||||||
((left-side)
|
|
||||||
(let* ([innermost
|
|
||||||
(if returned-value-list ; is it a normal-break/values?
|
|
||||||
(begin
|
|
||||||
(unless (and (pair? returned-value-list)
|
|
||||||
(null? (cdr returned-value-list)))
|
|
||||||
(error 'reconstruct
|
|
||||||
"context expected one value, given ~v"
|
|
||||||
returned-value-list))
|
|
||||||
(recon-value (car returned-value-list) render-settings))
|
|
||||||
nothing-so-far)])
|
|
||||||
(recon innermost mark-list #t)))
|
|
||||||
((right-side)
|
|
||||||
(let* ([innermost
|
|
||||||
(if returned-value-list ; is it an expr -> value reduction?
|
|
||||||
(begin
|
|
||||||
(unless (and (pair? returned-value-list)
|
|
||||||
(null? (cdr returned-value-list)))
|
|
||||||
(error 'reconstruct
|
|
||||||
"context expected one value, given ~v"
|
|
||||||
returned-value-list))
|
|
||||||
(recon-value (car returned-value-list) render-settings))
|
|
||||||
(recon-source-expr (mark-source (car mark-list))
|
|
||||||
mark-list null null render-settings))])
|
|
||||||
(recon (mark-as-highlight innermost) (cdr mark-list) #f)))
|
|
||||||
((double-break)
|
|
||||||
(let* ([source-expr (mark-source (car mark-list))]
|
|
||||||
[innermost-before
|
|
||||||
(mark-as-highlight
|
|
||||||
(recon-source-expr source-expr mark-list null null render-settings))]
|
|
||||||
[newly-lifted-bindings
|
|
||||||
(syntax-case source-expr (letrec-values)
|
|
||||||
[(letrec-values ([vars . rest] ...) . bodies)
|
|
||||||
(apply append (map syntax->list (syntax->list #`(vars ...))))]
|
|
||||||
[(let-values ([vars . rest] ...) . bodies)
|
|
||||||
(apply append (map syntax->list (syntax->list #`(vars ...))))]
|
|
||||||
[else (error
|
|
||||||
'reconstruct
|
|
||||||
"expected a let-values as source for a double-break, got: ~.s"
|
|
||||||
(syntax->datum source-expr))])]
|
|
||||||
[innermost-after
|
|
||||||
(mark-as-highlight
|
|
||||||
(recon-source-expr
|
|
||||||
(mark-source (car mark-list))
|
|
||||||
mark-list null newly-lifted-bindings render-settings))])
|
|
||||||
(list (recon innermost-before (cdr mark-list) #f)
|
|
||||||
(recon innermost-after (cdr mark-list) #f)))))))
|
|
||||||
)
|
|
||||||
|
|
||||||
answer
|
|
||||||
))
|
|
||||||
|
|
||||||
|
(case break-kind
|
||||||
|
((left-side)
|
||||||
|
(let* ([innermost
|
||||||
|
(if returned-value-list ; is it a normal-break/values?
|
||||||
|
(begin
|
||||||
|
(unless (and (pair? returned-value-list)
|
||||||
|
(null? (cdr returned-value-list)))
|
||||||
|
(error 'reconstruct
|
||||||
|
"context expected one value, given ~v"
|
||||||
|
returned-value-list))
|
||||||
|
(recon-value (car returned-value-list) render-settings))
|
||||||
|
nothing-so-far)])
|
||||||
|
(recon innermost mark-list #t)))
|
||||||
|
((right-side)
|
||||||
|
(let* ([innermost
|
||||||
|
(if returned-value-list ; is it an expr -> value reduction?
|
||||||
|
(begin
|
||||||
|
(unless (and (pair? returned-value-list)
|
||||||
|
(null? (cdr returned-value-list)))
|
||||||
|
(error 'reconstruct
|
||||||
|
"context expected one value, given ~v"
|
||||||
|
returned-value-list))
|
||||||
|
(recon-value (car returned-value-list) render-settings))
|
||||||
|
(recon-source-expr (mark-source (car mark-list))
|
||||||
|
mark-list null null render-settings))])
|
||||||
|
(recon (mark-as-highlight innermost) (cdr mark-list) #f)))
|
||||||
|
((double-break)
|
||||||
|
(let* ([source-expr (mark-source (car mark-list))]
|
||||||
|
[innermost-before
|
||||||
|
(mark-as-highlight
|
||||||
|
(recon-source-expr source-expr mark-list null null render-settings))]
|
||||||
|
[newly-lifted-bindings
|
||||||
|
(syntax-case source-expr (letrec-values)
|
||||||
|
[(letrec-values ([vars . rest] ...) . bodies)
|
||||||
|
(apply append (map syntax->list (syntax->list #`(vars ...))))]
|
||||||
|
[(let-values ([vars . rest] ...) . bodies)
|
||||||
|
(apply append (map syntax->list (syntax->list #`(vars ...))))]
|
||||||
|
[else (error
|
||||||
|
'reconstruct
|
||||||
|
"expected a let-values as source for a double-break, got: ~.s"
|
||||||
|
(syntax->datum source-expr))])]
|
||||||
|
[innermost-after
|
||||||
|
(mark-as-highlight
|
||||||
|
(recon-source-expr
|
||||||
|
(mark-source (car mark-list))
|
||||||
|
mark-list null newly-lifted-bindings render-settings))])
|
||||||
|
(list (recon innermost-before (cdr mark-list) #f)
|
||||||
|
(recon innermost-after (cdr mark-list) #f)))))))
|
||||||
|
|
||||||
|
|
||||||
|
answer
|
||||||
)
|
)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user