refactored to pull out macro unwinding
svn: r2350
This commit is contained in:
John Clements
parent
238b744d99
commit
52db4e170a
256
collects/stepper/private/macro-unwind.ss
Normal file
256
collects/stepper/private/macro-unwind.ss
Normal 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))))
|
||||
|
|
@ -36,24 +36,22 @@
|
|||
(module model mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "match.ss")
|
||||
"my-macros.ss"
|
||||
(prefix a: "annotate.ss")
|
||||
(prefix r: "reconstruct.ss")
|
||||
"shared.ss"
|
||||
"marks.ss"
|
||||
"testing-shared.ss"
|
||||
"model-settings.ss")
|
||||
|
||||
|
||||
"model-settings.ss"
|
||||
"macro-unwind.ss")
|
||||
|
||||
|
||||
(define program-expander-contract
|
||||
((-> void?) ; init
|
||||
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
|
||||
. -> .
|
||||
void?))
|
||||
|
||||
|
||||
|
||||
|
||||
(provide/contract [go (program-expander-contract ; program-expander
|
||||
(step-result? . -> . void?) ; receive-result
|
||||
(or/c render-settings? false/c) ; render-settings
|
||||
|
|
@ -95,200 +93,202 @@
|
|||
;; 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)
|
||||
(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))]))
|
||||
|
||||
;; 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
|
||||
; a highlight-placeholder
|
||||
; (->* ((listof syntax)) (list/c syntax syntax syntax))
|
||||
#;(define (redivide exprs)
|
||||
(letrec ([contains-highlight
|
||||
(lambda (expr)
|
||||
(or (syntax-property expr 'stepper-highlight)
|
||||
(syntax-case expr ()
|
||||
[(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))]
|
||||
[else #f])))])
|
||||
(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))])
|
||||
;; 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
|
||||
; a highlight-placeholder
|
||||
; (->* ((listof syntax)) (list/c syntax syntax syntax))
|
||||
#;(define (redivide exprs)
|
||||
(letrec ([contains-highlight
|
||||
(lambda (expr)
|
||||
(or (syntax-property expr 'stepper-highlight)
|
||||
(syntax-case expr ()
|
||||
[(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))]
|
||||
[else #f])))])
|
||||
(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
|
||||
|
||||
(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
|
||||
#;(define (double-redivide finished-exps new-exprs-before new-exprs-after)
|
||||
(let*-values ([(before current after) (redivide new-exprs-before)]
|
||||
[(before-2 current-2 after-2) (redivide new-exprs-after)])
|
||||
(unless (equal? (map syntax-object->hilite-datum before)
|
||||
(map syntax-object->hilite-datum before-2))
|
||||
(error 'double-redivide "reconstructed before defs are not equal."))
|
||||
(unless (equal? (map syntax-object->hilite-datum after)
|
||||
(map syntax-object->hilite-datum after-2))
|
||||
(error 'double-redivide "reconstructed after defs are not equal."))
|
||||
(values (append finished-exps before) current current-2 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))
|
||||
|
||||
#;(printf "break called with break-kind: ~a ..." break-kind)
|
||||
(if (r:skip-step? break-kind mark-list render-settings)
|
||||
(begin
|
||||
#;(printf " but it was skipped!\n")
|
||||
(when (or (eq? break-kind 'normal-break)
|
||||
(eq? break-kind 'nomal-break/values)) ;; not sure about this...
|
||||
(set! held-exp-list skipped-step)))
|
||||
(define (>>> x)
|
||||
(fprintf (current-output-port) ">>> ~v\n" x)
|
||||
x)
|
||||
|
||||
(define break
|
||||
(opt-lambda (mark-set break-kind [returned-value-list #f])
|
||||
|
||||
(begin
|
||||
#;(printf "and it wasn't skipped.\n")
|
||||
(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)))]
|
||||
|
||||
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
|
||||
|
||||
[(result-exp-break result-value-break)
|
||||
(if (eq? held-exp-list skipped-step)
|
||||
; don't render if before step was a skipped-step
|
||||
(set! held-exp-list no-sexp)
|
||||
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstructed (r:reconstruct-right-side mark-list returned-value-list render-settings)]
|
||||
[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)))]
|
||||
(define (reconstruct-all-completed)
|
||||
(map (match-lambda
|
||||
[`(,source-thunk ,lifting-indices ,getter)
|
||||
(match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)
|
||||
[#(exp #f) (first-of-one (unwind-no-highlight exp))]
|
||||
[#(exp #t) exp])])
|
||||
finished-exps))
|
||||
|
||||
[(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 (car reconstruct-result)]
|
||||
[right-side (cadr reconstruct-result)])
|
||||
;; 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)))]
|
||||
;; TO BE SCRAPPED
|
||||
#;(define (double-redivide finished-exps new-exprs-before new-exprs-after)
|
||||
(let*-values ([(before current after) (redivide new-exprs-before)]
|
||||
[(before-2 current-2 after-2) (redivide new-exprs-after)])
|
||||
(unless (equal? (map syntax-object->hilite-datum before)
|
||||
(map syntax-object->hilite-datum before-2))
|
||||
(error 'double-redivide "reconstructed before defs are not equal."))
|
||||
(unless (equal? (map syntax-object->hilite-datum after)
|
||||
(map syntax-object->hilite-datum after-2))
|
||||
(error 'double-redivide "reconstructed after defs are not equal."))
|
||||
(values (append finished-exps before) current current-2 after)))
|
||||
|
||||
|
||||
[(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)))))
|
||||
#;(printf "break called with break-kind: ~a ..." break-kind)
|
||||
(if (r:skip-step? break-kind mark-list render-settings)
|
||||
(begin
|
||||
#;(printf " but it was skipped!\n")
|
||||
(when (or (eq? break-kind 'normal-break)
|
||||
(eq? break-kind 'nomal-break/values)) ;; not sure about this...
|
||||
(set! held-exp-list skipped-step)))
|
||||
|
||||
(begin
|
||||
#;(printf "and it wasn't skipped.\n")
|
||||
(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 (unwind (r:reconstruct-left-side mark-list returned-value-list render-settings) #f))
|
||||
(set! held-step-was-app? (r:step-was-app? mark-list)))]
|
||||
|
||||
[(result-exp-break result-value-break)
|
||||
(if (eq? held-exp-list skipped-step)
|
||||
; don't render if before step was a skipped-step
|
||||
(set! held-exp-list no-sexp)
|
||||
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstructed (unwind (r:reconstruct-right-side mark-list returned-value-list render-settings) #f)]
|
||||
[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)
|
||||
;; 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
|
||||
(lambda ()
|
||||
|
|
@ -300,5 +300,11 @@
|
|||
(if (eof-object? expanded)
|
||||
(begin
|
||||
(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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,8 +11,7 @@
|
|||
"marks.ss"
|
||||
"model-settings.ss"
|
||||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
"lifting.ss")
|
||||
"my-macros.ss")
|
||||
|
||||
(provide/contract
|
||||
[reconstruct-completed (syntax?
|
||||
|
|
@ -20,23 +19,23 @@
|
|||
(-> (listof any/c))
|
||||
render-settings?
|
||||
. -> .
|
||||
syntax?)]
|
||||
(vector/c syntax? boolean?))]
|
||||
|
||||
;; front ends for reconstruct-current
|
||||
[reconstruct-left-side (mark-list?
|
||||
(or/c (listof any/c) false/c)
|
||||
render-settings?
|
||||
. -> .
|
||||
(listof syntax?))]
|
||||
syntax?)]
|
||||
[reconstruct-right-side (mark-list?
|
||||
(or/c (listof any/c) false/c)
|
||||
render-settings?
|
||||
. -> .
|
||||
(listof syntax?))]
|
||||
syntax?)]
|
||||
[reconstruct-double-break (mark-list?
|
||||
render-settings?
|
||||
. -> .
|
||||
(list/c (listof syntax?) (listof syntax?)))]
|
||||
(list/c syntax? syntax?))]
|
||||
|
||||
[final-mark-list? (-> mark-list? boolean?)]
|
||||
[skip-step? (-> break-kind? (or/c mark-list? false/c) render-settings? boolean?)]
|
||||
|
|
@ -257,258 +256,7 @@
|
|||
#t]
|
||||
[else
|
||||
#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
|
||||
|
||||
|
|
@ -743,6 +491,8 @@
|
|||
; 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
|
||||
; 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)
|
||||
(if lifting-indices
|
||||
|
|
@ -751,8 +501,7 @@
|
|||
(let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index)))
|
||||
(syntax->list #`vars-stx)
|
||||
lifting-indices)])
|
||||
(first-of-one (unwind-no-highlight
|
||||
(reconstruct-completed-define exp vars (vals-getter) render-settings))))])
|
||||
(vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))])
|
||||
(let skipto-loop ([exp exp])
|
||||
(cond
|
||||
[(syntax-property exp 'stepper-skipto) =>
|
||||
|
|
@ -761,20 +510,20 @@
|
|||
skipto-loop))]
|
||||
[(syntax-property exp 'stepper-define-struct-hint)
|
||||
;; the hint contains the original syntax
|
||||
(syntax-property exp 'stepper-define-struct-hint)]
|
||||
(vector (syntax-property exp 'stepper-define-struct-hint) #t)]
|
||||
[else
|
||||
(first-of-one
|
||||
(unwind-no-highlight
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
[(define-values vars-stx body)
|
||||
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
|
||||
[else
|
||||
(let* ([recon-vals (map (lambda (val)
|
||||
(recon-value val render-settings))
|
||||
(vals-getter))])
|
||||
(if (= (length recon-vals) 1)
|
||||
(attach-info (car recon-vals) exp)
|
||||
(attach-info #`(values #,@recon-vals) exp)))])))]))))
|
||||
(vector
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
[(define-values vars-stx body)
|
||||
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
|
||||
[else
|
||||
(let* ([recon-vals (map (lambda (val)
|
||||
(recon-value val render-settings))
|
||||
(vals-getter))])
|
||||
(if (= (length recon-vals) 1)
|
||||
(attach-info (car recon-vals) exp)
|
||||
(attach-info #`(values #,@recon-vals) exp)))])
|
||||
#f)]))))
|
||||
|
||||
;; an abstraction lifted from reconstruct-completed
|
||||
(define (reconstruct-completed-define exp vars vals render-settings)
|
||||
|
|
@ -1120,14 +869,14 @@
|
|||
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
|
||||
(recon-value (car returned-value-list) render-settings))
|
||||
nothing-so-far)])
|
||||
(unwind (recon innermost mark-list #t) #f)))
|
||||
(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))])
|
||||
(unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f)))
|
||||
(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))]
|
||||
|
|
@ -1139,8 +888,8 @@
|
|||
[else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e"
|
||||
(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))])
|
||||
(list (unwind (recon innermost-before (cdr mark-list) #f) #f)
|
||||
(unwind (recon innermost-after (cdr mark-list) #f) #t))))))
|
||||
(list (recon innermost-before (cdr mark-list) #f)
|
||||
(recon innermost-after (cdr mark-list) #f))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user