From e41ba9c77bab1efe893ddf269a5352a23f55f5a5 Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Tue, 5 Apr 2011 20:01:03 -0400 Subject: [PATCH] in lazy/lazy.rkt - modify cond for stepper - add support for multiple values in stepper - add inspector to multiple-values struct - hide split-values call in ~define-values in tests/stepper/ - add tests for cond in stepper/private/annotate.rkt - in annotate/top-level, allow arbitrary top-level terms (no error in else case), otherwise exprs like let throws error in stepper/private/ reconstruct.rkt lazy-highlighting.rkt - add support for eq? eqv? equal? lazy fns --- collects/lazy/lazy.rkt | 37 +++++++--- collects/stepper/private/annotate.rkt | 5 +- .../stepper/private/lazy-highlighting.rkt | 3 + collects/stepper/private/reconstruct.rkt | 9 +-- collects/tests/stepper/automatic-tests.rkt | 2 +- collects/tests/stepper/through-tests.rkt | 72 +++++++++++++++++++ 6 files changed, 110 insertions(+), 18 deletions(-) diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index 138c735c71..ad5d2ced25 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -192,10 +192,14 @@ ;; used (spceifically, students never use them). So `values' is redefined to ;; produce a first-class tuple-holding struct, and `split-values' turns that ;; into multiple values. - (define-struct multiple-values (values)) + ;; STC: add inspector for lazy stepper + (define-struct multiple-values (values) (make-inspector)) (define (split-values x) (let ([x (! x)]) (if (multiple-values? x) (apply values (multiple-values-values x)) x))) + (define-syntax (hidden-split-values stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (split-values arg)))])) ;; Force and split resulting values. (define (!values x) (split-values (! x))) @@ -211,7 +215,7 @@ ;; Redefine multiple-value constructs so they split the results (defsubst (~define-values (v ...) body) - (define-values (v ...) (split-values body))) + (define-values (v ...) (hidden-split-values body))) (defsubst (~let-values ([(x ...) v] ...) body ...) (let-values ([(x ...) (split-values v)] ...) (~begin body ...))) (defsubst (~let*-values ([(x ...) v] ...) body ...) @@ -382,16 +386,29 @@ (define* (~set-box! box val) (~ (set-box! (! box) val))) ;; not much to do with these besides inserting strictness points and ~begin + ; for stepper: change else to #t test, add new error else branch (define-syntax (~cond stx) (syntax-case stx () - [(_ [test body ...] ...) - (with-syntax ([(test ...) - ;; avoid forcing an `else' keyword - (map (lambda (stx) - (syntax-case stx (else) - [else stx] [x #'(hidden-! x)])) - (syntax->list #'(test ...)))]) - #'(hidden-~ (cond [test (~begin body ...)] ...)))])) + [(_ clause ...) ; stepper needs the loc of the full clause + (with-syntax + ([(new-clause ...) + (map + (λ (c) + (with-syntax ([(test body ...) c]) + (with-syntax + ([new-test + (syntax-case #'test (else) + [else ; for stepper + (stepper-syntax-property #'#t 'stepper-else #t)] + [x (syntax/loc #'x (hidden-! x))])]) + (syntax/loc c (new-test (~begin body ...)))))) + (syntax->list #'(clause ...)))] + [new-else-body (syntax/loc stx (error 'cond "should not get here"))]) + #`(hidden-~ + #,(syntax/loc stx + (cond + new-clause ... + [else new-else-body]))))])) (defsubst (~case v [keys body ...] ...) (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...))) diff --git a/collects/stepper/private/annotate.rkt b/collects/stepper/private/annotate.rkt index 51e11ff60d..7106ea06ed 100644 --- a/collects/stepper/private/annotate.rkt +++ b/collects/stepper/private/annotate.rkt @@ -1191,9 +1191,8 @@ exp] ; STC: for lazy, handle defines [(define-values (ids ...) bodies) (annotate/module-top-level exp)] - ; STC: for lazy - [(#%plain-app . terms) (annotate/module-top-level exp)] - [else + [else (annotate/module-top-level exp)] + #;[else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax->datum exp)) #;(annotate/module-top-level exp)]))) diff --git a/collects/stepper/private/lazy-highlighting.rkt b/collects/stepper/private/lazy-highlighting.rkt index 58a149b694..ce92aaa8ab 100644 --- a/collects/stepper/private/lazy-highlighting.rkt +++ b/collects/stepper/private/lazy-highlighting.rkt @@ -44,4 +44,7 @@ (sixth . 0) (seventh . 0) (eighth . 0) + (eq? . 0) + (eqv? . 0) + (equal? . 0) ))) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index d760629627..9c2b5e7c54 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -902,10 +902,11 @@ (cond [(eq? obj-name 'force) so-far] [(ormap (lx (eq? obj-name _)) - '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr - cdadar cdaddr cddaar cddadr cdddar cddddr - first second third fourth fifth sixth seventh eighth take)) + '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar + cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + first second third fourth fifth sixth seventh eighth take + eq? eqv? equal?)) #`(#%plain-app . #,rectified-evaluated)] [else (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))]))) diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index 798206ef89..339e65bc9d 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -14,7 +14,7 @@ lazy-cddadr lazy-cdddar lazy-cddddr lazy-second lazy-third lazy-fourth lazy-fifth lazy-sixth lazy-seventh lazy-eighth lazy-if1 lazy-if2 lazy-take-0 lazy-take lazy-take-impl - lazy-unknown1 lazy-unknown2 lazy-inf-list1)) + lazy-unknown1 lazy-unknown2 lazy-inf-list1 lazy-cond1 lazy-cond2)) (let ((outer-namespace (current-namespace))) (parameterize ([display-only-errors #t] diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index 745717fbbd..1264c8af37 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -1922,6 +1922,78 @@ -> ,add1-def ,nats-def-expanded {5} )) + ; lazy-cond1, lazy-cond2 +; (define (f x) +; (cond ((> 0 x) (/ 1 0)) +; ((< 0 x) (* x 10)) +; (else (+ x 10)))) +; (f 0) +; (f 1) + (let* ([make-test1 (λ (x) `(> 0 ,x))] + [make-test2 (λ (x) `(< 0 ,x))] + [test1 (make-test1 0)] + [test2 (make-test2 0)] + [test12 (make-test1 2)] + [test22 (make-test2 2)] + [make-clause1 (λ (x) `(* ,x 10))] + [make-clause2 (λ (x) `(+ ,x 10))] + [clause1 (make-clause1 0)] + [clause2 (make-clause2 0)] + [clause12 (make-clause1 2)] + [clause22 (make-clause2 2)] + [cnd (λ (x) `(cond (,(make-test1 x) ,err) + (,(make-test2 x) ,(make-clause1 x)) + (else ,(make-clause2 x))))] + [make-def (λ (x) `(define (f x) ,(cnd x)))] + [def (make-def 'x)] + [lam (λ (x) `(lambda (x) ,(cnd x)))]) + (t 'lazy-cond1 m:lazy + ,def (f 0) + :: ,def ({f} 0) -> ,def ({,(lam 'x)} 0) + :: ,def {(,(lam 'x ) 0)} -> ,def {,(cnd 0)} + :: ,def (cond ({,test1} ,err) + (,test2 ,clause1) + (else ,clause2)) + -> ,def (cond ({false} ,err) + (,test2 ,clause1) + (else ,clause2)) + :: ,def {(cond (false ,err) + (,test2 ,clause1) + (else ,clause2))} + -> ,def {(cond (,test2 ,clause1) + (else ,clause2))} + :: ,def (cond ({,test2} ,clause1) + (else ,clause2)) + -> ,def (cond ({false} ,clause1) + (else ,clause2)) + :: ,def {(cond (false ,clause1) + (else ,clause2))} + -> ,def {(cond (else ,clause2))} + -> ,def {,clause2} -> ,def {10}) + (t 'lazy-cond2 m:lazy + ,def (f 2) + :: ,def ({f} 2) -> ,def ({,(lam 'x)} 2) + :: ,def {(,(lam 'x ) 2)} -> ,def {,(cnd 2)} + :: ,def (cond ({,test12} ,err) + (,test22 ,clause12) + (else ,clause22)) + -> ,def (cond ({false} ,err) + (,test22 ,clause12) + (else ,clause22)) + :: ,def {(cond (false ,err) + (,test22 ,clause12) + (else ,clause22))} + -> ,def {(cond (,test22 ,clause12) + (else ,clause22))} + :: ,def (cond ({,test22} ,clause12) + (else ,clause22)) + -> ,def (cond ({true} ,clause12) + (else ,clause22)) + :: ,def {(cond (true ,clause12) + (else ,clause22))} + -> ,def {,clause12} -> ,def {20}) + ) + #; (t1 'teachpack-callbacks (test-teachpack-sequence