suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

check-expect largely supported

Browse Source 
svn: r9574
This commit is contained in:
John Clements 2008-05-01 22:33:54 +00:00
parent 1449dec372
commit 9326b8cfbc
5 changed files with 197 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/stepper/internal-docs.txt
View File

@ -86,7 +86,8 @@ stepper-hint :
[ 'from-splice-box ] : expression was expanded from a scheme splice [ 'from-splice-box ] : expression was expanded from a scheme splice
box (inside an xml box) box (inside an xml box)
[ 'comes-from-recur ] : expression was expanded from a 'recur' [ '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: stepper-define-type:
this is attached to the right-hand sides of defines to indicate what 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 [ 'lambda-define ] : this lambda arose from the expansion of
(define id (lambda ( (define id (lambda (
(Transferred.) (Transferred.)
Question 1: why the right-hand side? Why not on the define itself? 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. this expression does not occur directly in the source; reconstruct specially.
used for begin. 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. this reconstructed (...) expression is the result of a call with these args.
used by the check-expect unwinder to figure out the expected values. used by the check-expect unwinder to figure out the expected values.

198
collects/stepper/private/macro-unwind.ss
View File

@ -1,7 +1,7 @@
(module macro-unwind scheme/base (module macro-unwind scheme/base
(require (prefix-in kernel: syntax/kerncase) (require (only-in syntax/kerncase kernel-syntax-case)
mzlib/etc scheme/contract
mzlib/contract scheme/list
"model-settings.ss" "model-settings.ss"
"shared.ss" "shared.ss"
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
@ -51,32 +51,32 @@
stx)) stx))
(define (fall-through stx settings) (define (fall-through stx settings)
(kernel:kernel-syntax-case stx #f (kernel-syntax-case stx #f
[id [id
(identifier? stx) (identifier? stx)
(or (stepper-syntax-property stx 'stepper-lifted-name) (or (stepper-syntax-property stx 'stepper-lifted-name)
stx)] stx)]
[(define-values dc ...) [(define-values dc ...)
(unwind-define stx settings)] (unwind-define stx settings)]
[(#%plain-app exp ...) [(#%plain-app exp ...)
(recur-on-pieces #'(exp ...) settings)] (recur-on-pieces #'(exp ...) settings)]
[(quote datum) [(quote datum)
(if (symbol? #'datum) (if (symbol? #'datum)
stx stx
#'datum)] #'datum)]
[(let-values . rest) [(let-values . rest)
(unwind-mz-let stx settings)] (unwind-mz-let stx settings)]
[(letrec-values . rest) [(letrec-values . rest)
(unwind-mz-let stx settings)] (unwind-mz-let stx settings)]
[(#%plain-lambda . rest) [(#%plain-lambda . rest)
(recur-on-pieces #'(lambda . rest) settings)] (recur-on-pieces #'(lambda . rest) settings)]
[(set! var rhs) [(set! var rhs)
(with-syntax ([unwound-var (or (stepper-syntax-property (with-syntax ([unwound-var (or (stepper-syntax-property
#`var 'stepper-lifted-name) #`var 'stepper-lifted-name)
#`var)] #`var)]
[unwound-body (unwind #`rhs settings)]) [unwound-body (unwind #`rhs settings)])
#`(set! unwound-var unwound-body))] #`(set! unwound-var unwound-body))]
[else (recur-on-pieces stx settings)])) [else (recur-on-pieces stx settings)]))
(define (unwind stx settings) (define (unwind stx settings)
(transfer-info (transfer-info
@ -89,6 +89,7 @@
[(comes-from-or) (unwind-and/or 'or)] [(comes-from-or) (unwind-and/or 'or)]
[(comes-from-local) unwind-local] [(comes-from-local) unwind-local]
[(comes-from-recur) unwind-recur] [(comes-from-recur) unwind-recur]
[(comes-from-check-expect) unwind-check-expect]
;;[(comes-from-begin) unwind-begin] ;;[(comes-from-begin) unwind-begin]
[else fall-through])]) [else fall-through])])
(process stx settings)))) (process stx settings))))
@ -116,61 +117,55 @@
[else #`(#,unwound new-argval ...)]))))) [else #`(#,unwound new-argval ...)])))))
(define (unwind-define stx settings) (define (unwind-define stx settings)
(kernel:kernel-syntax-case stx #f (kernel-syntax-case stx #f
[(define-values (name . others) body) [(define-values (name . others) body)
(begin (begin
(unless (null? (syntax-e #'others)) (unless (null? (syntax-e #'others))
(error 'reconstruct (error 'reconstruct
"reconstruct fails on multiple-values define: ~v\n" "reconstruct fails on multiple-values define: ~v\n"
(syntax->datum stx))) (syntax->datum stx)))
(if (eq? (stepper-syntax-property #`body 'stepper-hint) 'comes-from-check-expect) (let* ([printed-name
(kernel:kernel-syntax-case (or (stepper-syntax-property #`name 'stepper-lifted-name)
(unwind #`body settings) #f (stepper-syntax-property #'name 'stepper-orig-name)
[(c-e (lambda () a1) a2 a3) #'name)]
#`(check-expect a1 a2)] [unwound-body (unwind #'body settings)]
[else #`(c-e body)]) ;; see notes in internal-docs.txt
(let* ([printed-name [define-type (stepper-syntax-property
(or (stepper-syntax-property #`name 'stepper-lifted-name) unwound-body 'stepper-define-type)])
(stepper-syntax-property #'name 'stepper-orig-name) (if define-type
#'name)] (kernel-syntax-case
[unwound-body (unwind #'body settings)] unwound-body #f
;; see notes in internal-docs.txt [(lambda arglist lam-body ...)
[define-type (stepper-syntax-property (case define-type
unwound-body 'stepper-define-type)]) [(shortened-proc-define)
(if define-type (let ([proc-define-name
(kernel:kernel-syntax-case (stepper-syntax-property
unwound-body #f unwound-body
[(lambda arglist lam-body ...) 'stepper-proc-define-name)])
(case define-type (if (or (free-identifier=? proc-define-name
[(shortened-proc-define) #'name)
(let ([proc-define-name (and (stepper-syntax-property #'name
(stepper-syntax-property 'stepper-orig-name)
unwound-body (free-identifier=?
'stepper-proc-define-name)]) proc-define-name
(if (or (free-identifier=? proc-define-name (stepper-syntax-property
#'name) #'name 'stepper-orig-name))))
(and (stepper-syntax-property #'name #`(define (#,printed-name . arglist)
'stepper-orig-name) lam-body ...)
(free-identifier=? #`(define #,printed-name
proc-define-name #,unwound-body)))]
(stepper-syntax-property [(lambda-define)
#'name 'stepper-orig-name)))) #`(define #,printed-name #,unwound-body)]
#`(define (#,printed-name . arglist) [else (error 'unwind-define
lam-body ...) "unknown value for syntax property 'stepper-define-type: ~e"
#`(define #,printed-name define-type)])]
#,unwound-body)))] [else (error 'unwind-define
[(lambda-define) "expr with stepper-define-type is not a lambda: ~e"
#`(define #,printed-name #,unwound-body)] (syntax->datum unwound-body))])
[else (error 'unwind-define #`(define #,printed-name #,unwound-body))))]
"unknown value for syntax property 'stepper-define-type: ~e" [else (error 'unwind-define
define-type)])] "expression is not a define-values: ~e"
[else (error 'unwind-define (syntax->datum stx))]))
"expr with stepper-define-type is not a lambda: ~e"
(syntax->datum unwound-body))])
#`(define #,printed-name #,unwound-body)))))]
[else (error 'unwind-define
"expression is not a define-values: ~e"
(syntax->datum stx))]))
(define (unwind-mz-let stx settings) (define (unwind-mz-let stx settings)
(with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) (with-syntax ([(label ([(var) rhs] ...) . bodies) stx])
@ -203,18 +198,18 @@
#`(new-label ([var rhs2] ...) . new-bodies)])))) #`(new-label ([var rhs2] ...) . new-bodies)]))))
(define (unwind-local stx settings) (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 ;; at least through intermediate, define-values may not occur in
;; local. ;; local.
[(letrec-values ([vars exp] ...) body) [(letrec-values ([vars exp] ...) body)
(with-syntax ([defns (map (lambda (def) (with-syntax ([defns (map (lambda (def)
(unwind def settings)) (unwind def settings))
(syntax->list (syntax->list
#`((define-values vars exp) ...)))]) #`((define-values vars exp) ...)))])
#`(local defns #,(unwind #'body settings)))] #`(local defns #,(unwind #'body settings)))]
[else (error 'unwind-local [else (error 'unwind-local
"expected a letrec-values, given: ~e" "expected a letrec-values, given: ~e"
(syntax->datum stx))])) (syntax->datum stx))]))
;(define (unwind-quasiquote-the-cons-application stx settings) ;(define (unwind-quasiquote-the-cons-application stx settings)
; (syntax-case (recur-on-pieces stx settings) () ; (syntax-case (recur-on-pieces stx settings) ()
@ -301,4 +296,15 @@
(syntax->datum stx))]) (syntax->datum stx))])
null)))]) null)))])
#`(#,label . clauses)))) #`(#,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 )]))
) )

25
collects/stepper/private/model.ss
View File

@ -39,8 +39,9 @@
(module model mzscheme (module model mzscheme
(require mzlib/contract (require mzlib/contract
mzlib/etc mzlib/etc
mzlib/match scheme/match
mzlib/class mzlib/class
scheme/list
(prefix a: "annotate.ss") (prefix a: "annotate.ss")
(prefix r: "reconstruct.ss") (prefix r: "reconstruct.ss")
"shared.ss" "shared.ss"
@ -48,6 +49,7 @@
"model-settings.ss" "model-settings.ss"
"macro-unwind.ss" "macro-unwind.ss"
"lifting.ss" "lifting.ss"
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
;; for breakpoint display ;; for breakpoint display
;; (commented out to allow nightly testing) ;; (commented out to allow nightly testing)
#;"display-break-stuff.ss") #;"display-break-stuff.ss")
@ -169,15 +171,20 @@
(let* ([mark-list (and mark-set (extract-mark-list mark-set))]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed) (define (reconstruct-all-completed)
(map (match-lambda (filter-map
[`(,source-thunk ,lifting-indices ,getter) (match-lambda
(match (r:reconstruct-completed [(list source-thunk lifting-indices getter)
(source-thunk) lifting-indices (let ([source (source-thunk)])
getter render-settings) (if (r:hide-completed? source)
[#(exp #f) (unwind exp render-settings)] #f
[#(exp #t) exp])]) (match (r:reconstruct-completed
finished-exps)) source lifting-indices
getter render-settings)
[(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) #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings) (if (r:skip-step? break-kind mark-list render-settings)
(begin (begin

3
collects/stepper/private/my-macros.ss
View File

@ -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) (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals)
(define 2vals vector) (define 2vals vector)

127
collects/stepper/private/reconstruct.ss
View File

@ -8,11 +8,13 @@
mzlib/list mzlib/list
mzlib/etc mzlib/etc
mzlib/contract mzlib/contract
scheme/match
"marks.ss" "marks.ss"
"model-settings.ss" "model-settings.ss"
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss"
(for-syntax scheme/base)) (for-syntax scheme/base)
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
(provide/contract (provide/contract
[reconstruct-completed (syntax? [reconstruct-completed (syntax?
@ -21,6 +23,7 @@
render-settings? render-settings?
. -> . . -> .
(vector/c syntax? boolean?))] (vector/c syntax? boolean?))]
[hide-completed? (syntax? . -> . boolean?)]
;; front ends for reconstruct-current ;; front ends for reconstruct-current
[reconstruct-left-side (mark-list? [reconstruct-left-side (mark-list?
@ -145,7 +148,9 @@
(define (skip-step? break-kind mark-list render-settings) (define (skip-step? break-kind mark-list render-settings)
(case break-kind (case break-kind
[(result-value-break) [(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) [(result-exp-break)
;; skip if clauses that are the result of and/or reductions ;; 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)]) (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)])
@ -180,34 +185,35 @@
(and (pair? mark-list) (and (pair? mark-list)
(let ([expr (mark-source (car 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)
[id (kernel:kernel-syntax-case expr #f
(identifier? expr) [id
(case (stepper-syntax-property expr 'stepper-binding-type) (identifier? expr)
[(lambda-bound) #t] ; don't halt for lambda-bound vars (case (stepper-syntax-property expr 'stepper-binding-type)
[(let-bound) [(lambda-bound) #t] ; don't halt for lambda-bound vars
(varref-skip-step? expr)] [(let-bound)
[(non-lexical) (varref-skip-step? expr)]
(varref-skip-step? expr)])] [(non-lexical)
[(#%top . id-stx) (varref-skip-step? expr)])]
(varref-skip-step? #`id-stx)] [(#%top . id-stx)
[(#%plain-app . terms) (varref-skip-step? #`id-stx)]
; don't halt for proper applications of constructors [(#%plain-app . terms)
(let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) ; don't halt for proper applications of constructors
(and (procedure? fun-val) (let ([fun-val (lookup-binding mark-list (get-arg-var 0))])
(procedure-arity-includes? (and (procedure? fun-val)
fun-val (procedure-arity-includes?
(length (cdr (syntax->list (syntax terms))))) fun-val
(or (and (render-settings-constructor-style-printing? render-settings) (length (cdr (syntax->list (syntax terms)))))
(if (render-settings-abbreviate-cons-as-list? render-settings) (or (and (render-settings-constructor-style-printing? render-settings)
(eq? fun-val special-list-value) (if (render-settings-abbreviate-cons-as-list? render-settings)
(and (eq? fun-val special-cons-value) (eq? fun-val special-list-value)
(second-arg-is-list? mark-list)))) (and (eq? fun-val special-cons-value)
;(model-settings:special-function? 'vector fun-val) (second-arg-is-list? mark-list))))
(and (eq? fun-val void) ;(model-settings:special-function? 'vector fun-val)
(eq? (cdr (syntax->list (syntax terms))) null)) (and (eq? fun-val void)
(struct-constructor-procedure? fun-val))))] (eq? (cdr (syntax->list (syntax terms))) null))
[else #f]))))) (struct-constructor-procedure? fun-val))))]
[else #f])))))
;; find-special-value finds the value associated with the given name. Applications of functions ;; find-special-value finds the value associated with the given name. Applications of functions
;; like 'list' should not be shown as steps, because the before and after steps will be the same. ;; like 'list' should not be shown as steps, because the before and after steps will be the same.
@ -427,16 +433,18 @@
; for the moment, let-bound vars occur only in and/or : ; for the moment, let-bound vars occur only in and/or :
(recon-value (lookup-binding mark-list var) render-settings)) (recon-value (lookup-binding mark-list var) render-settings))
((let-bound) ((let-bound)
(stepper-syntax-property var (if (stepper-syntax-property var 'stepper-no-lifting-info)
'stepper-lifted-name var
(binding-lifted-name mark-list var))) (stepper-syntax-property var
'stepper-lifted-name
(binding-lifted-name mark-list var))))
((stepper-temp) ((stepper-temp)
(error 'recon-source-expr "stepper-temp showed up in source?!?")) (error 'recon-source-expr "stepper-temp showed up in source?!?"))
((non-lexical) ((non-lexical)
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical")) (error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical"))
(else (else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a on var: ~a"
(stepper-syntax-property var 'stepper-binding-type)))))] (stepper-syntax-property var 'stepper-binding-type) (syntax->datum var)))))]
[else ; top-level-varref [else ; top-level-varref
(fixup-name (fixup-name
var)])))] var)])))]
@ -571,8 +579,15 @@
[else [else
reconstructed])))) 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 ; applications
[(#%plain-app . terms) [(#%plain-app . terms)
(attach-info (attach-info
(let* ([sub-exprs (syntax->list (syntax terms))] (match-let*
[arg-temps (build-list (length sub-exprs) get-arg-var)] ([sub-exprs (syntax->list (syntax terms))]
[arg-vals (map (lambda (arg-temp) [arg-temps (build-list (length sub-exprs) get-arg-var)]
(lookup-binding mark-list arg-temp)) [arg-vals (map (lambda (arg-temp)
arg-temps)]) (lookup-binding mark-list arg-temp))
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)) (case (mark-label (car mark-list))
((not-yet-called) ((not-yet-called)
(let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) (if (null? unevaluated)
(zip sub-exprs arg-vals))] #`(#%plain-app . #,rectified-evaluated)
[rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) #`(#%plain-app
(if (null? unevaluated) #,@rectified-evaluated
#`(#%plain-app . #,rectified-evaluated) #,so-far
#`(#%plain-app #,@(map recon-source-current-marks (cdr (map car unevaluated))))))
#,@rectified-evaluated
#,so-far
#,@(map recon-source-current-marks (cdr (map car unevaluated)))))))
((called) ((called)
(if (eq? so-far nothing-so-far) (stepper-syntax-property
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code (if (eq? so-far nothing-so-far)
(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 (else
(error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp)))) (error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp))))
exp)] exp)]