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,15 +36,13 @@
|
|||
(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
|
||||
|
|
@ -179,7 +177,9 @@
|
|||
(define (reconstruct-all-completed)
|
||||
(map (match-lambda
|
||||
[`(,source-thunk ,lifting-indices ,getter)
|
||||
(r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)])
|
||||
(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))
|
||||
|
||||
;; TO BE SCRAPPED
|
||||
|
|
@ -210,7 +210,7 @@
|
|||
(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-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)
|
||||
|
|
@ -219,7 +219,7 @@
|
|||
(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)]
|
||||
[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
|
||||
|
|
@ -254,8 +254,8 @@
|
|||
"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)])
|
||||
[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)
|
||||
|
|
@ -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?)]
|
||||
|
|
@ -258,257 +257,6 @@
|
|||
[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,10 +510,9 @@
|
|||
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
|
||||
(vector
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
[(define-values vars-stx body)
|
||||
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
|
||||
|
|
@ -774,7 +522,8 @@
|
|||
(vals-getter))])
|
||||
(if (= (length recon-vals) 1)
|
||||
(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
|
||||
(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