more stepper cleanup
This commit is contained in:
John Clements
parent
ff973b628b
commit
368f345901
File diff suppressed because it is too large
Load Diff
|
|
@ -1,14 +1,11 @@
|
|||
(module lifting scheme/base
|
||||
(require mzlib/etc
|
||||
mzlib/contract
|
||||
(prefix-in kernel: syntax/kerncase)
|
||||
mzlib/match
|
||||
"testing-shared.ss"
|
||||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
(for-syntax scheme/base))
|
||||
#lang racket
|
||||
|
||||
(define-struct context-record (stx index kind))
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
"testing-shared.ss"
|
||||
"shared.ss"
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define-struct context-record (stx index kind))
|
||||
|
||||
; context-records are used to represent syntax context frames. That is,
|
||||
; a list of context records represents a path through a syntax tree
|
||||
|
|
@ -24,7 +21,7 @@
|
|||
|
||||
|
||||
(define (lift stx lift-in-highlight?)
|
||||
(let*-2vals ([(context-records highlight) (find-highlight stx)])
|
||||
(match-let* ([(vector context-records highlight) (find-highlight stx)])
|
||||
(lift-local-defs context-records highlight lift-in-highlight?)))
|
||||
|
||||
; [find-highlight (-> syntax? (listof context-record?))]
|
||||
|
|
@ -34,123 +31,131 @@
|
|||
|
||||
(define (find-highlight stx)
|
||||
(let/ec success-escape
|
||||
(local
|
||||
((define (make-try-all-subexprs stx kind context-so-far)
|
||||
(lambda (index-mangler list-of-subtries)
|
||||
(let loop ([index 0] [remaining list-of-subtries])
|
||||
(unless (null? remaining)
|
||||
(let* ([try (car remaining)]
|
||||
[corrected-index (index-mangler index)])
|
||||
((car try) (cadr try) (cons (make-context-record stx corrected-index kind) context-so-far))
|
||||
(loop (+ index 1) (cdr remaining)))))))
|
||||
|
||||
(define try->offset-try
|
||||
(lambda (try)
|
||||
(lambda (offset subtries)
|
||||
(try (lambda (index) (list (+ offset index))) subtries))))
|
||||
|
||||
;; WHOA: this code uses the template for fully-expanded syntax; what the code
|
||||
;; actually gets is reconstructed code. This is a problem, because you can't
|
||||
;; distinguish a top-level begin from one that's the result of some evaluation.
|
||||
;; I think for the moment that it will solve our problem simply to remove the
|
||||
;; special case for begin at the top level. JBC, 2006-10-09
|
||||
|
||||
;; ... aaaand, yep, there's a bug. The input is not fully-expanded syntax, and
|
||||
;; therefore _can_ include a two-branched 'if' (because the reconstructor produces it.)
|
||||
;;
|
||||
|
||||
(define (top-level-expr-iterator stx context-so-far)
|
||||
(let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))])
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
(try 3 (map (lambda (expr) `(,module-level-expr-iterator ,expr))
|
||||
(syntax->list #'module-level-exprs)))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx context-so-far)])))
|
||||
|
||||
(define (module-level-expr-iterator stx context-so-far)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(#%provide . provide-specs)
|
||||
(void)]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx context-so-far)]))
|
||||
|
||||
(define (general-top-level-expr-iterator stx context-so-far)
|
||||
(let ([try (try->offset-try (make-try-all-subexprs stx 'general-top-level context-so-far))])
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(try 2 `((,expr-iterator ,#'expr)))]
|
||||
[(define-syntaxes (var ...) expr)
|
||||
(try 2 `((,expr-iterator ,#'expr)))]
|
||||
;; this code is buggy, but I believe it doesn't belong here at all
|
||||
;; per above discussion. JBC, 2006-10-09
|
||||
#;[(begin . top-level-exprs)
|
||||
(try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr))
|
||||
(syntax->list #'exprs)))]
|
||||
[(#%require . require-specs)
|
||||
(void)]
|
||||
[else
|
||||
(expr-iterator stx context-so-far)])))
|
||||
|
||||
(define (expr-iterator stx context-so-far)
|
||||
(when (stepper-syntax-property stx 'stepper-highlight)
|
||||
(success-escape (2vals context-so-far stx)))
|
||||
(let* ([try (make-try-all-subexprs stx 'expr context-so-far)]
|
||||
[try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr))
|
||||
(syntax->list exprs))))]
|
||||
[try-exprs-offset (try->offset-try try-exprs)]
|
||||
[let-values-abstraction
|
||||
(lambda (stx)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(kwd (((variable ...) rhs) ...) . bodies)
|
||||
(begin
|
||||
(try-exprs (lambda (index) (list 1 index 1)) #'(rhs ...))
|
||||
(try-exprs-offset 2 #'bodies))]
|
||||
[else
|
||||
(error 'expr-syntax-object-iterator
|
||||
"unexpected let(rec) expression: ~a"
|
||||
(syntax->datum stx))]))])
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[var-stx
|
||||
(identifier? (syntax var-stx))
|
||||
(void)]
|
||||
[(#%plain-lambda vars . bodies)
|
||||
(try-exprs-offset 2 #'bodies)]
|
||||
[(case-lambda (vars . bodies) ...)
|
||||
(let loop ([count 1] [clauses (syntax->list #'(bodies ...))])
|
||||
(unless (null? clauses)
|
||||
(try-exprs (lambda (index) (list count (+ index 1))) (cdar clauses))
|
||||
(loop (+ count 1) (cdr clauses))))]
|
||||
[(if test then else)
|
||||
(try-exprs-offset 1 #'(test then else))]
|
||||
[(if test then)
|
||||
(try-exprs-offset 1 #'(test then))]
|
||||
[(begin . bodies)
|
||||
(try-exprs-offset 1 #'bodies)]
|
||||
[(begin0 . bodies)
|
||||
(try-exprs-offset 1 #'bodies)]
|
||||
[(let-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(letrec-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(set! var val)
|
||||
(try-exprs-offset 2 #'(val))]
|
||||
[(quote _)
|
||||
(void)]
|
||||
[(quote-syntax _)
|
||||
(void)]
|
||||
[(with-continuation-mark key mark body)
|
||||
(try-exprs-offset 1 #'(key mark body))]
|
||||
[(#%plain-app . exprs)
|
||||
(try-exprs-offset 1 #'exprs)]
|
||||
[(#%top . var)
|
||||
(void)]
|
||||
[else
|
||||
(error 'expr-iterator "unknown expr: ~a"
|
||||
(syntax->datum stx))]))))
|
||||
(let ()
|
||||
(define (make-try-all-subexprs stx kind context-so-far)
|
||||
(lambda (index-mangler list-of-subtries)
|
||||
(let loop ([index 0] [remaining list-of-subtries])
|
||||
(unless (null? remaining)
|
||||
(let* ([try (car remaining)]
|
||||
[corrected-index (index-mangler index)])
|
||||
((car try) (cadr try) (cons (make-context-record stx corrected-index kind) context-so-far))
|
||||
(loop (+ index 1) (cdr remaining)))))))
|
||||
|
||||
(begin (top-level-expr-iterator stx null)
|
||||
(error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (syntax->datum stx))))))
|
||||
(define try->offset-try
|
||||
(lambda (try)
|
||||
(lambda (offset subtries)
|
||||
(try (lambda (index) (list (+ offset index))) subtries))))
|
||||
|
||||
;; WHOA: this code uses the template for fully-expanded syntax; what the code
|
||||
;; actually gets is reconstructed code. This is a problem, because you can't
|
||||
;; distinguish a top-level begin from one that's the result of some evaluation.
|
||||
;; I think for the moment that it will solve our problem simply to remove the
|
||||
;; special case for begin at the top level. JBC, 2006-10-09
|
||||
|
||||
;; ... aaaand, yep, there's a bug. The input is not fully-expanded syntax, and
|
||||
;; therefore _can_ include a two-branched 'if' (because the reconstructor produces it.)
|
||||
;;
|
||||
|
||||
(define (top-level-expr-iterator stx context-so-far)
|
||||
(let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))])
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
(try 3 (map (lambda (expr) `(,module-level-expr-iterator ,expr))
|
||||
(syntax->list #'module-level-exprs)))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx context-so-far)])))
|
||||
|
||||
|
||||
|
||||
(define (module-level-expr-iterator stx context-so-far)
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(#%provide . provide-specs)
|
||||
(void)]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx context-so-far)]))
|
||||
|
||||
(define (general-top-level-expr-iterator stx context-so-far)
|
||||
(let ([try (try->offset-try (make-try-all-subexprs stx 'general-top-level context-so-far))])
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(try 2 `((,expr-iterator ,#'expr)))]
|
||||
[(define-syntaxes (var ...) expr)
|
||||
(try 2 `((,expr-iterator ,#'expr)))]
|
||||
;; this code is buggy, but I believe it doesn't belong here at all
|
||||
;; per above discussion. JBC, 2006-10-09
|
||||
#;[(begin . top-level-exprs)
|
||||
(try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr))
|
||||
(syntax->list #'exprs)))]
|
||||
[(#%require . require-specs)
|
||||
(void)]
|
||||
[else
|
||||
(expr-iterator stx context-so-far)])))
|
||||
|
||||
|
||||
(define (expr-iterator stx context-so-far)
|
||||
(when (stepper-syntax-property stx 'stepper-highlight)
|
||||
(success-escape (vector context-so-far stx)))
|
||||
(let* ([try (make-try-all-subexprs stx 'expr context-so-far)]
|
||||
[try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr))
|
||||
(syntax->list exprs))))]
|
||||
[try-exprs-offset (try->offset-try try-exprs)]
|
||||
[let-values-abstraction
|
||||
(lambda (stx)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(kwd (((variable ...) rhs) ...) . bodies)
|
||||
(begin
|
||||
(try-exprs (lambda (index) (list 1 index 1)) #'(rhs ...))
|
||||
(try-exprs-offset 2 #'bodies))]
|
||||
[else
|
||||
(error 'expr-syntax-object-iterator
|
||||
"unexpected let(rec) expression: ~a"
|
||||
(syntax->datum stx))]))])
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[var-stx
|
||||
(identifier? (syntax var-stx))
|
||||
(void)]
|
||||
[(#%plain-lambda vars . bodies)
|
||||
(try-exprs-offset 2 #'bodies)]
|
||||
[(case-lambda (vars . bodies) ...)
|
||||
(let loop ([count 1] [clauses (syntax->list #'(bodies ...))])
|
||||
(unless (null? clauses)
|
||||
(try-exprs (lambda (index) (list count (+ index 1))) (cdar clauses))
|
||||
(loop (+ count 1) (cdr clauses))))]
|
||||
[(if test then else)
|
||||
(try-exprs-offset 1 #'(test then else))]
|
||||
[(if test then)
|
||||
(try-exprs-offset 1 #'(test then))]
|
||||
[(begin . bodies)
|
||||
(try-exprs-offset 1 #'bodies)]
|
||||
[(begin0 . bodies)
|
||||
(try-exprs-offset 1 #'bodies)]
|
||||
[(let-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(letrec-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(set! var val)
|
||||
(try-exprs-offset 2 #'(val))]
|
||||
[(quote _)
|
||||
(void)]
|
||||
[(quote-syntax _)
|
||||
(void)]
|
||||
[(with-continuation-mark key mark body)
|
||||
(try-exprs-offset 1 #'(key mark body))]
|
||||
[(#%plain-app . exprs)
|
||||
(try-exprs-offset 1 #'exprs)]
|
||||
[(#%top . var)
|
||||
(void)]
|
||||
[else
|
||||
(error 'expr-iterator "unknown expr: ~a"
|
||||
(syntax->datum stx))])))
|
||||
|
||||
;; this should exit before reaching the error:
|
||||
(top-level-expr-iterator stx null)
|
||||
(error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (syntax->datum stx)))))
|
||||
|
||||
; TESTING:
|
||||
|
||||
|
|
@ -186,12 +191,12 @@
|
|||
(list `(define-values (f) (lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2)
|
||||
'general-top-level)))
|
||||
|
||||
(let*-2vals ([(context-records highlight) (find-highlight test-datum)])
|
||||
(match-let* ([(vector context-records highlight) (find-highlight test-datum)])
|
||||
(test expected map datum-ize-context-record context-records))
|
||||
|
||||
|
||||
(test null (lambda ()
|
||||
(let*-2vals ([(context-records dc)
|
||||
(match-let* ([(vector context-records dc)
|
||||
(find-highlight (car (build-stx-with-highlight `((hilite foo)))))])
|
||||
context-records))))
|
||||
|
||||
|
|
@ -312,5 +317,5 @@
|
|||
)
|
||||
|
||||
(report-errs)
|
||||
))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -160,23 +160,24 @@
|
|||
;;;;;;;;;;
|
||||
|
||||
(define (make-debug-info source tail-bound free-vars label lifting?)
|
||||
(let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
|
||||
(if lifting?
|
||||
(let*-2vals ([let-bindings (filter (lambda (var)
|
||||
(and
|
||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||
((let-bound macro-bound) #t)
|
||||
((lambda-bound stepper-temp non-lexical) #f)
|
||||
(else (error 'make-debug-info
|
||||
"varref ~a's binding-type info was not recognized: ~a"
|
||||
(syntax-e var)
|
||||
(stepper-syntax-property var 'stepper-binding-type))))
|
||||
(not (stepper-syntax-property var 'stepper-no-lifting-info))))
|
||||
kept-vars)]
|
||||
[lifter-syms (map get-lifted-var let-bindings)])
|
||||
(make-full-mark source label (append kept-vars lifter-syms)))
|
||||
;; I'm not certain that non-lifting is currently tested: 2005-12, JBC
|
||||
(make-full-mark source label kept-vars))))
|
||||
(define kept-vars (binding-set-varref-set-intersect tail-bound free-vars))
|
||||
(define (let-binding? var)
|
||||
(and
|
||||
(not (stepper-syntax-property var 'stepper-no-lifting-info))
|
||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||
((let-bound macro-bound) #t)
|
||||
((lambda-bound stepper-temp non-lexical) #f)
|
||||
(else (error 'make-debug-info
|
||||
"varref ~a's binding-type info was not recognized: ~a"
|
||||
(syntax-e var)
|
||||
(stepper-syntax-property var 'stepper-binding-type))))))
|
||||
(cond [lifting?
|
||||
(define let-bindings (filter let-binding? kept-vars))
|
||||
(define lifter-syms (map get-lifted-var let-bindings))
|
||||
(make-full-mark source label (append kept-vars lifter-syms))]
|
||||
[else
|
||||
;; I'm not certain that non-lifting is currently tested: 2005-12, JBC
|
||||
(make-full-mark source label kept-vars)]))
|
||||
|
||||
|
||||
(define (make-top-level-mark source-expr)
|
||||
|
|
|
|||
|
|
@ -44,30 +44,7 @@
|
|||
|
||||
;; honestly, match-let* supersedes all of this, if I ever have time to redo it...
|
||||
|
||||
(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals)
|
||||
|
||||
(define 2vals vector)
|
||||
|
||||
(define-syntax (let*-2vals stx)
|
||||
(syntax-case stx (let*-2vals)
|
||||
[(let*-2vals () . bodies)
|
||||
(syntax/loc stx (begin . bodies))]
|
||||
[(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies) ; 2 values in a vector
|
||||
(syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)])
|
||||
(let*-2vals (binding ...) . bodies)))]
|
||||
[(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value
|
||||
(quasisyntax/loc stx (let* ([id-a rhs])
|
||||
#,(syntax/loc stx (let*-2vals (binding ...) . bodies))))]))
|
||||
|
||||
(define-syntax (2vals-first stx)
|
||||
(syntax-case stx (2vals-first)
|
||||
[(2vals-first a)
|
||||
(syntax (vector-ref a 0))]))
|
||||
|
||||
(define-syntax (2vals-second stx)
|
||||
(syntax-case stx (2vals-second)
|
||||
[(2vals-second a)
|
||||
(syntax (vector-ref a 1))]))
|
||||
(provide 2vals-map apply-to-first-of-2vals)
|
||||
|
||||
(define (apply-to-first-of-2vals proc 2vals)
|
||||
(vector (proc (vector-ref 2vals 0))
|
||||
|
|
@ -79,10 +56,10 @@
|
|||
|
||||
(define (2vals-map f . lsts)
|
||||
(if (null? (car lsts))
|
||||
(2vals null null)
|
||||
(let*-2vals ([(a b) (apply f (map car lsts))]
|
||||
[(a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
|
||||
(2vals (cons a a-rest) (cons b b-rest)))))
|
||||
(vector null null)
|
||||
(match-let* ([(vector a b) (apply f (map car lsts))]
|
||||
[(vector a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
|
||||
(vector (cons a a-rest) (cons b b-rest)))))
|
||||
|
||||
; test cases
|
||||
; (require my-macros)
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@
|
|||
|
||||
(define-struct let-glump (name-set exp val-set))
|
||||
|
||||
; split-list : ('a -> boolean) (listof 'a) -> (2vals (listof 'a) (listof 'a))
|
||||
; split-list : ('a -> boolean) (listof 'a) -> (vector (listof 'a) (listof 'a))
|
||||
; split-list splits a list into two lists at the first element s.t. (fn element) => true).
|
||||
; that is, split-list yields the lists A and B such that (append A B) gives the original
|
||||
; list, and (fn element) => false for all elements in A, and B is either empty or
|
||||
|
|
@ -63,15 +63,15 @@
|
|||
(define (split-list fn lst)
|
||||
(let loop ([remaining lst] [so-far null])
|
||||
(cond [(null? remaining)
|
||||
(2vals (reverse so-far) null)]
|
||||
(vector (reverse so-far) null)]
|
||||
[else
|
||||
(if (fn (car remaining))
|
||||
(2vals (reverse so-far) remaining)
|
||||
(vector (reverse so-far) remaining)
|
||||
(loop (cdr remaining) (cons (car remaining) so-far)))])))
|
||||
|
||||
; test cases
|
||||
; (test (2vals '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1))
|
||||
; (test (2vals '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5))
|
||||
; (test (vector '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1))
|
||||
; (test (vector '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5))
|
||||
|
||||
; n-split-list : num ('a list) -> ('a list) ('a list)
|
||||
; n-split-list splits a given list A into two lists B and C, such that B contains the
|
||||
|
|
@ -82,11 +82,11 @@
|
|||
(error 'n-split-list "can't split list ~a after ~ath element; not long enough" lst num))
|
||||
(let loop ([count num] [remaining lst] [so-far null])
|
||||
(if (= count 0)
|
||||
(2vals (reverse so-far) remaining)
|
||||
(vector (reverse so-far) remaining)
|
||||
(loop (- count 1) (cdr remaining) (cons (car remaining) so-far)))))
|
||||
|
||||
; test cases
|
||||
; (test (2vals '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
|
||||
; (test (vector '(a b c) '(d e f)) n-split-list 3 '(a b c d e f))
|
||||
|
||||
|
||||
(define (mark-as-highlight stx)
|
||||
|
|
@ -646,68 +646,69 @@
|
|||
[recon-let
|
||||
(lambda ()
|
||||
(with-syntax ([(label ((vars rhs) ...) . bodies) exp])
|
||||
(let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[glumps
|
||||
(map (lambda (binding-set rhs)
|
||||
(make-let-glump
|
||||
(map (lambda (binding)
|
||||
(stepper-syntax-property binding
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list binding)))
|
||||
binding-set)
|
||||
rhs
|
||||
(map (lambda (arg-binding)
|
||||
(lookup-binding mark-list arg-binding))
|
||||
binding-set)))
|
||||
binding-sets
|
||||
(syntax->list #`(rhs ...)))]
|
||||
[num-defns-done (lookup-binding mark-list let-counter)]
|
||||
[(done-glumps not-done-glumps)
|
||||
(n-split-list num-defns-done glumps)]
|
||||
[recon-lifted
|
||||
(lambda (names expr)
|
||||
#`(#,names #,expr))]
|
||||
[before-bindings
|
||||
(map
|
||||
(lambda (glump)
|
||||
(let* ([name-set (let-glump-name-set glump)]
|
||||
[rhs-val-set (map (lambda (val)
|
||||
(if (> (length name-set) 0)
|
||||
(recon-value val render-settings (car name-set))
|
||||
(recon-value val render-settings)))
|
||||
(let-glump-val-set glump))])
|
||||
(if (= (length rhs-val-set) 1)
|
||||
#`(#,name-set #,@rhs-val-set)
|
||||
#`(#,name-set (values #,rhs-val-set)))))
|
||||
done-glumps)]
|
||||
[reconstruct-remaining-def
|
||||
(lambda (glump)
|
||||
(let ([rhs-source (let-glump-exp glump)]
|
||||
[rhs-name-set (let-glump-name-set glump)])
|
||||
(recon-lifted rhs-name-set
|
||||
(recon-source-current-marks rhs-source))))]
|
||||
[after-bindings
|
||||
(if (pair? not-done-glumps)
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(map reconstruct-remaining-def not-done-glumps)
|
||||
(cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far)
|
||||
(map reconstruct-remaining-def (cdr not-done-glumps))))
|
||||
null)]
|
||||
[recon-bindings (append before-bindings after-bindings)]
|
||||
;; there's a terrible tangle of invariants here. Among them:
|
||||
;; num-defns-done = (length binding-sets) IFF the so-far has a 'stepper-offset' index
|
||||
;; that is not #f (that is, we're evaluating the body...)
|
||||
[so-far-offset-index (and (not (eq? so-far nothing-so-far))
|
||||
(stepper-syntax-property so-far 'stepper-offset-index))]
|
||||
[bodies (syntax->list (syntax bodies))]
|
||||
[rectified-bodies
|
||||
(map (lambda (body offset-index)
|
||||
(if (eq? offset-index so-far-offset-index)
|
||||
so-far
|
||||
(recon-source-expr body mark-list binding-list binding-list render-settings)))
|
||||
bodies
|
||||
(iota (length bodies)))])
|
||||
(match-let*
|
||||
([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[glumps
|
||||
(map (lambda (binding-set rhs)
|
||||
(make-let-glump
|
||||
(map (lambda (binding)
|
||||
(stepper-syntax-property binding
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list binding)))
|
||||
binding-set)
|
||||
rhs
|
||||
(map (lambda (arg-binding)
|
||||
(lookup-binding mark-list arg-binding))
|
||||
binding-set)))
|
||||
binding-sets
|
||||
(syntax->list #`(rhs ...)))]
|
||||
[num-defns-done (lookup-binding mark-list let-counter)]
|
||||
[(vector done-glumps not-done-glumps)
|
||||
(n-split-list num-defns-done glumps)]
|
||||
[recon-lifted
|
||||
(lambda (names expr)
|
||||
#`(#,names #,expr))]
|
||||
[before-bindings
|
||||
(map
|
||||
(lambda (glump)
|
||||
(let* ([name-set (let-glump-name-set glump)]
|
||||
[rhs-val-set (map (lambda (val)
|
||||
(if (> (length name-set) 0)
|
||||
(recon-value val render-settings (car name-set))
|
||||
(recon-value val render-settings)))
|
||||
(let-glump-val-set glump))])
|
||||
(if (= (length rhs-val-set) 1)
|
||||
#`(#,name-set #,@rhs-val-set)
|
||||
#`(#,name-set (values #,rhs-val-set)))))
|
||||
done-glumps)]
|
||||
[reconstruct-remaining-def
|
||||
(lambda (glump)
|
||||
(let ([rhs-source (let-glump-exp glump)]
|
||||
[rhs-name-set (let-glump-name-set glump)])
|
||||
(recon-lifted rhs-name-set
|
||||
(recon-source-current-marks rhs-source))))]
|
||||
[after-bindings
|
||||
(if (pair? not-done-glumps)
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(map reconstruct-remaining-def not-done-glumps)
|
||||
(cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far)
|
||||
(map reconstruct-remaining-def (cdr not-done-glumps))))
|
||||
null)]
|
||||
[recon-bindings (append before-bindings after-bindings)]
|
||||
;; there's a terrible tangle of invariants here. Among them:
|
||||
;; num-defns-done = (length binding-sets) IFF the so-far has a 'stepper-offset' index
|
||||
;; that is not #f (that is, we're evaluating the body...)
|
||||
[so-far-offset-index (and (not (eq? so-far nothing-so-far))
|
||||
(stepper-syntax-property so-far 'stepper-offset-index))]
|
||||
[bodies (syntax->list (syntax bodies))]
|
||||
[rectified-bodies
|
||||
(map (lambda (body offset-index)
|
||||
(if (eq? offset-index so-far-offset-index)
|
||||
so-far
|
||||
(recon-source-expr body mark-list binding-list binding-list render-settings)))
|
||||
bodies
|
||||
(iota (length bodies)))])
|
||||
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
|
||||
(if (stepper-syntax-property exp 'stepper-fake-exp)
|
||||
|
||||
|
|
|
|||
|
|
@ -1504,7 +1504,7 @@
|
|||
(provide ggg)
|
||||
;; run whatever tests are enabled (intended for interactive use):
|
||||
(define (ggg)
|
||||
(parameterize (#;[disable-stepper-error-handling #t]
|
||||
(parameterize ([disable-stepper-error-handling #t]
|
||||
#;[display-only-errors #t]
|
||||
#;[store-steps #f]
|
||||
#;[show-all-steps #t])
|
||||
|
|
@ -1512,5 +1512,5 @@
|
|||
check-error check-error-bad))
|
||||
#;(run-tests '(teachpack-universe))
|
||||
#;(run-all-tests)
|
||||
(run-tests '(mz-app2))
|
||||
(run-tests '(simple-if))
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user