suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactored to pull out macro unwinding

Browse Source 
svn: r2350
This commit is contained in:
John Clements 2006-03-02 23:45:42 +00:00
parent 238b744d99
commit 52db4e170a
3 changed files with 482 additions and 471 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

256
collects/stepper/private/macro-unwind.ss Normal file
View File

@ -0,0 +1,256 @@
(module macro-unwind mzscheme
(require (prefix kernel: (lib "kerncase.ss" "syntax"))
(lib "etc.ss")
(lib "contract.ss")
"shared.ss"
"lifting.ss")
(provide/contract [unwind (syntax? boolean? . -> . (listof syntax?))]
[unwind-no-highlight (syntax? . -> . (listof syntax?))])
; ; ;
;
; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ;
;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;
; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ;
;
; unwind takes a syntax object with a single highlight,
; and returns a list of syntax objects
(define (unwind stx lift-at-highlight?)
(macro-unwind (lift stx lift-at-highlight?)))
; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that
; makes it more obvious what it does.
; [unwind-no-highlight (-> syntax? (listof syntax?))]
(define (unwind-no-highlight stx)
(macro-unwind (list stx)))
; unwind-only-highlight : syntax? -> (listof syntax?)
(define (unwind-only-highlight stx)
(unwind stx #t))
(define (improper-member elt improper-list)
(cond [(pair? improper-list)
(or (eq? elt (car improper-list))
(improper-member elt (cdr improper-list)))]
[else
(eq? elt improper-list)]))
(define-syntax (noisy-and stx)
(syntax-case stx ()
[(_) #`#t]
[(_ a b ...)
(with-syntax ([inner (syntax/loc stx (noisy-and b ...))]
[error (syntax/loc #`a (error 'noisy-and "and clause failed"))])
(syntax/loc stx (if a inner error)))]
[else
(error 'noisy-and "bad syntax for noisy-and")]))
;(->* (syntax? (listof syntax?))
; (syntax? (listof syntax?)))
(define (macro-unwind stxs)
(local
((define (recur-on-pieces stx)
(if (pair? (syntax-e stx))
(datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx)
stx))
(define (inner stx)
(define (fall-through)
(kernel:kernel-syntax-case stx #f
[id
(identifier? stx)
(or (syntax-property stx 'stepper-lifted-name)
stx)]
[(define-values dc ...)
(unwind-define stx)]
[(#%app exp ...)
(recur-on-pieces #'(exp ...))]
[(#%datum . datum)
#'datum]
[(let-values . rest)
(unwind-mz-let stx)]
[(letrec-values . rest)
(unwind-mz-let stx)]
[(set! var rhs)
(with-syntax ([unwound-var (or (syntax-property #`var 'stepper-lifted-name) #`var)]
[unwound-body (inner #`rhs)])
#`(set! unwound-var unwound-body))]
[else
(recur-on-pieces stx)]))
(transfer-info
(if (syntax-property stx 'user-stepper-hint)
(case (syntax-property stx 'user-stepper-hint)
[(comes-from-cond) (unwind-cond stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position))]
[(comes-from-and) (unwind-and/or stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position)
'and)]
[(comes-from-or) (unwind-and/or stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position)
'or)]
[(comes-from-local)
(unwind-local stx)]
[(comes-from-recur)
(unwind-recur stx)]
[(comes-from-begin)
(unwind-begin stx)]
(else (fall-through)))
(fall-through))
stx))
(define (transfer-highlight from to)
(if (syntax-property from 'stepper-highlight)
(syntax-property to 'stepper-highlight #t)
to))
(define (unwind-recur stx)
(with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here
(with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))])
(let ([unwound (inner #`letrec-term)])
(syntax-case unwound (letrec lambda)
[(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2)
(unless (module-identifier=? #`loop-name #`loop-name-2)
(error "unexpected syntax for 'recur': ~v" stx))
(transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))]
[else #`(#,unwound new-argval ...)])))))
(define (unwind-define stx)
(kernel:kernel-syntax-case stx #f
[(define-values (name . others) body)
(begin
(unless (null? (syntax-e #'others))
(error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx)))
(let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name)
(syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (inner #'body)]
[define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt
(if define-type
(kernel:kernel-syntax-case unwound-body #f
[(lambda arglist lam-body ...)
(case define-type
[(shortened-proc-define)
(let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name #'name)
(and (syntax-property #'name 'stepper-orig-name)
(module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name))))
#`(define (#,printed-name . arglist) lam-body ...)
#`(define #,printed-name #,unwound-body)))]
[(lambda-define)
#`(define #,printed-name #,unwound-body)]
[else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])]
[else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))])
#`(define #,printed-name #,unwound-body))))]
[else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))]))
(define (unwind-mz-let stx)
(with-syntax ([(label ([(var) rhs] ...) . bodies) stx])
(with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))]
[new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
#`let*
(case (syntax-e #'label)
[(let-values) #'let]
[(letrec-values) #'letrec]))]
[new-bodies (map inner (syntax->list #'bodies))])
(syntax-case #`new-bodies (let*) ; is this let and the nested one part of a let*?
[((let* bindings inner-body ...))
(and
(improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
(eq? (syntax-property stx 'user-stepper-source)
(syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source))
(eq? (syntax-property stx 'user-stepper-position)
(syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position)))
#`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)]
[else
#`(new-label ([var rhs2] ...) . new-bodies)]))))
(define (unwind-local stx)
(kernel:kernel-syntax-case stx #f
[(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local.
(with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))])
#`(local defns #,(inner #'body)))]
[else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))]))
;(define (unwind-quasiquote-the-cons-application stx)
; (syntax-case (recur-on-pieces stx) ()
; [(#%app the-cons . rest)
; (syntax (cons . rest))]
; [else
; (error 'reconstruct "unexpected result for unwinding the-cons application")]))
(define (unwind-cond-clause stx test-stx result-stx)
(with-syntax ([new-test (if (syntax-property stx 'user-stepper-else)
#`else
(inner test-stx))]
[result (inner result-stx)])
#`(new-test result)))
(define (unwind-cond stx user-source user-position)
(with-syntax ([clauses
(let loop ([stx stx])
(if (and (eq? user-source (syntax-property stx 'user-source))
(eq? user-position (syntax-property stx 'user-position)))
(syntax-case stx (if begin #%app)
[(if test result) ; the else clause disappears when it's a language-inserted else clause
(list (unwind-cond-clause stx #`test #`result))]
[(if test result else-clause)
(cons (unwind-cond-clause stx #`test #`result)
(loop (syntax else-clause)))]
[(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely'
null]
[else-stx
(error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))])
(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]
[(or) #`false])])
(with-syntax ([clauses
(append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder))
(let loop ([stx stx])
(if (and (eq? user-source (syntax-property stx 'user-source))
(eq? user-position (syntax-property stx 'user-position)))
(syntax-case stx (if let-values #%datum)
[(if part-1 part-2 part-3)
(cons (inner (syntax part-1))
(case label
((and)
(loop (syntax part-2)))
((or)
(loop (syntax part-3)))
(else
(error 'unwind-and/or "unknown label ~a" label))))]
[else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))])
null)))])
#`(#,label . clauses)))))
(map inner stxs))))

392
collects/stepper/private/model.ss
View File

@ -36,24 +36,22 @@
(module model mzscheme (module model mzscheme
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss")
(lib "match.ss") (lib "match.ss")
"my-macros.ss"
(prefix a: "annotate.ss") (prefix a: "annotate.ss")
(prefix r: "reconstruct.ss") (prefix r: "reconstruct.ss")
"shared.ss" "shared.ss"
"marks.ss" "marks.ss"
"testing-shared.ss" "model-settings.ss"
"model-settings.ss") "macro-unwind.ss")
(define program-expander-contract (define program-expander-contract
((-> void?) ; init ((-> void?) ; init
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
. -> . . -> .
void?)) void?))
(provide/contract [go (program-expander-contract ; program-expander (provide/contract [go (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result (step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c) ; render-settings (or/c render-settings? false/c) ; render-settings
@ -95,200 +93,202 @@
;; in fact, just test for eq?-ness. ;; in fact, just test for eq?-ness.
#;(define (highlight-mutated-expressions lefts rights) #;(define (highlight-mutated-expressions lefts rights)
(if (or (null? lefts) (null? rights)) (if (or (null? lefts) (null? rights))
(list lefts rights) (list lefts rights)
(let ([left-car (car lefts)] (let ([left-car (car lefts)]
[right-car (car rights)]) [right-car (car rights)])
(if (eq? (syntax-property left-car 'user-source) (if (eq? (syntax-property left-car 'user-source)
(syntax-property right-car 'user-source)) (syntax-property right-car 'user-source))
(let ([highlights-added (highlight-mutated-expression left-car right-car)] (let ([highlights-added (highlight-mutated-expression left-car right-car)]
[rest (highlight-mutated-expressions (cdr lefts) (cdr rights))]) [rest (highlight-mutated-expressions (cdr lefts) (cdr rights))])
(cons (cons (car highlights-added) (car rest)) (cons (cons (car highlights-added) (car rest))
(cons (cadr highlights-added) (cadr rest)))))))) (cons (cadr highlights-added) (cadr rest))))))))
;; highlight-mutated-expression: syntax? syntax? -> syntax? ;; highlight-mutated-expression: syntax? syntax? -> syntax?
;; given two expressions, highlight 'em both if they differ at all. ;; 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. ;; 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 ;; 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. ;; that the highlighting follows from the reductions but can't obviously be deduced from them.
#;(define (highlight-mutated-expression left right) #;(define (highlight-mutated-expression left right)
(cond (cond
;; if either one is already highlighted, leave them alone. ;; if either one is already highlighted, leave them alone.
[(or (syntax-property left 'stepper-highlight) [(or (syntax-property left 'stepper-highlight)
(syntax-property right 'stepper-highlight)) (syntax-property right 'stepper-highlight))
(list left right)] (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))]))
;; first pass: highlight if not eq?. Should be broken for local-bound things ;; REDIVIDE MAKES NO SENSE IN THE NEW INTERFACE. THIS WILL BE DELETED AFTER BEING PARTED OUT.
;; as they pass into permanence. ; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists,
[(eq? left right) ; where the before and after sets are maximal-length lists where none of the s-expressions contain
(list left right)] ; a highlight-placeholder
; (->* ((listof syntax)) (list/c syntax syntax syntax))
[else (list (syntax-property left 'stepper-highlight) #;(define (redivide exprs)
(syntax-property right 'stepper-highlight))])) (letrec ([contains-highlight
(lambda (expr)
;; REDIVIDE MAKES NO SENSE IN THE NEW INTERFACE. THIS WILL BE DELETED AFTER BEING PARTED OUT. (or (syntax-property expr 'stepper-highlight)
; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists, (syntax-case expr ()
; where the before and after sets are maximal-length lists where none of the s-expressions contain [(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))]
; a highlight-placeholder [else #f])))])
; (->* ((listof syntax)) (list/c syntax syntax syntax)) (let* ([list-length (length exprs)]
#;(define (redivide exprs) [split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))]
(letrec ([contains-highlight [split-point-b (length (or (memf contains-highlight (reverse exprs)) null))])
(lambda (expr) (if (<= split-point-b split-point-a)
(or (syntax-property expr 'stepper-highlight) (error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs))
(syntax-case expr () (values (sublist 0 split-point-a exprs) ; before
[(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))] (sublist split-point-a split-point-b exprs) ; during
[else #f])))]) (sublist split-point-b list-length exprs)))))) ; after
(let* ([list-length (length exprs)]
[split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))]
[split-point-b (length (or (memf contains-highlight (reverse exprs)) null))])
(if (<= split-point-b split-point-a)
(error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs))
(values (sublist 0 split-point-a exprs) ; before
(sublist split-point-a split-point-b exprs) ; during
(sublist split-point-b list-length exprs)))))) ; after
; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6))
; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6))
;
; (redivide `(,highlight-placeholder 5 6))
; (values `() `(,highlight-placeholder) `(5 6))
;
; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder))
; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `())
;
; (printf "will be errors:~n")
; (equal? (redivide `(1 2 3 4))
; error-value)
;
; (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 #f])
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed)
(map (match-lambda
[`(,source-thunk ,lifting-indices ,getter)
(r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)])
finished-exps))
;; TO BE SCRAPPED ; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6))
#;(define (double-redivide finished-exps new-exprs-before new-exprs-after) ; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6))
(let*-values ([(before current after) (redivide new-exprs-before)] ;
[(before-2 current-2 after-2) (redivide new-exprs-after)]) ; (redivide `(,highlight-placeholder 5 6))
(unless (equal? (map syntax-object->hilite-datum before) ; (values `() `(,highlight-placeholder) `(5 6))
(map syntax-object->hilite-datum before-2)) ;
(error 'double-redivide "reconstructed before defs are not equal.")) ; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder))
(unless (equal? (map syntax-object->hilite-datum after) ; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `())
(map syntax-object->hilite-datum after-2)) ;
(error 'double-redivide "reconstructed after defs are not equal.")) ; (printf "will be errors:~n")
(values (append finished-exps before) current current-2 after))) ; (equal? (redivide `(1 2 3 4))
; error-value)
;
; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5))
; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5))
#;(printf "break called with break-kind: ~a ..." break-kind) (define (>>> x)
(if (r:skip-step? break-kind mark-list render-settings) (fprintf (current-output-port) ">>> ~v\n" x)
(begin x)
#;(printf " but it was skipped!\n")
(when (or (eq? break-kind 'normal-break) (define break
(eq? break-kind 'nomal-break/values)) ;; not sure about this... (opt-lambda (mark-set break-kind [returned-value-list #f])
(set! held-exp-list skipped-step)))
(begin
#;(printf "and it wasn't skipped.\n") (let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(case break-kind
[(normal-break normal-break/values)
(begin
(when (and (eq? break-kind 'normal-break) returned-value-list)
(error 'break "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list (r:reconstruct-left-side mark-list returned-value-list render-settings))
(set! held-step-was-app? (r:step-was-app? mark-list)))]
[(result-exp-break result-value-break) (define (reconstruct-all-completed)
(if (eq? held-exp-list skipped-step) (map (match-lambda
; don't render if before step was a skipped-step [`(,source-thunk ,lifting-indices ,getter)
(set! held-exp-list no-sexp) (match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)
[#(exp #f) (first-of-one (unwind-no-highlight exp))]
(let* ([new-finished-list (reconstruct-all-completed)] [#(exp #t) exp])])
[reconstructed (r:reconstruct-right-side mark-list returned-value-list render-settings)] finished-exps))
[result
(if (eq? held-exp-list no-sexp)
;; in this case, there was no "before" step, due to
;; unannotated code. In this case, we make the
;; optimistic guess that none of the finished expressions
;; were mutated. It would be somewhat painful to do a better
;; job, and the stepper makes no guarantees in this case.
(make-before-after-result
(list #`(... ...))
(append new-finished-list reconstructed)
'normal)
(let*-values
([(step-kind) (if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal)]
[(left-exps right-exps)
;; write this later:
#;(identify-changed (append held-finished-list held-exps) (append new-finished-list reconstructed))
(values (append held-finished-list held-exp-list)
(append new-finished-list reconstructed))])
(make-before-after-result left-exps right-exps step-kind)))])
(set! held-exp-list no-sexp)
(receive-result result)))]
[(double-break) ;; TO BE SCRAPPED
;; a double-break occurs at the beginning of a let's evaluation. #;(define (double-redivide finished-exps new-exprs-before new-exprs-after)
(when (not (eq? held-exp-list no-sexp)) (let*-values ([(before current after) (redivide new-exprs-before)]
(error 'break-reconstruction [(before-2 current-2 after-2) (redivide new-exprs-after)])
"held-exp-list not empty when a double-break occurred")) (unless (equal? (map syntax-object->hilite-datum before)
(let* ([new-finished-list (reconstruct-all-completed)] (map syntax-object->hilite-datum before-2))
[reconstruct-result (r:reconstruct-double-break mark-list render-settings)] (error 'double-redivide "reconstructed before defs are not equal."))
[left-side (car reconstruct-result)] (unless (equal? (map syntax-object->hilite-datum after)
[right-side (cadr reconstruct-result)]) (map syntax-object->hilite-datum after-2))
;; add highlighting code as for other cases... (error 'double-redivide "reconstructed after defs are not equal."))
(receive-result (make-before-after-result (append new-finished-list left-side) (values (append finished-exps before) current current-2 after)))
(append new-finished-list right-side)
'normal)))]
#;(printf "break called with break-kind: ~a ..." break-kind)
[(expr-finished-break) (if (r:skip-step? break-kind mark-list render-settings)
(unless (not mark-list) (begin
(error 'break "expected no mark-list with expr-finished-break")) #;(printf " but it was skipped!\n")
;; in an expr-finished-break, the returned-vals hold (listof (list/c source lifting-index getter)) (when (or (eq? break-kind 'normal-break)
;; this will now include define-struct breaks, for which the source is the source and the getter (eq? break-kind 'nomal-break/values)) ;; not sure about this...
;; causes an error. (set! held-exp-list skipped-step)))
(for-each (lambda (source/index/getter)
(apply add-to-finished source/index/getter)) (begin
returned-value-list)] #;(printf "and it wasn't skipped.\n")
(case break-kind
[else (error 'break "unknown label on break")])))))) [(normal-break normal-break/values)
(begin
(when (and (eq? break-kind 'normal-break) returned-value-list)
(error 'break "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed))
(define (step-through-expression expanded expand-next-expression) (set! held-exp-list (unwind (r:reconstruct-left-side mark-list returned-value-list render-settings) #f))
(let* ([annotated (a:annotate expanded break track-inferred-names?)]) (set! held-step-was-app? (r:step-was-app? mark-list)))]
(eval-syntax annotated)
(expand-next-expression))) [(result-exp-break result-value-break)
(if (eq? held-exp-list skipped-step)
(define (err-display-handler message exn) ; don't render if before step was a skipped-step
(if (not (eq? held-exp-list no-sexp)) (set! held-exp-list no-sexp)
(begin
(receive-result (make-before-error-result (append held-finished-list held-exp-list) (let* ([new-finished-list (reconstruct-all-completed)]
message)) [reconstructed (unwind (r:reconstruct-right-side mark-list returned-value-list render-settings) #f)]
(set! held-exp-list no-sexp)) [result
(receive-result (make-error-result message))))) (if (eq? held-exp-list no-sexp)
;; in this case, there was no "before" step, due to
;; unannotated code. In this case, we make the
;; optimistic guess that none of the finished expressions
;; were mutated. It would be somewhat painful to do a better
;; job, and the stepper makes no guarantees in this case.
(make-before-after-result
(list #`(... ...))
(append new-finished-list reconstructed)
'normal)
(let*-values
([(step-kind) (if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal)]
[(left-exps right-exps)
;; write this later:
#;(identify-changed (append held-finished-list held-exps) (append new-finished-list reconstructed))
(values (append held-finished-list held-exp-list)
(append new-finished-list reconstructed))])
(make-before-after-result left-exps right-exps step-kind)))])
(set! held-exp-list no-sexp)
(receive-result result)))]
[(double-break)
;; 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"))
(let* ([new-finished-list (reconstruct-all-completed)]
[reconstruct-result (r:reconstruct-double-break mark-list render-settings)]
[left-side (unwind (car reconstruct-result) #f)]
[right-side (unwind (cadr reconstruct-result) #t)])
;; add highlighting code as for other cases...
(receive-result (make-before-after-result (append new-finished-list left-side)
(append new-finished-list right-side)
'normal)))]
[(expr-finished-break)
(unless (not mark-list)
(error 'break "expected no mark-list with expr-finished-break"))
;; in an expr-finished-break, the returned-vals hold (listof (list/c source lifting-index getter))
;; this will now include define-struct breaks, for which the source is the source and the getter
;; causes an error.
(for-each (lambda (source/index/getter)
(apply add-to-finished source/index/getter))
returned-value-list)]
[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)
(expand-next-expression)))
(define (err-display-handler message exn)
(if (not (eq? held-exp-list no-sexp))
(begin
(receive-result (make-before-error-result (append held-finished-list held-exp-list)
message))
(set! held-exp-list no-sexp))
(receive-result (make-error-result message)))))
(program-expander (program-expander
(lambda () (lambda ()
@ -300,5 +300,11 @@
(if (eof-object? expanded) (if (eof-object? expanded)
(begin (begin
(receive-result (make-finished-stepping))) (receive-result (make-finished-stepping)))
(step-through-expression expanded continue-thunk))))))) (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)))

305
collects/stepper/private/reconstruct.ss
View File

@ -11,8 +11,7 @@
"marks.ss" "marks.ss"
"model-settings.ss" "model-settings.ss"
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss")
"lifting.ss")
(provide/contract (provide/contract
[reconstruct-completed (syntax? [reconstruct-completed (syntax?
@ -20,23 +19,23 @@
(-> (listof any/c)) (-> (listof any/c))
render-settings? render-settings?
. -> . . -> .
syntax?)] (vector/c syntax? boolean?))]
;; front ends for reconstruct-current ;; front ends for reconstruct-current
[reconstruct-left-side (mark-list? [reconstruct-left-side (mark-list?
(or/c (listof any/c) false/c) (or/c (listof any/c) false/c)
render-settings? render-settings?
. -> . . -> .
(listof syntax?))] syntax?)]
[reconstruct-right-side (mark-list? [reconstruct-right-side (mark-list?
(or/c (listof any/c) false/c) (or/c (listof any/c) false/c)
render-settings? render-settings?
. -> . . -> .
(listof syntax?))] syntax?)]
[reconstruct-double-break (mark-list? [reconstruct-double-break (mark-list?
render-settings? render-settings?
. -> . . -> .
(list/c (listof syntax?) (listof syntax?)))] (list/c syntax? syntax?))]
[final-mark-list? (-> mark-list? boolean?)] [final-mark-list? (-> mark-list? boolean?)]
[skip-step? (-> break-kind? (or/c mark-list? false/c) render-settings? boolean?)] [skip-step? (-> break-kind? (or/c mark-list? false/c) render-settings? boolean?)]
@ -257,258 +256,7 @@
#t] #t]
[else [else
#f]))) #f])))
; ; ;
;
; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ;
;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;
; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ;
;
; unwind takes a syntax object with a single highlight,
; and returns a list of syntax objects
(define (unwind stx lift-at-highlight?)
(macro-unwind (lift stx lift-at-highlight?)))
; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that
; makes it more obvious what it does.
; [unwind-no-highlight (-> syntax? (listof syntax?))]
(define (unwind-no-highlight stx)
(macro-unwind (list stx)))
; unwind-only-highlight : syntax? -> (listof syntax?)
(define (unwind-only-highlight stx)
(unwind stx #t))
(define (first-of-one x)
(unless (= (length x) 1)
(error 'first-of-one "expected a list of length one in: ~v" x))
(car x))
(define (improper-member elt improper-list)
(cond [(pair? improper-list)
(or (eq? elt (car improper-list))
(improper-member elt (cdr improper-list)))]
[else
(eq? elt improper-list)]))
(define-syntax (noisy-and stx)
(syntax-case stx ()
[(_) #`#t]
[(_ a b ...)
(with-syntax ([inner (syntax/loc stx (noisy-and b ...))]
[error (syntax/loc #`a (error 'noisy-and "and clause failed"))])
(syntax/loc stx (if a inner error)))]
[else
(error 'noisy-and "bad syntax for noisy-and")]))
;(->* (syntax? (listof syntax?))
; (syntax? (listof syntax?)))
(define (macro-unwind stxs)
(local
((define (recur-on-pieces stx)
(if (pair? (syntax-e stx))
(datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx)
stx))
(define (inner stx)
(define (fall-through)
(kernel:kernel-syntax-case stx #f
[id
(identifier? stx)
(or (syntax-property stx 'stepper-lifted-name)
stx)]
[(define-values dc ...)
(unwind-define stx)]
[(#%app exp ...)
(recur-on-pieces #'(exp ...))]
[(#%datum . datum)
#'datum]
[(let-values . rest)
(unwind-mz-let stx)]
[(letrec-values . rest)
(unwind-mz-let stx)]
[(set! var rhs)
(with-syntax ([unwound-var (or (syntax-property #`var 'stepper-lifted-name) #`var)]
[unwound-body (inner #`rhs)])
#`(set! unwound-var unwound-body))]
[else
(recur-on-pieces stx)]))
(transfer-info
(if (syntax-property stx 'user-stepper-hint)
(case (syntax-property stx 'user-stepper-hint)
[(comes-from-cond) (unwind-cond stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position))]
[(comes-from-and) (unwind-and/or stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position)
'and)]
[(comes-from-or) (unwind-and/or stx
(syntax-property stx 'user-source)
(syntax-property stx 'user-position)
'or)]
[(comes-from-local)
(unwind-local stx)]
[(comes-from-recur)
(unwind-recur stx)]
[(comes-from-begin)
(unwind-begin stx)]
(else (fall-through)))
(fall-through))
stx))
(define (transfer-highlight from to)
(if (syntax-property from 'stepper-highlight)
(syntax-property to 'stepper-highlight #t)
to))
(define (unwind-recur stx)
(with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here
(with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))])
(let ([unwound (inner #`letrec-term)])
(syntax-case unwound (letrec lambda)
[(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2)
(unless (module-identifier=? #`loop-name #`loop-name-2)
(error "unexpected syntax for 'recur': ~v" stx))
(transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))]
[else #`(#,unwound new-argval ...)])))))
(define (unwind-define stx)
(kernel:kernel-syntax-case stx #f
[(define-values (name . others) body)
(begin
(unless (null? (syntax-e #'others))
(error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx)))
(let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name)
(syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (inner #'body)]
[define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt
(if define-type
(kernel:kernel-syntax-case unwound-body #f
[(lambda arglist lam-body ...)
(case define-type
[(shortened-proc-define)
(let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name #'name)
(and (syntax-property #'name 'stepper-orig-name)
(module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name))))
#`(define (#,printed-name . arglist) lam-body ...)
#`(define #,printed-name #,unwound-body)))]
[(lambda-define)
#`(define #,printed-name #,unwound-body)]
[else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])]
[else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))])
#`(define #,printed-name #,unwound-body))))]
[else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))]))
(define (unwind-mz-let stx)
(with-syntax ([(label ([(var) rhs] ...) . bodies) stx])
(with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))]
[new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
#`let*
(case (syntax-e #'label)
[(let-values) #'let]
[(letrec-values) #'letrec]))]
[new-bodies (map inner (syntax->list #'bodies))])
(syntax-case #`new-bodies (let*) ; is this let and the nested one part of a let*?
[((let* bindings inner-body ...))
(and
(improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint))
(eq? (syntax-property stx 'user-stepper-source)
(syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source))
(eq? (syntax-property stx 'user-stepper-position)
(syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position)))
#`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)]
[else
#`(new-label ([var rhs2] ...) . new-bodies)]))))
(define (unwind-local stx)
(kernel:kernel-syntax-case stx #f
[(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local.
(with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))])
#`(local defns #,(inner #'body)))]
[else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))]))
;(define (unwind-quasiquote-the-cons-application stx)
; (syntax-case (recur-on-pieces stx) ()
; [(#%app the-cons . rest)
; (syntax (cons . rest))]
; [else
; (error 'reconstruct "unexpected result for unwinding the-cons application")]))
(define (unwind-cond-clause stx test-stx result-stx)
(with-syntax ([new-test (if (syntax-property stx 'user-stepper-else)
#`else
(inner test-stx))]
[result (inner result-stx)])
#`(new-test result)))
(define (unwind-cond stx user-source user-position)
(with-syntax ([clauses
(let loop ([stx stx])
(if (and (eq? user-source (syntax-property stx 'user-source))
(eq? user-position (syntax-property stx 'user-position)))
(syntax-case stx (if begin #%app)
[(if test result) ; the else clause disappears when it's a language-inserted else clause
(list (unwind-cond-clause stx #`test #`result))]
[(if test result else-clause)
(cons (unwind-cond-clause stx #`test #`result)
(loop (syntax else-clause)))]
[(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely'
null]
[else-stx
(error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))])
(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]
[(or) #`false])])
(with-syntax ([clauses
(append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder))
(let loop ([stx stx])
(if (and (eq? user-source (syntax-property stx 'user-source))
(eq? user-position (syntax-property stx 'user-position)))
(syntax-case stx (if let-values #%datum)
[(if part-1 part-2 part-3)
(cons (inner (syntax part-1))
(case label
((and)
(loop (syntax part-2)))
((or)
(loop (syntax part-3)))
(else
(error 'unwind-and/or "unknown label ~a" label))))]
[else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))])
null)))])
#`(#,label . clauses)))))
(map inner stxs)))
@ -522,7 +270,7 @@
; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ;
; ;
; ;
7
; recon-source-expr ; recon-source-expr
@ -743,6 +491,8 @@
; Accepts the source expression, a lifting-index which is either a number (indicating ; Accepts the source expression, a lifting-index which is either a number (indicating
; a lifted binding) or false (indicating a top-level expression), a list of values ; a lifted binding) or false (indicating a top-level expression), a list of values
; currently bound to the bindings, and the language level's render-settings. ; currently bound to the bindings, and the language level's render-settings.
;; returns a vectory containing a reconstructed expression and a boolean indicating whether this is source syntax
;; from a define-struct and therefore should not be unwound.
(define (reconstruct-completed exp lifting-indices vals-getter render-settings) (define (reconstruct-completed exp lifting-indices vals-getter render-settings)
(if lifting-indices (if lifting-indices
@ -751,8 +501,7 @@
(let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index))) (let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index)))
(syntax->list #`vars-stx) (syntax->list #`vars-stx)
lifting-indices)]) lifting-indices)])
(first-of-one (unwind-no-highlight (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))])
(reconstruct-completed-define exp vars (vals-getter) render-settings))))])
(let skipto-loop ([exp exp]) (let skipto-loop ([exp exp])
(cond (cond
[(syntax-property exp 'stepper-skipto) => [(syntax-property exp 'stepper-skipto) =>
@ -761,20 +510,20 @@
skipto-loop))] skipto-loop))]
[(syntax-property exp 'stepper-define-struct-hint) [(syntax-property exp 'stepper-define-struct-hint)
;; the hint contains the original syntax ;; the hint contains the original syntax
(syntax-property exp 'stepper-define-struct-hint)] (vector (syntax-property exp 'stepper-define-struct-hint) #t)]
[else [else
(first-of-one (vector
(unwind-no-highlight (kernel:kernel-syntax-case exp #f
(kernel:kernel-syntax-case exp #f [(define-values vars-stx body)
[(define-values vars-stx body) (reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)] [else
[else (let* ([recon-vals (map (lambda (val)
(let* ([recon-vals (map (lambda (val) (recon-value val render-settings))
(recon-value val render-settings)) (vals-getter))])
(vals-getter))]) (if (= (length recon-vals) 1)
(if (= (length recon-vals) 1) (attach-info (car recon-vals) exp)
(attach-info (car recon-vals) exp) (attach-info #`(values #,@recon-vals) exp)))])
(attach-info #`(values #,@recon-vals) exp)))])))])))) #f)]))))
;; an abstraction lifted from reconstruct-completed ;; an abstraction lifted from reconstruct-completed
(define (reconstruct-completed-define exp vars vals render-settings) (define (reconstruct-completed-define exp vars vals render-settings)
@ -1120,14 +869,14 @@
(error 'reconstruct "context expected one value, given ~v" returned-value-list)) (error 'reconstruct "context expected one value, given ~v" returned-value-list))
(recon-value (car returned-value-list) render-settings)) (recon-value (car returned-value-list) render-settings))
nothing-so-far)]) nothing-so-far)])
(unwind (recon innermost mark-list #t) #f))) (recon innermost mark-list #t)))
((right-side) ((right-side)
(let* ([innermost (if returned-value-list ; is it an expr -> value reduction? (let* ([innermost (if returned-value-list ; is it an expr -> value reduction?
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list)))
(error 'reconstruct "context expected one value, given ~v" returned-value-list)) (error 'reconstruct "context expected one value, given ~v" returned-value-list))
(recon-value (car returned-value-list) render-settings)) (recon-value (car returned-value-list) render-settings))
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))]) (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))])
(unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f))) (recon (mark-as-highlight innermost) (cdr mark-list) #f)))
((double-break) ((double-break)
(let* ([source-expr (mark-source (car mark-list))] (let* ([source-expr (mark-source (car mark-list))]
[innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))] [innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))]
@ -1139,8 +888,8 @@
[else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e" [else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e"
(syntax-object->datum source-expr))])] (syntax-object->datum source-expr))])]
[innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))]) [innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))])
(list (unwind (recon innermost-before (cdr mark-list) #f) #f) (list (recon innermost-before (cdr mark-list) #f)
(unwind (recon innermost-after (cdr mark-list) #f) #t)))))) (recon innermost-after (cdr mark-list) #f))))))
) )