diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index 8d386567ab..b881061803 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -337,7 +337,7 @@ (define* (~vector-set! vec i val) (~ (vector-set! (! vec) (! i) val))) (define* (~set-box! box val) (~ (set-box! (! box) val))) - ;; not much to do with these besides inserting strict points + ;; not much to do with these besides inserting strictness points and ~begin (define-syntax (~cond stx) (syntax-case stx () [(_ [test body ...] ...) @@ -598,6 +598,8 @@ ;; -------------------------------------------------------------------------- ;; mzlib/list functionality + ;; These are a hack, they're not the same due to different error + ;; messages (and they work with improper lists too). (define* (rest x) (~cdr x)) (define* (first x) (~car x)) (define* (second x) (~cadr x)) diff --git a/collects/tests/lazy/forcers.rkt b/collects/tests/lazy/forcers.rkt new file mode 100644 index 0000000000..6a922b6050 --- /dev/null +++ b/collects/tests/lazy/forcers.rkt @@ -0,0 +1,52 @@ +#lang racket/base + +(require tests/eli-tester lazy/force) + +(define (test-lazy/force) + (test (! 1) => 1 + (! (! 1)) => 1 + (! (~ 1)) => 1 + (! (~ (~ (~ 1)))) => 1)) + +(define (test-!list) + (test (!list (list 1 2 3)) => '(1 2 3) + (!list (~ (list 1 2 3))) => '(1 2 3) + (!list (~ (cons 1 (~ (cons 2 (~ (cons 3 (~ null)))))))) => '(1 2 3) + (!list 1) => 1 ; works on dotted lists + (!list (cons 1 2)) => '(1 . 2))) + +(define (test-!!list) + (test (!!list (list 1 2 3)) => '(1 2 3) + (!!list (list (~ 1) (~ 2) (~ 3))) => '(1 2 3) + (!!list (list* (~ 1) (~ 2) (~ 3))) => '(1 2 . 3) + (!!list (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) + => '(1 2 3) + (!!list (~ (cons (~ 1) (~ (list 2 3))))) => '(1 2 3) + (!!list (~ (cons (~ 1) (~ (list 2 (~ 3)))))) => '(1 2 3))) + +(define (test-!!) + (parameterize ([print-graph #t]) + (test + (!! (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) + => '(1 2 3) + (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) ones))) + => "#0=(1 . #0#)" + (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) (list ones ones)))) + => "(#0=(1 . #0#) #0#)" + (format "~s" (!! (letrec ([x (vector 1 (~ x))]) x))) + => "#0=#(1 #0#)" + (format "~s" (!! (letrec ([x (vector-immutable 1 (~ x))]) x))) + => "#0=#(1 #0#)" + (format "~s" (!! (letrec ([x (box (~ x))]) x))) + => "#0=#�#" + (format "~s" (!! (letrec ([x (box-immutable (~ x))]) x))) + => "#0=#�#" + (format "~s" (!! (letrec ([x (make-prefab-struct 'foo 1 (~ x))]) x))) + => "#0=#s(foo 1 #0#)"))) + +(provide forcer-tests) +(define (forcer-tests) + (test do (test-lazy/force) + do (test-!list) + do (test-!!list) + do (test-!!))) diff --git a/collects/tests/lazy/lang.rkt b/collects/tests/lazy/lang.rkt index 81feaa3969..535745cb3b 100644 --- a/collects/tests/lazy/lang.rkt +++ b/collects/tests/lazy/lang.rkt @@ -1,54 +1,75 @@ -#lang scheme/base +#lang lazy -(require tests/eli-tester lazy/force) +(require tests/eli-tester) -;; Currently this has only tests for the lazy language `!' forcer. +;; tests for lazy language constructs -(define (test-lazy/force) - (test (! 1) => 1 - (! (! 1)) => 1 - (! (~ 1)) => 1 - (! (~ (~ (~ 1)))) => 1)) +(define (basic-tests) + (test + (! ((car (list if)) (< 1 2) 3 (error "poof"))) => 3 + (! ((car (list or)) 3 (error "poof"))) => 3 + (! ((car (list and)) (< 2 1) (error "poof"))) => #f + (!! (let ([x 0]) (set! x 1) (list x))) => '(1) ; implicit begin forces + (! (let ([x 0]) (when (zero? x) (error "poof")) 1)) =error> "poof" + (! (let ([x 0]) (when (zero? x) (set! x (add1 x)) (set! x (add1 x))) x)) + => 2 + (! (let ([x 1]) (unless (zero? x) (set! x (add1 x)) (set! x (add1 x))) x)) + => 3 + (! (let ([x 0]) (cond [(zero? x) (set! x (add1 x)) (set! x (add1 x))]) x)) + => 2 + (! (eq? 1 1)) => #t + (! (eq? 1 2)) => #f + (! (eqv? 1.0 1.0)) => #t + (! (eqv? 1.0 1)) => #f + (! (= 1.0 1)) => #t + (! (equal? (list 1.0) (list 1.0))) => #t + (! (letrec ([zs (cons 0 zs)]) (equal? (list zs zs) (list zs zs)))) => #t + )) -(define (test-!list) - (test (!list (list 1 2 3)) => '(1 2 3) - (!list (~ (list 1 2 3))) => '(1 2 3) - (!list (~ (cons 1 (~ (cons 2 (~ (cons 3 (~ null)))))))) => '(1 2 3) - (!list 1) => 1 ; works on dotted lists - (!list (cons 1 2)) => '(1 . 2))) +(define (list-tests) + (test + (! (car 0)) =error> "car: expects argument of type " + (! (cdr 0)) =error> "cdr: expects argument of type " + (! (car (cons 1 (/ 1 0)))) => 1 + (! (cdr (cons (/ 1 0) 1))) => 1 + (! (list-ref (list (/ 1 0) 1 (/ 1 0)) 1)) => 1 + (! (list-ref (cons 1 (/ 1 0)) 0)) => 1 ; doesn't force list structure + (! (list-tail (cons (/ 1 0) 0) 1)) => 0 + (! (length (list (/ 1 0) (/ 1 0) (/ 1 0)))) => 3 + (! (let ([l (list (/ 1 0) (/ 1 0))]) (length (append l l l)))) => 6 + (!! (member 1 (cons 0 (cons 1 2)))) => '(1 . 2) + (!! (memq 1 (cons 0 (cons 1 2)))) => '(1 . 2) + (!! (memv 1 (cons 0 (cons 1 2)))) => '(1 . 2) + (! (second (map car (list 1 2 3)))) =error> "expects argument of type" + (! (second (map car (list 1 '(2) 3)))) => 2 + )) -(define (test-!!list) - (test (!!list (list 1 2 3)) => '(1 2 3) - (!!list (list (~ 1) (~ 2) (~ 3))) => '(1 2 3) - (!!list (list* (~ 1) (~ 2) (~ 3))) => '(1 2 . 3) - (!!list (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) - => '(1 2 3) - (!!list (~ (cons (~ 1) (~ (list 2 3))))) => '(1 2 3) - (!!list (~ (cons (~ 1) (~ (list 2 (~ 3)))))) => '(1 2 3))) - -(define (test-!!) - (parameterize ([print-graph #t]) - (test - (!! (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) - => '(1 2 3) - (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) ones))) - => "#0=(1 . #0#)" - (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) (list ones ones)))) - => "(#0=(1 . #0#) #0#)" - (format "~s" (!! (letrec ([x (vector 1 (~ x))]) x))) - => "#0=#(1 #0#)" - (format "~s" (!! (letrec ([x (vector-immutable 1 (~ x))]) x))) - => "#0=#(1 #0#)" - (format "~s" (!! (letrec ([x (box (~ x))]) x))) - => "#0=#�#" - (format "~s" (!! (letrec ([x (box-immutable (~ x))]) x))) - => "#0=#�#" - (format "~s" (!! (letrec ([x (make-prefab-struct 'foo 1 (~ x))]) x))) - => "#0=#s(foo 1 #0#)"))) +(define (take-tests) + (define test-lst1 '(1 2 3)) + (test + (! (take "nonnum" test-lst1)) + =error> + #rx"take: expects type as 1st .* '\\(1 2 3\\)" + (! (take -1 test-lst1)) + =error> "take: expects type as 1st argument" + (! (take -1 "nonlist")) + =error> "take: expects type as 1st argument" + (! (take 0 "nonlist")) => '() + (! (take 1 "nonlist")) =error> "take: not a proper list: \"nonlist\"" + (! (take 0 null)) => '() + (! (take 0 test-lst1)) => '() + (!! (take 1 test-lst1)) => '(1) + (!! (take 2 test-lst1)) => '(1 2) + (!! (take 3 (take 4 test-lst1))) => '(1 2 3) ; doesn't force the error + (! (fourth (take 4 test-lst1))) ; this one does + =error> "take: index 4 too large for input list" + (! (list-ref (take (~ 1) (list 2)) 0)) => 2 + (! (take 0 (error))) => '() ; doesn't even force the list structure + (!! (take 1 (cons 0 (error "poof")))) => '(0) + )) (provide lang-tests) (define (lang-tests) - (test do (test-lazy/force) - do (test-!list) - do (test-!!list) - do (test-!!))) + (! (begin (basic-tests) + (list-tests) + (take-tests)))) diff --git a/collects/tests/lazy/langimpl.rkt b/collects/tests/lazy/langimpl.rkt deleted file mode 100644 index 6dbee9933a..0000000000 --- a/collects/tests/lazy/langimpl.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang scheme/base - -(require tests/eli-tester lazy) - -;; tests for lazy language constructs -;; add tests as needed - -(provide test-take) - -(define (test-take) - (define test-lst1 '(1 2 3)) - (test (! (take "nonnum" test-lst1)) =error> "take: expects type as 1st argument, given: \"nonnum\"; other arguments were: (1 2 3)" - (! (take -1 test-lst1)) =error> "take: expects type as 1st argument, given: -1; other arguments were: (1 2 3)" - (! (take -1 "nonlist")) =error> "take: expects type as 1st argument, given: -1; other arguments were: \"nonlist\"" - (! (take 0 "nonlist")) => '() ; this is how Racket's take behaves - (! (take 1 "nonlist")) =error> "take: not a proper list: \"nonlist\"" - (! (take 0 null)) => '() - (! (take 0 test-lst1)) => '() ; test for push#22080 - (! (car (take 1 test-lst1))) => 1 - (! (cdr (take 1 test-lst1))) => '() - (! (first (take 2 test-lst1))) => 1 - (! (second (take 2 test-lst1))) => 2 - (! (cddr (take 2 test-lst1))) => '() - (! (first (take 4 test-lst1))) => 1 - (! (second (take 4 test-lst1))) => 2 - (! (third (take 4 test-lst1))) => 3 - (! (fourth (take 4 test-lst1))) =error> "take: index 4 too large for input list" - (! (list-ref (take (car (list 1)) (list 2)) 0)) => 2 - )) - -; not working, only get 1 test passed -#;(define (langimpl-tests) - (test (test-take))) \ No newline at end of file diff --git a/collects/tests/lazy/main.rkt b/collects/tests/lazy/main.rkt index eb81b0fa86..d83898e135 100644 --- a/collects/tests/lazy/main.rkt +++ b/collects/tests/lazy/main.rkt @@ -1,9 +1,7 @@ -#lang scheme/base +#lang racket/base -(require tests/eli-tester "promise.rkt" "lang.rkt" "langimpl.rkt") +(require tests/eli-tester "promise.rkt" "forcers.rkt" "lang.rkt") -(test do (lang-tests) -; do (langimpl-tests) ; not working, so import test-take directly - do (test-take) - do (promise-tests) -) +(test do (promise-tests) + do (forcer-tests) + do (lang-tests)) diff --git a/collects/tests/lazy/promise.rkt b/collects/tests/lazy/promise.rkt index 71e347fa9c..0dfb2b9ef1 100644 --- a/collects/tests/lazy/promise.rkt +++ b/collects/tests/lazy/promise.rkt @@ -1,6 +1,8 @@ -#lang scheme/base +#lang racket/base -(require scheme/promise tests/eli-tester (for-syntax scheme/base)) +;; Tests for the various racket promises + +(require racket/promise tests/eli-tester (for-syntax racket/base)) ;; check that things are `promise?'s or not (define (test-types)