more stepper cleanup
This commit is contained in:
John Clements
parent
ff973b628b
commit
368f345901
|
|
@ -102,29 +102,25 @@
|
|||
; (let-bound, lambda-bound, or non-lexical), it flags if's which could come from
|
||||
; cond's, it labels the begins in conds with 'stepper-skip annotations
|
||||
|
||||
; label-var-types returns a syntax object which is identical to the original except
|
||||
; that the variable references are labeled with the stepper-syntax-property
|
||||
; 'stepper-binding-type, which is set to either let-bound, lambda-bound, or
|
||||
; non-lexical.
|
||||
; label-var-types returns a syntax object which is identical to the
|
||||
; original except that the variable references are labeled with the
|
||||
; stepper-syntax-property 'stepper-binding-type, which is set to either
|
||||
; let-bound, lambda-bound, or non-lexical.
|
||||
|
||||
(define (top-level-rewrite stx)
|
||||
(let loop ([stx stx]
|
||||
[let-bound-bindings null]
|
||||
[cond-test (lx #f)])
|
||||
(if (or (stepper-syntax-property stx 'stepper-skip-completely)
|
||||
(stepper-syntax-property stx 'stepper-define-struct-hint))
|
||||
stx
|
||||
(let* ([recur-regular
|
||||
(lambda (stx)
|
||||
(loop stx let-bound-bindings (lx #f)))]
|
||||
[recur-with-bindings
|
||||
(lambda (exp vars)
|
||||
(loop exp (append vars let-bound-bindings) (lx #f)))]
|
||||
[recur-in-cond
|
||||
(lambda (stx new-cond-test)
|
||||
(loop stx let-bound-bindings new-cond-test))]
|
||||
[do-let/rec
|
||||
(lambda (stx rec?)
|
||||
(define (recur-regular stx)
|
||||
(loop stx let-bound-bindings (lx #f)))
|
||||
|
||||
(define (recur-with-bindings exp vars)
|
||||
(loop exp (append vars let-bound-bindings) (lx #f)))
|
||||
|
||||
(define (recur-in-cond stx new-cond-test)
|
||||
(loop stx let-bound-bindings new-cond-test))
|
||||
|
||||
(define (do-let/rec stx rec?)
|
||||
(with-syntax ([(label ((vars rhs) ...) . bodies) stx])
|
||||
(let* ([vars-list
|
||||
(apply append
|
||||
|
|
@ -149,15 +145,20 @@
|
|||
[new-bindings (map list labelled-vars-list rhs-list)])
|
||||
(datum->syntax
|
||||
stx
|
||||
`(,#'label ,new-bindings ,@new-bodies) stx stx))))]
|
||||
`(,#'label ,new-bindings ,@new-bodies) stx stx))))
|
||||
|
||||
|
||||
; evaluated at runtime, using 3D code:
|
||||
[put-into-xml-table (lambda (val)
|
||||
(define (put-into-xml-table val)
|
||||
(hash-set! finished-xml-box-table val #t)
|
||||
val)]
|
||||
val)
|
||||
|
||||
|
||||
[rewritten
|
||||
(cond
|
||||
[(or (stepper-syntax-property stx 'stepper-skip-completely)
|
||||
(stepper-syntax-property stx 'stepper-define-struct-hint))
|
||||
stx]
|
||||
[else
|
||||
(define rewritten
|
||||
(kernel:kernel-syntax-case
|
||||
stx
|
||||
#f
|
||||
|
|
@ -167,10 +168,13 @@
|
|||
[rebuild-if
|
||||
(lambda (new-cond-test)
|
||||
(let* ([new-then (recur-regular (syntax then))]
|
||||
[rebuilt (stepper-syntax-property
|
||||
(rebuild-stx `(if ,(recur-regular (syntax test))
|
||||
[rebuilt
|
||||
(stepper-syntax-property
|
||||
(rebuild-stx
|
||||
`(if ,(recur-regular (syntax test))
|
||||
,new-then
|
||||
,(recur-in-cond (syntax else-stx) new-cond-test))
|
||||
,(recur-in-cond (syntax else-stx)
|
||||
new-cond-test))
|
||||
stx)
|
||||
'stepper-hint
|
||||
'comes-from-cond)])
|
||||
|
|
@ -180,19 +184,25 @@
|
|||
rebuilt)))])
|
||||
(cond [(cond-test stx) ; continuing an existing 'cond'
|
||||
(rebuild-if cond-test)]
|
||||
[(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
|
||||
[(and origin (pair? origin)
|
||||
(eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
|
||||
(rebuild-if (lambda (test-stx)
|
||||
(and (eq? (syntax-source stx) (syntax-source test-stx))
|
||||
(eq? (syntax-position stx) (syntax-position test-stx)))))]
|
||||
(and (eq? (syntax-source stx)
|
||||
(syntax-source test-stx))
|
||||
(eq? (syntax-position stx)
|
||||
(syntax-position test-stx)))))]
|
||||
[else ; not from a 'cond' at all.
|
||||
(rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
|
||||
[(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
|
||||
(cond-test stx)
|
||||
(stepper-syntax-property stx 'stepper-skip-completely #t)]
|
||||
|
||||
; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of
|
||||
; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet
|
||||
; exist. So we patch it up after expansion. And we discard the outer 'let' at the same time.
|
||||
; wrapper on a local. This is necessary because
|
||||
; teach.ss expands local into a trivial let wrapping a bunch of
|
||||
; internal defines, and therefore the letrec-values on
|
||||
; which I want to hang the 'stepper-hint doesn't yet
|
||||
; exist. So we patch it up after expansion. And we
|
||||
; discard the outer 'let' at the same time.
|
||||
[(let-values () expansion-of-local)
|
||||
(eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-local)
|
||||
(syntax-case #`expansion-of-local (letrec-values)
|
||||
|
|
@ -213,7 +223,8 @@
|
|||
(syntax var)
|
||||
'stepper-binding-type
|
||||
(if (eq? (identifier-binding (syntax var)) 'lexical)
|
||||
(cond [(ormap (lx (bound-identifier=? _ (syntax var))) let-bound-bindings)
|
||||
(cond [(ormap (lx (bound-identifier=? _ (syntax var)))
|
||||
let-bound-bindings)
|
||||
'let-bound]
|
||||
[else
|
||||
'lambda-bound])
|
||||
|
|
@ -223,13 +234,15 @@
|
|||
(let ([content (syntax-e stx)])
|
||||
(if (pair? content)
|
||||
(rebuild-stx (syntax-pair-map content recur-regular) stx)
|
||||
stx))])])
|
||||
stx))]))
|
||||
|
||||
(if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box)
|
||||
(stepper-syntax-property #`(#%plain-app #,put-into-xml-table #,rewritten)
|
||||
(stepper-syntax-property #`(#%plain-app
|
||||
#,put-into-xml-table
|
||||
#,rewritten)
|
||||
'stepper-skipto
|
||||
(list syntax-e cdr car))
|
||||
(stepper-recertify rewritten stx))))))
|
||||
(stepper-recertify rewritten stx))])))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -345,7 +358,8 @@
|
|||
"no getter for a define-struct")))))))
|
||||
|
||||
(define (top-level-annotate/inner exp source-exp defined-name)
|
||||
(let*-2vals ([(annotated dont-care)
|
||||
(match-let*
|
||||
([(vector annotated dont-care)
|
||||
(annotate/inner exp 'all #f defined-name)])
|
||||
#`(with-continuation-mark #,debug-key
|
||||
#,(make-top-level-mark source-exp)
|
||||
|
|
@ -391,61 +405,62 @@
|
|||
. -> . (vector/p syntax? binding-set?))
|
||||
(lambda (exp tail-bound pre-break? procedure-name-info)
|
||||
|
||||
(cond [(cond
|
||||
((stepper-syntax-property exp 'stepper-skipto) 'rebuild)
|
||||
((stepper-syntax-property exp 'stepper-skipto/discard) 'discard)
|
||||
(else #f))
|
||||
=> (lambda (traversal)
|
||||
(let* ([free-vars-captured #f] ; this will be set!'ed
|
||||
;;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))]
|
||||
;; WARNING! I depend on the order of evaluation in application arguments here:
|
||||
[annotated (skipto/auto
|
||||
exp
|
||||
traversal
|
||||
(lambda (subterm)
|
||||
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
|
||||
;; annotate an exp with a stepper/skipto or stepper-skipto/discard
|
||||
;; label
|
||||
(define (dont-annotate traversal)
|
||||
;; mutable, to catch free vars. Mutated several times, we
|
||||
;; only care about the last. A bit yecchy.
|
||||
(define free-vars-captured #f)
|
||||
|
||||
(define (subterm-recur subterm)
|
||||
(match-let*
|
||||
([(vector stx free-vars)
|
||||
(annotate/inner subterm tail-bound pre-break?
|
||||
procedure-name-info)])
|
||||
(set! free-vars-captured free-vars)
|
||||
stx)))])
|
||||
(2vals (wcm-wrap
|
||||
skipto-mark
|
||||
annotated)
|
||||
free-vars-captured)))]
|
||||
stx))
|
||||
|
||||
[(stepper-syntax-property exp 'stepper-skip-completely)
|
||||
(2vals (wcm-wrap 13 exp) null)]
|
||||
(define annotated (skipto/auto exp traversal subterm-recur))
|
||||
|
||||
(vector (wcm-wrap skipto-mark annotated) free-vars-captured))
|
||||
|
||||
[else
|
||||
(let*
|
||||
;; recurrence procedures, used to recur on sub-expressions:
|
||||
([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))]
|
||||
[non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))]
|
||||
[result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))]
|
||||
[set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))]
|
||||
[let-rhs-recur (lambda (exp binding-names dyn-index-syms)
|
||||
(let* ([proc-name-info
|
||||
|
||||
(define (tail-recur exp) (annotate/inner exp tail-bound
|
||||
#t procedure-name-info))
|
||||
(define (non-tail-recur exp) (annotate/inner exp null #f #f))
|
||||
(define (result-recur exp) (annotate/inner exp null
|
||||
#f procedure-name-info))
|
||||
(define (set!-rhs-recur exp name) (annotate/inner exp null #f name))
|
||||
(define (let-rhs-recur exp binding-names dyn-index-syms)
|
||||
(define proc-name-info
|
||||
(if (not (null? binding-names))
|
||||
(list (car binding-names) (car dyn-index-syms))
|
||||
#f)])
|
||||
(annotate/inner exp null #f proc-name-info)))]
|
||||
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))]
|
||||
#f))
|
||||
(annotate/inner exp null #f proc-name-info))
|
||||
(define (lambda-body-recur exp) (annotate/inner exp 'all #t #f))
|
||||
|
||||
|
||||
; let bodies have a startling number of recurrence patterns. ouch!
|
||||
;; ... looks like these can maybe be collapsed with a simpler desired reduction sequence
|
||||
;; (a.k.a. not safe-for-space).
|
||||
|
||||
;; no pre-break, tail w.r.t. new bindings:
|
||||
[let-body-recur/single
|
||||
(lambda (exp bindings)
|
||||
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info))]
|
||||
(define (let-body-recur/single exp bindings)
|
||||
(annotate/inner exp (binding-set-union (list tail-bound bindings))
|
||||
#f procedure-name-info))
|
||||
|
||||
;; different flavors of make-debug-info allow users to provide only the needed fields:
|
||||
|
||||
[make-debug-info-normal (lambda (free-bindings)
|
||||
(make-debug-info exp tail-bound free-bindings 'none #t))]
|
||||
[make-debug-info-app (lambda (tail-bound free-bindings label)
|
||||
(make-debug-info exp tail-bound free-bindings label #t))]
|
||||
[make-debug-info-let (lambda (free-bindings binding-list let-counter)
|
||||
(make-debug-info exp
|
||||
(define (make-debug-info-normal free-bindings)
|
||||
(make-debug-info exp tail-bound free-bindings 'none #t))
|
||||
|
||||
(define (make-debug-info-app tail-bound free-bindings label)
|
||||
(make-debug-info exp tail-bound free-bindings label #t))
|
||||
|
||||
(define (make-debug-info-let free-bindings binding-list let-counter)
|
||||
(make-debug-info
|
||||
exp
|
||||
(binding-set-union (list tail-bound
|
||||
binding-list
|
||||
(list let-counter)))
|
||||
|
|
@ -453,26 +468,26 @@
|
|||
binding-list
|
||||
(list let-counter))) ; NB using bindings as varrefs
|
||||
'let-body
|
||||
#t))]
|
||||
[make-debug-info-fake-exp (lambda (exp free-bindings)
|
||||
#t))
|
||||
(define (make-debug-info-fake-exp exp free-bindings)
|
||||
(make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
|
||||
tail-bound free-bindings 'none #t))]
|
||||
[make-debug-info-fake-exp/tail-bound (lambda (exp tail-bound free-bindings)
|
||||
(make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
|
||||
tail-bound free-bindings 'none #t))]
|
||||
tail-bound free-bindings 'none #t))
|
||||
|
||||
[outer-wcm-wrap (if pre-break?
|
||||
(define (make-debug-info-fake-exp/tail-bound exp tail-bound free-bindings)
|
||||
(make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t)
|
||||
tail-bound free-bindings 'none #t))
|
||||
|
||||
(define outer-wcm-wrap (if pre-break?
|
||||
wcm-pre-break-wrap
|
||||
wcm-wrap)]
|
||||
[wcm-break-wrap (lambda (debug-info exp)
|
||||
(outer-wcm-wrap debug-info (break-wrap exp)))]
|
||||
wcm-wrap))
|
||||
(define (wcm-break-wrap debug-info exp)
|
||||
(outer-wcm-wrap debug-info (break-wrap exp)))
|
||||
|
||||
;; used for things that are values:
|
||||
[normal-bundle
|
||||
(lambda (free-vars annotated)
|
||||
(2vals (outer-wcm-wrap (make-debug-info-normal free-vars)
|
||||
(define (normal-bundle free-vars annotated)
|
||||
(vector (outer-wcm-wrap (make-debug-info-normal free-vars)
|
||||
annotated)
|
||||
free-vars))]
|
||||
free-vars))
|
||||
|
||||
|
||||
; @@ @@ @@
|
||||
|
|
@ -485,8 +500,7 @@
|
|||
; @@@@@ -$$-@@@@@@@@@@@+@$ $@:@@ -$$-@@
|
||||
;
|
||||
|
||||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(define (lambda-clause-abstraction clause)
|
||||
(with-syntax ([(args-stx . bodies) clause])
|
||||
(match-let*
|
||||
([(vector annotated-body free-varrefs)
|
||||
|
|
@ -513,31 +527,22 @@
|
|||
(vector (datum->syntax
|
||||
#'here
|
||||
`(,#'args-stx ,annotated-body) #'clause)
|
||||
new-free-varrefs))))]
|
||||
new-free-varrefs))))
|
||||
|
||||
[outer-lambda-abstraction
|
||||
(lambda (annotated-lambda free-varrefs)
|
||||
(let*-2vals
|
||||
|
||||
(define (outer-lambda-abstraction annotated-lambda free-varrefs)
|
||||
(let*
|
||||
([closure-info (make-debug-info-app 'all free-varrefs 'none)]
|
||||
;; if we manually disable the storage of names, lambdas get rendered as lambdas.
|
||||
[closure-name (if show-lambdas-as-lambdas?
|
||||
;; if we manually disable the storage of names,
|
||||
;; lambdas get rendered as lambdas.
|
||||
;; Yikes, this seems like a pretty gross hack... JBC 2010-12
|
||||
[closure-name
|
||||
(if show-lambdas-as-lambdas?
|
||||
#f
|
||||
(cond [(syntax? procedure-name-info) procedure-name-info]
|
||||
[(pair? procedure-name-info) (car procedure-name-info)]
|
||||
[else #f]))]
|
||||
|
||||
#;[make-ap-struct
|
||||
(lambda (clo debug-info maybe-index)
|
||||
(annotated-proc
|
||||
clo
|
||||
(make-closure-record
|
||||
closure-name
|
||||
debug-info
|
||||
#f
|
||||
maybe-index)))]
|
||||
|
||||
|
||||
|
||||
[closure-storing-proc
|
||||
(lambda (clo debug-info maybe-index)
|
||||
(annotated-proc
|
||||
|
|
@ -550,10 +555,16 @@
|
|||
|
||||
[captured
|
||||
(cond [(pair? procedure-name-info)
|
||||
#`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info
|
||||
#`(#%plain-app
|
||||
#,closure-storing-proc
|
||||
#,annotated-lambda
|
||||
#,closure-info
|
||||
#,(cadr procedure-name-info))]
|
||||
[else
|
||||
#`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info
|
||||
#`(#%plain-app
|
||||
#,closure-storing-proc
|
||||
#,annotated-lambda
|
||||
#,closure-info
|
||||
#f)])]
|
||||
|
||||
;; gnarr! I can't find a test case
|
||||
|
|
@ -566,7 +577,10 @@
|
|||
(syntax-e closure-name))
|
||||
captured)])
|
||||
|
||||
(normal-bundle free-varrefs inferred-name-struct)))]
|
||||
(normal-bundle free-varrefs inferred-name-struct)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; @@
|
||||
|
|
@ -630,19 +644,18 @@
|
|||
; wish me luck.
|
||||
|
||||
|
||||
[let-abstraction
|
||||
(lambda (stx output-identifier make-init-list)
|
||||
(define (let-abstraction stx output-identifier make-init-list)
|
||||
(with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
|
||||
(let*-2vals
|
||||
(match-let*
|
||||
([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[vals (syntax->list #'(val ...))]
|
||||
[lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)]
|
||||
[lifted-vars (apply append lifted-var-sets)]
|
||||
[(annotated-vals free-varref-sets-vals)
|
||||
[(vector annotated-vals free-varref-sets-vals)
|
||||
(2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
|
||||
[bodies-list (syntax->list #'bodies)]
|
||||
[(annotated-body free-varrefs-body)
|
||||
[(vector annotated-body free-varrefs-body)
|
||||
(if (= (length bodies-list) 1)
|
||||
(let-body-recur/single (car bodies-list) binding-list)
|
||||
;; oh dear lord, we have to unfold these like an application:
|
||||
|
|
@ -652,20 +665,28 @@
|
|||
[(null? (cdr bodies-list))
|
||||
(tail-recur (car bodies-list))]
|
||||
[else
|
||||
(let*-2vals
|
||||
([(rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)]
|
||||
[(this-one free-vars-this) (non-tail-recur (car bodies-list))]
|
||||
[free-vars-all (varref-set-union (list free-vars-rest free-vars-this))]
|
||||
(match-let*
|
||||
([(vector rest free-vars-rest)
|
||||
(unroll-loop (cdr bodies-list) #f)]
|
||||
[(vector this-one free-vars-this)
|
||||
(non-tail-recur (car bodies-list))]
|
||||
[free-vars-all
|
||||
(varref-set-union (list free-vars-rest
|
||||
free-vars-this))]
|
||||
[debug-info (make-debug-info-fake-exp
|
||||
#`(begin #,@bodies-list)
|
||||
free-vars-all)]
|
||||
[begin-form #`(begin #,(normal-break/values-wrap this-one) #,rest)])
|
||||
(2vals (if outermost?
|
||||
[begin-form
|
||||
#`(begin
|
||||
#,(normal-break/values-wrap this-one)
|
||||
#,rest)])
|
||||
(vector (if outermost?
|
||||
(wcm-wrap debug-info begin-form)
|
||||
(wcm-pre-break-wrap debug-info begin-form))
|
||||
(wcm-pre-break-wrap debug-info
|
||||
begin-form))
|
||||
free-vars-all))])))])
|
||||
|
||||
((2vals (quasisyntax/loc
|
||||
((vector (quasisyntax/loc
|
||||
exp
|
||||
(let ([#,counter-id (#,binding-indexer)])
|
||||
(#,output-identifier #,outer-initialization #,wrapped-begin)))
|
||||
|
|
@ -715,8 +736,7 @@
|
|||
(double-break-wrap
|
||||
#`(begin #,@(apply append (zip set!-clauses counter-clauses))
|
||||
(#%plain-app #,exp-finished-break #,exp-finished-clauses)
|
||||
#,annotated-body)))])))))]
|
||||
|
||||
#,annotated-body)))])))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -736,29 +756,32 @@
|
|||
; @@@@@ @@@@@
|
||||
|
||||
; if-abstraction: (-> syntax? syntax? (or/c false/c syntax?) (values syntax? varref-set?))
|
||||
[if-abstraction
|
||||
(lambda (test then else)
|
||||
(let*-2vals
|
||||
([(annotated-test free-varrefs-test)
|
||||
(define (if-abstraction test then else)
|
||||
(match-let*
|
||||
([(vector annotated-test free-varrefs-test)
|
||||
(non-tail-recur test)]
|
||||
[test-with-break
|
||||
(normal-break/values-wrap annotated-test)]
|
||||
[(annotated-then free-varrefs-then)
|
||||
[(vector annotated-then free-varrefs-then)
|
||||
(tail-recur then)]
|
||||
[(annotated-else free-varrefs-else)
|
||||
[(vector annotated-else free-varrefs-else)
|
||||
(if else
|
||||
(tail-recur else)
|
||||
(2vals #f null))]
|
||||
(vector #f null))]
|
||||
[free-varrefs (varref-set-union (list free-varrefs-test
|
||||
free-varrefs-then
|
||||
free-varrefs-else))]
|
||||
[annotated-if
|
||||
(if else
|
||||
(quasisyntax/loc exp (if #,test-with-break #,annotated-then #,annotated-else))
|
||||
(quasisyntax/loc exp (if #,test-with-break #,annotated-then)))])
|
||||
(2vals
|
||||
(quasisyntax/loc exp
|
||||
(if #,test-with-break #,annotated-then #,annotated-else))
|
||||
(quasisyntax/loc exp
|
||||
(if #,test-with-break #,annotated-then)))])
|
||||
(vector
|
||||
(outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-if)
|
||||
free-varrefs)))]
|
||||
free-varrefs)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -778,9 +801,9 @@
|
|||
;
|
||||
|
||||
|
||||
[varref-abstraction
|
||||
(lambda (var)
|
||||
(let*-2vals ([free-varrefs (list var)]
|
||||
(define (varref-abstraction var)
|
||||
(match-let*
|
||||
([free-varrefs (list var)]
|
||||
[varref-break-wrap
|
||||
(lambda ()
|
||||
(wcm-break-wrap (make-debug-info-normal free-varrefs)
|
||||
|
|
@ -793,7 +816,7 @@
|
|||
(if (memq (syntax-e var) beginner-defined:must-reduce)
|
||||
(varref-break-wrap)
|
||||
(varref-no-break-wrap)))])
|
||||
(2vals
|
||||
(vector
|
||||
(case (stepper-syntax-property var 'stepper-binding-type)
|
||||
((lambda-bound macro-bound) (varref-no-break-wrap))
|
||||
((let-bound) (varref-break-wrap))
|
||||
|
|
@ -802,55 +825,68 @@
|
|||
(#f (top-level-varref-break-wrap))
|
||||
['lexical
|
||||
;; my reading of the docs suggest that this should not occur in v4...
|
||||
(error 'varref-abstraction "identifier-binding should not be 'lexical")]
|
||||
(error 'varref-abstraction
|
||||
"identifier-binding should not be 'lexical")]
|
||||
[(list-rest (? module-path-index? path-index) dontcare)
|
||||
(let-values ([(module-path dc5) (module-path-index-split path-index)])
|
||||
(let-values ([(module-path dc5)
|
||||
(module-path-index-split path-index)])
|
||||
(if module-path
|
||||
;; not a module-local variable:
|
||||
(top-level-varref-break-wrap)
|
||||
;; a module-local-variable:
|
||||
(varref-break-wrap)))]
|
||||
[other (error 'annotate "unexpected value for identifier-binding: ~v" other)])))
|
||||
free-varrefs)))]
|
||||
[other (error
|
||||
'annotate
|
||||
"unexpected value for identifier-binding: ~v" other)])))
|
||||
free-varrefs)))
|
||||
|
||||
[recertifier
|
||||
(lambda (vals)
|
||||
(let*-2vals ([(new-exp bindings) vals])
|
||||
(2vals (stepper-recertify new-exp exp)
|
||||
(define (recertifier vals)
|
||||
(match-let* ([(vector new-exp bindings) vals])
|
||||
(vector (stepper-recertify new-exp exp)
|
||||
(map (lambda (b)
|
||||
(stepper-recertify b exp))
|
||||
bindings))))]
|
||||
bindings))))
|
||||
|
||||
;; this is a terrible hack... until some other language form needs it. It wraps the
|
||||
;; given annotated expression with a break that adds the result to the list of completed
|
||||
;; expressions
|
||||
[maybe-final-val-wrap
|
||||
;; this is a terrible hack... until some other language form needs it.
|
||||
;; It wraps the given annotated expression with a break that adds the
|
||||
;; result to the list of completed expressions
|
||||
(define maybe-final-val-wrap
|
||||
(match-lambda
|
||||
[(vector annotated free-vars)
|
||||
(vector (if (stepper-syntax-property exp 'stepper-use-val-as-final)
|
||||
#`(#%plain-app
|
||||
call-with-values
|
||||
(#%plain-lambda () #,annotated)
|
||||
(#%plain-lambda results
|
||||
(#%plain-lambda
|
||||
results
|
||||
(#,exp-finished-break
|
||||
(#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () results))))
|
||||
(#%plain-app list
|
||||
(#%plain-app
|
||||
list
|
||||
#,(lambda () exp)
|
||||
#f
|
||||
(#%plain-lambda () results))))
|
||||
(#%plain-app values results)))
|
||||
annotated)
|
||||
free-vars)]
|
||||
[error 'maybe-final-val-wrap "stepper internal error 20080527"])]
|
||||
|
||||
)
|
||||
; find the source expression and associate it with the parsed expression
|
||||
; (when (and red-exprs foot-wrap?)
|
||||
; (set-exp-read! exp (find-read-expr exp)))
|
||||
[error 'maybe-final-val-wrap "stepper internal error 20080527"]))
|
||||
|
||||
(cond [(stepper-syntax-property exp 'stepper-skipto)
|
||||
(dont-annotate 'rebuild)]
|
||||
[(stepper-syntax-property exp 'stepper-skipto/discard)
|
||||
(dont-annotate 'discard)]
|
||||
[(stepper-syntax-property exp 'stepper-skip-completely)
|
||||
(vector (wcm-wrap 13 exp) null)]
|
||||
|
||||
[else
|
||||
(recertifier
|
||||
(maybe-final-val-wrap
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
(kernel:kernel-syntax-case
|
||||
exp #f
|
||||
|
||||
[(#%plain-lambda . clause)
|
||||
(let*-2vals ([(annotated-clause free-varrefs)
|
||||
(match-let*
|
||||
([(vector annotated-clause free-varrefs)
|
||||
(lambda-clause-abstraction (syntax clause))]
|
||||
[annotated-lambda
|
||||
(with-syntax ([annotated-clause annotated-clause])
|
||||
|
|
@ -858,7 +894,8 @@
|
|||
(outer-lambda-abstraction annotated-lambda free-varrefs))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(let*-2vals ([(annotated-cases free-varrefs-cases)
|
||||
(match-let*
|
||||
([(vector annotated-cases free-varrefs-cases)
|
||||
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
|
||||
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
|
||||
(syntax/loc exp (case-lambda . annotated-cases)))]
|
||||
|
|
@ -911,16 +948,17 @@
|
|||
;; the body of the begin0 is in tail position.
|
||||
|
||||
[(begin0 body)
|
||||
(let*-2vals ([(annotated-body free-vars-body)
|
||||
(match-let* ([(vector annotated-body free-vars-body)
|
||||
(tail-recur #'body)])
|
||||
(2vals (wcm-break-wrap (make-debug-info-normal free-vars-body)
|
||||
(vector (wcm-break-wrap (make-debug-info-normal free-vars-body)
|
||||
(quasisyntax/loc exp (begin0 #,annotated-body)))
|
||||
free-vars-body))]
|
||||
|
||||
|
||||
[(begin0 first-body . bodies-stx)
|
||||
(let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)]
|
||||
[(annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
|
||||
(match-let*
|
||||
([(vector annotated-first free-vars-first) (result-recur #'first-body)]
|
||||
[(vector annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
|
||||
[wrapped-rest (map normal-break/values-wrap annotated-rest)]
|
||||
[all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))]
|
||||
[early-debug-info (make-debug-info-normal all-free-vars)]
|
||||
|
|
@ -931,7 +969,8 @@
|
|||
#`(begin0 #,@rest-exps)
|
||||
(binding-set-union (list (list tagged-temp) tail-bound))
|
||||
(varref-set-union (list (list tagged-temp) all-free-vars))))]
|
||||
[rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest]
|
||||
[rolled-into-fakes
|
||||
(let loop ([remaining-wrapped wrapped-rest]
|
||||
[remaining-src (syntax->list #`bodies-stx)]
|
||||
[first-time? #t])
|
||||
((if first-time? wcm-wrap wcm-pre-break-wrap)
|
||||
|
|
@ -940,27 +979,11 @@
|
|||
[else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped)
|
||||
(cdr remaining-src)
|
||||
#f))])))])
|
||||
(2vals (wcm-wrap early-debug-info
|
||||
(vector (wcm-wrap early-debug-info
|
||||
#`(let ([#,begin0-temp #,annotated-first])
|
||||
#,rolled-into-fakes))
|
||||
all-free-vars))]
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;; ;;;
|
||||
; ; ; ;
|
||||
; ; ; ;
|
||||
; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;; ; ; ;; ; ; ;
|
||||
; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
[(let-values . _)
|
||||
(let-abstraction exp
|
||||
#`let-values
|
||||
|
|
@ -984,16 +1007,17 @@
|
|||
|
||||
|
||||
[(set! var val)
|
||||
(let*-2vals
|
||||
([(annotated-val val-free-varrefs)
|
||||
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
|
||||
(match-let*
|
||||
([(vector annotated-val val-free-varrefs)
|
||||
(set!-rhs-recur (syntax val)
|
||||
(syntax-case (syntax var) (#%top)
|
||||
[(#%top . real-var) (syntax-e (syntax real-var))]
|
||||
[else (syntax var)]))]
|
||||
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
|
||||
[annotated-set!
|
||||
(return-value-wrap
|
||||
(quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))])
|
||||
(2vals
|
||||
(vector
|
||||
(outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!)
|
||||
free-varrefs))]
|
||||
|
||||
|
|
@ -1024,7 +1048,7 @@
|
|||
|
||||
|
||||
[(with-continuation-mark key mark body)
|
||||
;(let*-2vals ([(annotated-key free-varrefs-key)
|
||||
;(match-let* ([(annotated-key free-varrefs-key)
|
||||
; (non-tail-recur (syntax key))]
|
||||
; [(annotated-mark free-varrefs-mark)
|
||||
; (non-tail-recur (syntax mark))]
|
||||
|
|
@ -1092,11 +1116,11 @@
|
|||
;; transfer that knowledge to here. -- JBC, 2006-10-11
|
||||
|
||||
[(#%plain-app . terms)
|
||||
(let*-2vals
|
||||
([(annotated-terms free-varrefs-terms)
|
||||
(match-let*
|
||||
([(vector annotated-terms free-varrefs-terms)
|
||||
(2vals-map non-tail-recur (syntax->list (syntax terms)))]
|
||||
[free-varrefs (varref-set-union free-varrefs-terms)])
|
||||
(2vals
|
||||
(vector
|
||||
(let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
|
||||
[tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp))
|
||||
arg-temps)]
|
||||
|
|
@ -1133,15 +1157,14 @@
|
|||
; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@
|
||||
|
||||
|
||||
[(#%top . var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
[(#%top . var-stx) (varref-abstraction #`var-stx)]
|
||||
|
||||
[var-stx
|
||||
(identifier? #`var-stx)
|
||||
(varref-abstraction #`var-stx)]
|
||||
|
||||
[else
|
||||
(error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))]))))])))
|
||||
(error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))])))])))
|
||||
|
||||
;; annotate/top-level : syntax-> syntax
|
||||
;; expansion of teaching level language programs produces two kinds of
|
||||
|
|
|
|||
|
|
@ -1,14 +1,11 @@
|
|||
(module lifting scheme/base
|
||||
(require mzlib/etc
|
||||
mzlib/contract
|
||||
(prefix-in kernel: syntax/kerncase)
|
||||
mzlib/match
|
||||
#lang racket
|
||||
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
"testing-shared.ss"
|
||||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define-struct context-record (stx index kind))
|
||||
(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,8 +31,8 @@
|
|||
|
||||
(define (find-highlight stx)
|
||||
(let/ec success-escape
|
||||
(local
|
||||
((define (make-try-all-subexprs stx kind context-so-far)
|
||||
(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)
|
||||
|
|
@ -61,15 +58,19 @@
|
|||
|
||||
(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
|
||||
(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
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(#%provide . provide-specs)
|
||||
(void)]
|
||||
[else-stx
|
||||
|
|
@ -77,7 +78,8 @@
|
|||
|
||||
(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
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(try 2 `((,expr-iterator ,#'expr)))]
|
||||
[(define-syntaxes (var ...) expr)
|
||||
|
|
@ -92,9 +94,10 @@
|
|||
[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)))
|
||||
(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))))]
|
||||
|
|
@ -110,7 +113,8 @@
|
|||
(error 'expr-syntax-object-iterator
|
||||
"unexpected let(rec) expression: ~a"
|
||||
(syntax->datum stx))]))])
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
(kernel:kernel-syntax-case
|
||||
stx #f
|
||||
[var-stx
|
||||
(identifier? (syntax var-stx))
|
||||
(void)]
|
||||
|
|
@ -147,10 +151,11 @@
|
|||
(void)]
|
||||
[else
|
||||
(error 'expr-iterator "unknown expr: ~a"
|
||||
(syntax->datum stx))]))))
|
||||
(syntax->datum stx))])))
|
||||
|
||||
(begin (top-level-expr-iterator stx null)
|
||||
(error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (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)
|
||||
(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))))
|
||||
(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)))
|
||||
(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))))
|
||||
(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,7 +646,8 @@
|
|||
[recon-let
|
||||
(lambda ()
|
||||
(with-syntax ([(label ((vars rhs) ...) . bodies) exp])
|
||||
(let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
||||
(match-let*
|
||||
([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
|
||||
[binding-list (apply append binding-sets)]
|
||||
[glumps
|
||||
(map (lambda (binding-set rhs)
|
||||
|
|
@ -663,7 +664,7 @@
|
|||
binding-sets
|
||||
(syntax->list #`(rhs ...)))]
|
||||
[num-defns-done (lookup-binding mark-list let-counter)]
|
||||
[(done-glumps not-done-glumps)
|
||||
[(vector done-glumps not-done-glumps)
|
||||
(n-split-list num-defns-done glumps)]
|
||||
[recon-lifted
|
||||
(lambda (names expr)
|
||||
|
|
|
|||
|
|
@ -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