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

in stepper/private/reconstruct.rkt

Browse Source 
- in recon-inner, in called app case
  - add other force fns to force case (!!, !list, !!list)
  - add other list fns
    (list?, length, list-ref, etc)

in stepper/private/lazy-highlighting.rkt
- add various list fns (list?, length, list-ref, etc)

in stepper/private/macro-unwind.rkt
- in unwind-cond, disable check of user-source and user-position

in tests/stepper/
- add test for various list fns
This commit is contained in:
Stephen Chang 2011-04-06 17:58:45 -04:00
parent e41ba9c77b
commit 5d47c0b49b
6 changed files with 117 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/lazy/lazy.rkt
View File

@ -404,11 +404,12 @@
(syntax/loc c (new-test (~begin body ...))))))
(syntax->list #'(clause ...)))]
[new-else-body (syntax/loc stx (error 'cond "should not get here"))])
#`(hidden-~
(quasisyntax/loc stx
(hidden-~
#,(syntax/loc stx
(cond
new-clause ...
[else new-else-body]))))]))
[else new-else-body])))))]))
(defsubst (~case v [keys body ...] ...)
(hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...)))

23
collects/stepper/private/lazy-highlighting.rkt
View File

@ -7,8 +7,8 @@
(define
table
(make-immutable-hasheq
'((take . 0)
(caar . 1)
'((take . 0)
(caar . 1)
(cadr . 0)
(cdar . 1)
(cddr . 0)
@ -47,4 +47,21 @@
(eq? . 0)
(eqv? . 0)
(equal? . 0)
)))
(list? . 0)
(length . 0)
(list-ref . 0)
(list-tail . 0)
(append . 0)
(reverse . 0)
(empty? . 0)
(assoc . 0)
(assq . 0)
(assv . 0)
(cons? . 0)
(remove . 0)
(remq . 0)
(remv . 0)
(member . 0)
(memq . 0)
(memv . 0)
)))

5
collects/stepper/private/macro-unwind.rkt
View File

@ -257,7 +257,10 @@
(with-syntax
([clauses
(let loop ([stx stx])
(if (and (eq? user-source
; STC: I'm disabling this check because the user-position on some
; lazy conds are not correct, but I can't figure out where.
; Disabling this check does not break any existing stepper tests.
(if #t #;(and (eq? user-source
(syntax-property stx 'user-source))
(eq? user-position
(syntax-property stx 'user-position)))

8
collects/stepper/private/reconstruct.rkt
View File

@ -899,14 +899,18 @@
; dont show ellipses for force (and other lazy fns)
; object-name is good enough here, so dont need to add another "special val"
(let ([obj-name (object-name (car arg-vals))])
(cond [(eq? obj-name 'force) so-far]
(cond [(ormap
(lx (eq? obj-name _))
'(force ! !! !list !!list))
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
eq? eqv? equal?))
eq? eqv? equal? list? length list-ref list-tail append reverse
empty? assoc assq assv cons? remove remq remv member memq memv))
#`(#%plain-app . #,rectified-evaluated)]
[else
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))])))

8
collects/tests/stepper/automatic-tests.rkt
View File

@ -14,7 +14,11 @@
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-cond1 lazy-cond2))
lazy-unknown1 lazy-unknown2 lazy-inf-list1 lazy-cond1 lazy-cond2
lazy-eq? lazy-eqv? lazy-equal? lazy-list?1 lazy-list?2 lazy-list?3
lazy-length lazy-list-ref lazy-list-tail lazy-append lazy-reverse lazy-empty?
lazy-assoc lazy-assq lazy-assv lazy-cons? lazy-remove lazy-remq lazy-remv
lazy-member lazy-memq lazy-memv))
(let ((outer-namespace (current-namespace)))
(parameterize ([display-only-errors #t]
@ -25,7 +29,7 @@
;; make sure the tests' print-convert sees the teaching languages' properties
#;(namespace-attach-module outer-namespace 'mzlib/pconvert-prop (current-namespace))
(namespace-require 'test-engine/racket-tests)
(if (and #;(run-all-tests-except
(if (and (run-all-tests-except
(append '(bad-and bad-cons check-error begin-let-bug prims qq-splice time
set! local-set! local-struct/i local-struct/ilam)
steve-broke

78
collects/tests/stepper/through-tests.rkt
View File

@ -1994,6 +1994,84 @@
-> ,def {,clause12} -> ,def {20})
)
(t 'lazy-eq? m:lazy
(eq? 'a 'a)
:: {(eq? 'a'a)} -> {true})
(t 'lazy-eqv? m:lazy
(eqv? (integer->char 955) (integer->char 955))
:: (eqv? {(integer->char 955)} (integer->char 955))
-> (eqv? {#\λ} (integer->char 955))
:: (eqv? #\λ {(integer->char 955)})
-> (eqv? #\λ {#\λ})
:: {(eqv? #\λ #\λ)} -> {true})
(t 'lazy-equal? m:lazy
(equal? (list 1 2) (list 1 2))
:: {(equal? (list 1 2) (list 1 2))} -> {true})
(t 'lazy-list?1 m:lazy
(list? (list 1 2))
:: {(list? (list 1 2))} -> {true})
(t 'lazy-list?2 m:lazy
(list? empty)
:: {(list? empty)} -> {true})
(t 'lazy-list?3 m:lazy
(list? (+ 1 2))
:: (list? {(+ 1 2)}) -> (list? {3})
:: {(list? 3)} -> {false})
(t 'lazy-length m:lazy
(length (list 1 2))
:: {(length (list 1 2))} -> {2})
(t 'lazy-list-ref m:lazy
(list-ref (list 1 2) (+ 1 0))
:: (list-ref (list 1 2) {(+ 1 0)}) -> (list-ref (list 1 2) {1})
:: {(list-ref (list 1 2) 1)} -> {2})
(t 'lazy-list-tail m:lazy
(list-tail (list 1 2) 1)
:: {(list-tail (list 1 2) 1)} -> {(list 2)})
(t 'lazy-append m:lazy
(append (list 1 2) (list 3 4))
:: {(append (list 1 2) (list 3 4))}
-> {(cons 1 ,(<delay#> 0))})
(t 'lazy-reverse m:lazy
(reverse (list 1 2 3))
:: {(reverse (list 1 2 3))} -> {(list 3 2 1)})
(t 'lazy-empty? m:lazy
(empty? (list 1 2))
:: {(empty? (list 1 2))} -> {false})
(t 'lazy-assoc m:lazy
(assoc 1 (list (list 1 2)))
:: {(assoc 1 (list (list 1 2)))} -> {(list 1 2)})
(t 'lazy-assq m:lazy
(assq 1 (list (list 1 2)))
:: {(assq 1 (list (list 1 2)))} -> {(list 1 2)})
(t 'lazy-assv m:lazy
(assv 1 (list (list 1 2)))
:: {(assv 1 (list (list 1 2)))} -> {(list 1 2)})
(t 'lazy-cons? m:lazy
(cons? (list 1 2))
:: {(cons? (list 1 2))} -> {true})
(t 'lazy-remove m:lazy
(remove 2 (list 1 2 3))
:: {(remove 2 (list 1 2 3))} -> {(cons 1 ,(<delay#> 0))})
(t 'lazy-remq m:lazy
(remq 2 (list 1 2 3))
:: {(remq 2 (list 1 2 3))} -> {(cons 1 ,(<delay#> 0))})
(t 'lazy-remv m:lazy
(remv 2 (list 1 2 3))
:: {(remv 2 (list 1 2 3))} -> {(cons 1 ,(<delay#> 0))})
(t 'lazy-member m:lazy
(member 1 (list 1 2))
:: {(member 1 (list 1 2))} -> {(list 1 2)})
(t 'lazy-memq m:lazy
(memq 1 (list 1 2))
:: {(memq 1 (list 1 2))} -> {(list 1 2)})
(t 'lazy-memv m:lazy
(memv 1 (list 1 2))
:: {(memv 1 (list 1 2))} -> {(list 1 2)})
#;
(t1 'teachpack-callbacks
(test-teachpack-sequence