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.

34
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,7 +51,7 @@
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)
@ -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,19 +117,13 @@
[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)
(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 (let* ([printed-name
(or (stepper-syntax-property #`name 'stepper-lifted-name) (or (stepper-syntax-property #`name 'stepper-lifted-name)
(stepper-syntax-property #'name 'stepper-orig-name) (stepper-syntax-property #'name 'stepper-orig-name)
@ -138,7 +133,7 @@
[define-type (stepper-syntax-property [define-type (stepper-syntax-property
unwound-body 'stepper-define-type)]) unwound-body 'stepper-define-type)])
(if define-type (if define-type
(kernel:kernel-syntax-case (kernel-syntax-case
unwound-body #f unwound-body #f
[(lambda arglist lam-body ...) [(lambda arglist lam-body ...)
(case define-type (case define-type
@ -167,7 +162,7 @@
[else (error 'unwind-define [else (error 'unwind-define
"expr with stepper-define-type is not a lambda: ~e" "expr with stepper-define-type is not a lambda: ~e"
(syntax->datum unwound-body))]) (syntax->datum unwound-body))])
#`(define #,printed-name #,unwound-body)))))] #`(define #,printed-name #,unwound-body))))]
[else (error 'unwind-define [else (error 'unwind-define
"expression is not a define-values: ~e" "expression is not a define-values: ~e"
(syntax->datum stx))])) (syntax->datum stx))]))
@ -203,7 +198,7 @@
#`(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)
@ -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 )]))
) )

19
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
[(list source-thunk lifting-indices getter)
(let ([source (source-thunk)])
(if (r:hide-completed? source)
#f
(match (r:reconstruct-completed (match (r:reconstruct-completed
(source-thunk) lifting-indices source lifting-indices
getter render-settings) getter render-settings)
[#(exp #f) (unwind exp render-settings)] [(vector exp #f) (unwind exp render-settings)]
[#(exp #t) exp])]) [(vector exp #t) exp])))])
finished-exps)) 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)

47
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,7 +185,8 @@
(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)
(kernel:kernel-syntax-case expr #f
[id [id
(identifier? expr) (identifier? expr)
(case (stepper-syntax-property expr 'stepper-binding-type) (case (stepper-syntax-property expr 'stepper-binding-type)
@ -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)
(if (stepper-syntax-property var 'stepper-no-lifting-info)
var
(stepper-syntax-property var (stepper-syntax-property var
'stepper-lifted-name 'stepper-lifted-name
(binding-lifted-name mark-list var))) (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)])))]
@ -572,6 +580,13 @@
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*
([sub-exprs (syntax->list (syntax terms))]
[arg-temps (build-list (length sub-exprs) get-arg-var)] [arg-temps (build-list (length sub-exprs) get-arg-var)]
[arg-vals (map (lambda (arg-temp) [arg-vals (map (lambda (arg-temp)
(lookup-binding mark-list arg-temp)) (lookup-binding mark-list arg-temp))
arg-temps)]) arg-temps)]
(case (mark-label (car mark-list)) [(vector evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
((not-yet-called)
(let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*))
(zip sub-exprs arg-vals))] (zip sub-exprs arg-vals))]
[rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))])
(case (mark-label (car mark-list))
((not-yet-called)
(if (null? unevaluated) (if (null? unevaluated)
#`(#%plain-app . #,rectified-evaluated) #`(#%plain-app . #,rectified-evaluated)
#`(#%plain-app #`(#%plain-app
#,@rectified-evaluated #,@rectified-evaluated
#,so-far #,so-far
#,@(map recon-source-current-marks (cdr (map car unevaluated))))))) #,@(map recon-source-current-marks (cdr (map car unevaluated))))))
((called) ((called)
(stepper-syntax-property
(if (eq? so-far nothing-so-far) (if (eq? so-far nothing-so-far)
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur?
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...)))) (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)]