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
This commit is contained in:
Stephen Chang
parent
c0f8f1cdb2
commit
e41ba9c77b
|
|
@ -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 ...)] ...)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)])))
|
||||
|
|
|
|||
|
|
@ -44,4 +44,7 @@
|
|||
(sixth . 0)
|
||||
(seventh . 0)
|
||||
(eighth . 0)
|
||||
(eq? . 0)
|
||||
(eqv? . 0)
|
||||
(equal? . 0)
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -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 ...))])))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user