check-expect largely supported
svn: r9574
This commit is contained in:
John Clements
parent
1449dec372
commit
9326b8cfbc
|
|
@ -86,7 +86,8 @@ stepper-hint :
|
|||
[ 'from-splice-box ] : expression was expanded from a scheme splice
|
||||
box (inside an xml box)
|
||||
[ 'comes-from-recur ] : expression was expanded from a 'recur'
|
||||
[ 'comes-from-check-expect ] : expression was expanded from a 'check-expect'
|
||||
[ 'comes-from-check-expect ] : expression was expanded from a 'check-expect',
|
||||
or this identifier (use or binding) was created by the expansion of a 'check-expect'.
|
||||
|
||||
stepper-define-type:
|
||||
this is attached to the right-hand sides of defines to indicate what
|
||||
|
|
@ -100,8 +101,6 @@ stepper-define-type:
|
|||
[ 'lambda-define ] : this lambda arose from the expansion of
|
||||
(define id (lambda (
|
||||
|
||||
|
||||
|
||||
(Transferred.)
|
||||
|
||||
Question 1: why the right-hand side? Why not on the define itself?
|
||||
|
|
@ -231,7 +230,7 @@ stepper-fake-exp :
|
|||
this expression does not occur directly in the source; reconstruct specially.
|
||||
used for begin.
|
||||
|
||||
args-of-call [ADDED BY RECONSTRUCTOR] :
|
||||
stepper-args-of-call [ADDED BY RECONSTRUCTOR] :
|
||||
this reconstructed (...) expression is the result of a call with these args.
|
||||
used by the check-expect unwinder to figure out the expected values.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module macro-unwind scheme/base
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
mzlib/etc
|
||||
mzlib/contract
|
||||
(require (only-in syntax/kerncase kernel-syntax-case)
|
||||
scheme/contract
|
||||
scheme/list
|
||||
"model-settings.ss"
|
||||
"shared.ss"
|
||||
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
stx))
|
||||
|
||||
(define (fall-through stx settings)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
(kernel-syntax-case stx #f
|
||||
[id
|
||||
(identifier? stx)
|
||||
(or (stepper-syntax-property stx 'stepper-lifted-name)
|
||||
|
|
@ -89,6 +89,7 @@
|
|||
[(comes-from-or) (unwind-and/or 'or)]
|
||||
[(comes-from-local) unwind-local]
|
||||
[(comes-from-recur) unwind-recur]
|
||||
[(comes-from-check-expect) unwind-check-expect]
|
||||
;;[(comes-from-begin) unwind-begin]
|
||||
[else fall-through])])
|
||||
(process stx settings))))
|
||||
|
|
@ -116,19 +117,13 @@
|
|||
[else #`(#,unwound new-argval ...)])))))
|
||||
|
||||
(define (unwind-define stx settings)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
(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->datum stx)))
|
||||
(if (eq? (stepper-syntax-property #`body 'stepper-hint) 'comes-from-check-expect)
|
||||
(kernel:kernel-syntax-case
|
||||
(unwind #`body settings) #f
|
||||
[(c-e (lambda () a1) a2 a3)
|
||||
#`(check-expect a1 a2)]
|
||||
[else #`(c-e body)])
|
||||
(let* ([printed-name
|
||||
(or (stepper-syntax-property #`name 'stepper-lifted-name)
|
||||
(stepper-syntax-property #'name 'stepper-orig-name)
|
||||
|
|
@ -138,7 +133,7 @@
|
|||
[define-type (stepper-syntax-property
|
||||
unwound-body 'stepper-define-type)])
|
||||
(if define-type
|
||||
(kernel:kernel-syntax-case
|
||||
(kernel-syntax-case
|
||||
unwound-body #f
|
||||
[(lambda arglist lam-body ...)
|
||||
(case define-type
|
||||
|
|
@ -167,7 +162,7 @@
|
|||
[else (error 'unwind-define
|
||||
"expr with stepper-define-type is not a lambda: ~e"
|
||||
(syntax->datum unwound-body))])
|
||||
#`(define #,printed-name #,unwound-body)))))]
|
||||
#`(define #,printed-name #,unwound-body))))]
|
||||
[else (error 'unwind-define
|
||||
"expression is not a define-values: ~e"
|
||||
(syntax->datum stx))]))
|
||||
|
|
@ -203,7 +198,7 @@
|
|||
#`(new-label ([var rhs2] ...) . new-bodies)]))))
|
||||
|
||||
(define (unwind-local stx settings)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
(kernel-syntax-case stx #f
|
||||
;; at least through intermediate, define-values may not occur in
|
||||
;; local.
|
||||
[(letrec-values ([vars exp] ...) body)
|
||||
|
|
@ -301,4 +296,15 @@
|
|||
(syntax->datum stx))])
|
||||
null)))])
|
||||
#`(#,label . clauses))))
|
||||
|
||||
(define (unwind-check-expect stx settings)
|
||||
(kernel-syntax-case (fall-through stx settings) #f
|
||||
[(c-e (lambda () a1) a2 a3 a4)
|
||||
#`(check-expect a1 a2)]
|
||||
[(dots1 actual dots2)
|
||||
(and (eq? (syntax->datum #'dots1) '...)
|
||||
(eq? (syntax->datum #'dots2) '...))
|
||||
(with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)])
|
||||
#`(check-expect actual expected))]
|
||||
[any #`(c-e any) #;#`(check-expect )]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -39,8 +39,9 @@
|
|||
(module model mzscheme
|
||||
(require mzlib/contract
|
||||
mzlib/etc
|
||||
mzlib/match
|
||||
scheme/match
|
||||
mzlib/class
|
||||
scheme/list
|
||||
(prefix a: "annotate.ss")
|
||||
(prefix r: "reconstruct.ss")
|
||||
"shared.ss"
|
||||
|
|
@ -48,6 +49,7 @@
|
|||
"model-settings.ss"
|
||||
"macro-unwind.ss"
|
||||
"lifting.ss"
|
||||
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
|
||||
;; for breakpoint display
|
||||
;; (commented out to allow nightly testing)
|
||||
#;"display-break-stuff.ss")
|
||||
|
|
@ -169,15 +171,20 @@
|
|||
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
|
||||
|
||||
(define (reconstruct-all-completed)
|
||||
(map (match-lambda
|
||||
[`(,source-thunk ,lifting-indices ,getter)
|
||||
(filter-map
|
||||
(match-lambda
|
||||
[(list source-thunk lifting-indices getter)
|
||||
(let ([source (source-thunk)])
|
||||
(if (r:hide-completed? source)
|
||||
#f
|
||||
(match (r:reconstruct-completed
|
||||
(source-thunk) lifting-indices
|
||||
source lifting-indices
|
||||
getter render-settings)
|
||||
[#(exp #f) (unwind exp render-settings)]
|
||||
[#(exp #t) exp])])
|
||||
[(vector exp #f) (unwind exp render-settings)]
|
||||
[(vector exp #t) exp])))])
|
||||
finished-exps))
|
||||
|
||||
#;(>>> break-kind)
|
||||
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
|
||||
(if (r:skip-step? break-kind mark-list render-settings)
|
||||
(begin
|
||||
|
|
|
|||
|
|
@ -42,6 +42,9 @@
|
|||
;;
|
||||
;;;;;;;;;;
|
||||
|
||||
|
||||
;; 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)
|
||||
|
|
|
|||
|
|
@ -8,11 +8,13 @@
|
|||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/contract
|
||||
scheme/match
|
||||
"marks.ss"
|
||||
"model-settings.ss"
|
||||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax scheme/base)
|
||||
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
|
||||
|
||||
(provide/contract
|
||||
[reconstruct-completed (syntax?
|
||||
|
|
@ -21,6 +23,7 @@
|
|||
render-settings?
|
||||
. -> .
|
||||
(vector/c syntax? boolean?))]
|
||||
[hide-completed? (syntax? . -> . boolean?)]
|
||||
|
||||
;; front ends for reconstruct-current
|
||||
[reconstruct-left-side (mark-list?
|
||||
|
|
@ -145,7 +148,9 @@
|
|||
(define (skip-step? break-kind mark-list render-settings)
|
||||
(case break-kind
|
||||
[(result-value-break)
|
||||
#f]
|
||||
(and (pair? mark-list)
|
||||
(let ([expr (mark-source (car mark-list))])
|
||||
(equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect)))]
|
||||
[(result-exp-break)
|
||||
;; skip if clauses that are the result of and/or reductions
|
||||
(let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
|
||||
|
|
@ -180,7 +185,8 @@
|
|||
|
||||
(and (pair? mark-list)
|
||||
(let ([expr (mark-source (car mark-list))])
|
||||
(or (kernel:kernel-syntax-case expr #f
|
||||
(or (equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect)
|
||||
(kernel:kernel-syntax-case expr #f
|
||||
[id
|
||||
(identifier? expr)
|
||||
(case (stepper-syntax-property expr 'stepper-binding-type)
|
||||
|
|
@ -427,16 +433,18 @@
|
|||
; for the moment, let-bound vars occur only in and/or :
|
||||
(recon-value (lookup-binding mark-list var) render-settings))
|
||||
((let-bound)
|
||||
(if (stepper-syntax-property var 'stepper-no-lifting-info)
|
||||
var
|
||||
(stepper-syntax-property var
|
||||
'stepper-lifted-name
|
||||
(binding-lifted-name mark-list var)))
|
||||
(binding-lifted-name mark-list var))))
|
||||
((stepper-temp)
|
||||
(error 'recon-source-expr "stepper-temp showed up in source?!?"))
|
||||
((non-lexical)
|
||||
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical"))
|
||||
(else
|
||||
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
|
||||
(stepper-syntax-property var 'stepper-binding-type)))))]
|
||||
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a on var: ~a"
|
||||
(stepper-syntax-property var 'stepper-binding-type) (syntax->datum var)))))]
|
||||
[else ; top-level-varref
|
||||
(fixup-name
|
||||
var)])))]
|
||||
|
|
@ -572,6 +580,13 @@
|
|||
reconstructed]))))
|
||||
|
||||
|
||||
;; hide-completed? : syntax? -> boolean?
|
||||
(define (hide-completed? stx)
|
||||
(syntax-case stx ()
|
||||
[(define-values (v) rhs)
|
||||
(equal? (stepper-syntax-property #'v 'stepper-hint) 'comes-from-check-expect)
|
||||
#t]
|
||||
[else #f]))
|
||||
|
||||
|
||||
; ; ;
|
||||
|
|
@ -722,26 +737,30 @@
|
|||
; applications
|
||||
[(#%plain-app . terms)
|
||||
(attach-info
|
||||
(let* ([sub-exprs (syntax->list (syntax terms))]
|
||||
(match-let*
|
||||
([sub-exprs (syntax->list (syntax terms))]
|
||||
[arg-temps (build-list (length sub-exprs) get-arg-var)]
|
||||
[arg-vals (map (lambda (arg-temp)
|
||||
(lookup-binding mark-list arg-temp))
|
||||
arg-temps)])
|
||||
(case (mark-label (car mark-list))
|
||||
((not-yet-called)
|
||||
(let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
|
||||
arg-temps)]
|
||||
[(vector evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
|
||||
(zip sub-exprs arg-vals))]
|
||||
[rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))])
|
||||
(case (mark-label (car mark-list))
|
||||
((not-yet-called)
|
||||
(if (null? unevaluated)
|
||||
#`(#%plain-app . #,rectified-evaluated)
|
||||
#`(#%plain-app
|
||||
#,@rectified-evaluated
|
||||
#,so-far
|
||||
#,@(map recon-source-current-marks (cdr (map car unevaluated)))))))
|
||||
#,@(map recon-source-current-marks (cdr (map car unevaluated))))))
|
||||
((called)
|
||||
(stepper-syntax-property
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code
|
||||
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))))
|
||||
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur?
|
||||
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...)))
|
||||
'stepper-args-of-call
|
||||
rectified-evaluated))
|
||||
(else
|
||||
(error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp))))
|
||||
exp)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user