Adding test cases for core libraries

svn: r15303

collects/frtime/core/dv.ss

@@ -1,18 +1,18 @@
 #lang scheme
 (require "contract.ss")
 
-(define-struct dv (real used vec) #:mutable)
+(define-struct dv (vec-length next-avail-pos vec) #:mutable)
 
 (define (dv:make size)
   (make-dv size 0 (make-vector size)))
 
-(define (dv:length dv) (dv-used dv))
+(define (dv:length dv) (dv-next-avail-pos dv))
 
 (define (dv:remove-last a-dv)
   (match a-dv
     [(struct dv (_ used vec))
-     (set-dv-used! a-dv (sub1 used))
-     (vector-set! vec used 0)]))
+     (set-dv-next-avail-pos! a-dv (sub1 used))
+     (vector-set! vec (sub1 used) 0)]))
 
 (define (dv:ref a-dv pos)
   (match a-dv
@@ -28,7 +28,7 @@
   (match a-dv
     [(struct dv (real used vec))
      (if (used . < . real)
-         (begin (set-dv-used! a-dv (add1 used))
+         (begin (set-dv-next-avail-pos! a-dv (add1 used))
                 (vector-set! vec used item))
          (let ([new-vec 
                 (build-vector
@@ -37,15 +37,19 @@
                    (if (i . < . used)
                        (vector-ref vec i)
                        0)))])
+           (printf "Doubling DV to ~a~n" (* 2 real))
            (set-dv-vec! a-dv new-vec)
-           (set-dv-real! a-dv (* 2 real))
-           (set-dv-used! a-dv (add1 used))
-           (vector-set! new-vec used item)))]))
+           (set-dv-vec-length! a-dv (* 2 real))
+           (dv:append a-dv item)))]))
+
+(define (non-empty-dv? dv)
+  ((dv:length dv) . > . 0))
 
 (provide/contract*
+ [dv? (any/c . -> . boolean?)]
  [dv:make (exact-nonnegative-integer? . -> . dv?)]
  [dv:length (dv? . -> . exact-nonnegative-integer?)]
- [dv:remove-last (dv? . -> . void)]
+ [dv:remove-last (non-empty-dv? . -> . void)]
  [dv:ref (->d ([dv dv?] [pos exact-nonnegative-integer?]) () 
               #:pre-cond (pos . < . (dv:length dv))
               [r any/c])]

collects/frtime/core/erl.ss

@@ -1,6 +1,7 @@
 #lang scheme
 (require "match.ss"
          "contract.ss"
+         #;"sema-mailbox.ss"
          "mailbox.ss")
 
 (define-struct tid (lid) #:prefab)

collects/frtime/core/heap.ss

@@ -107,8 +107,8 @@
  [make-heap (sorter/c equality/c . -> . heap?)]
  [heap-empty? (heap? . -> . boolean?)]
  [heap-insert (heap? any/c . -> . void)]
- [heap-pop (non-empty-heap? . -> . void)]
+ [heap-pop (non-empty-heap? . -> . any/c)]
  [heap-peak (non-empty-heap? . -> . any/c)]
  [heap-remove-pos (non-empty-heap? exact-nonnegative-integer? . -> . void)]
- [heap-remove (heap? any/c . -> . void)]
+ [heap-remove (heap? any/c . -> . boolean?)]
  [heap-contains (heap? any/c . -> . boolean?)])

collects/frtime/core/mailbox.ss

@@ -82,5 +82,5 @@
 (provide/contract*
  [mailbox? (any/c . -> . boolean?)]
  [new-mailbox (-> mailbox?)]
- [mailbox-send! (mailbox? any/c . -> . void)]
+ [mailbox-send! (mailbox? (not/c false/c) . -> . void)]
  [mailbox-receive (mailbox? (or/c false/c number?) (-> any) (any/c . -> . (-> any)) . -> . (-> any))])

collects/frtime/tests/dv.ss

@@ -0,0 +1,40 @@
+#lang scheme
+(require frtime/core/dv
+         scheme/package
+         tests/eli-tester)
+
+(define (dv:ref* d l)
+  (for/list ([i (in-list l)])
+    (dv:ref d i)))
+
+(test
+ (dv:length (dv:make 5)) => 0)
+
+(package-begin
+ (define d (dv:make 5))
+ (test
+  (dv? d) => true
+  (dv:append d 1) => (void)
+  (dv:length d) => 1
+  (dv:ref d 0) => 1
+  (dv:set! d 0 2) => (void)
+  (dv:ref d 0) => 2
+  (dv:remove-last d) => (void)
+  (dv:length d) => 0
+  (dv:ref d 0) => 0
+  
+  (dv:append d 1) => (void)
+  (dv:append d 2) => (void)
+  (dv:append d 3) => (void)
+  (dv:ref* d (list 0 1 2)) => (list 1 2 3)
+  (dv:set! d 0 4) => (void)
+  (dv:ref* d (list 0 1 2)) => (list 4 2 3)
+  (dv:remove-last d) => (void)
+  (dv:ref* d (list 0 1 2)) => (list 4 2 0)
+  (dv:append d 5) => (void)
+  (dv:ref* d (list 0 1 2)) => (list 4 2 5)
+  
+  ))
+  
+ 
+ 

collects/frtime/tests/erl.ss

@@ -1,6 +1,28 @@
 #lang scheme
-(require frtime/erl)
+(require frtime/core/erl
+         tests/eli-tester)
 
-(define t (spawn/name 'test (receive [#f (error 'test "Got an #f")])))
+(define ch (make-channel))
+(define t
+  (spawn/name 
+   'test
+   (let loop ()
+     (receive 
+      [after 10 
+             (channel-put ch "Timeout")
+             (loop)]
+      ['self
+       (channel-put ch (self))
+       (loop)]
+      [v
+       (channel-put ch v)
+       (loop)]))))
 
-(! t #t)
+(test
+ (! t #t) => (void)
+ (channel-get ch) => #t
+ (! t (list 1 2)) => (void)
+ (channel-get ch) => (list 1 2)
+ (! t 'self) => (void)
+ (channel-get ch) => #s(tid test)
+ (self) => #s(tid thread1))

collects/frtime/tests/heap.ss

@@ -1,27 +1,41 @@
 #lang scheme
-(require frtime/heap)
+(require frtime/core/heap
+         scheme/package
+         tests/eli-tester)
 
-(define f (make-heap > eq?))
-(heap-insert f 99)
-(printf "A ~S~n" f)
-(heap-remove-pos f 1)
-(printf "B ~S~n" f)
-(for-each (lambda (x) (heap-insert f x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
-(printf "C ~S~n" f)
-(heap-remove f 10) (printf "~S~n" f)
-(heap-remove f 5) (printf "~S~n" f)
-(heap-remove f 8) (printf "~S~n" f)
-(heap-remove f 13) (printf "~S~n" f)
-(printf "~S~n" (heap-contains f 11))
-(printf "~S~n" (heap-contains f 123))
-(heap-pop f)
-(heap-pop f)
-(heap-pop f)
-(heap-pop f) (printf "~S~n" f)
-(printf "~S~n" (heap-contains f 11))
-(printf "~S~n" (heap-contains f 4))
-(printf "~S~n" f)
-(heap-remove f 2)
-(printf "~S~n" f)
-(heap-remove f 3)
-(printf "~S~n" f)
+(package-begin
+ (define h (make-heap > eq?))
+ (test
+  (heap? h) => #t
+  (heap-empty? h) => #t
+  (non-empty-heap? h) => #f
+  (heap-insert h 99) => (void)
+  (heap-empty? h) => #f
+  (non-empty-heap? h) => #t
+  (heap-peak h) => 99
+  (heap-pop h) => 99
+  (heap-empty? h) => #t
+  (non-empty-heap? h) => #f
+  (heap-contains h 99) => #f
+  (heap-insert h 99) => (void)
+  (heap-contains h 99) => #t
+  (heap-remove h 99) => #t
+  (heap-contains h 99) => #f
+  (heap-remove h 99) => #f
+  (heap-insert h 1) => (void)
+  (heap-insert h 2) => (void)
+  (heap-insert h 3) => (void)
+  (heap-pop h) => 3
+  (heap-peak h) => 2
+  (heap-pop h) => 2
+  (heap-pop h) => 1
+  (heap-empty? h) => #t
+  (heap-insert h 3) => (void)
+  (heap-insert h 1) => (void)
+  (heap-insert h 4) => (void)
+  (heap-insert h 2) => (void)
+  (heap-pop h) => 4
+  (heap-pop h) => 3
+  (heap-pop h) => 2
+  (heap-pop h) => 1
+  ))

collects/frtime/tests/mailbox.ss

@@ -0,0 +1,41 @@
+#lang scheme
+(require scheme/package
+         tests/eli-tester
+         frtime/core/match
+         (prefix-in ch: frtime/core/mailbox)
+         (prefix-in sema: frtime/core/sema-mailbox))
+
+(define (test-it! new-mailbox mailbox? mailbox-send! mailbox-receive)
+  (define mb (new-mailbox))
+  (define ch (make-channel))
+  (define (error-timeout) (error 'never))
+  (define (id-thnk v) (lambda () v))
+  (define (want-thnk what) 
+    (lambda (v) 
+      (if (= what v)
+          (lambda () v)
+          match-fail)))
+  (test
+   (mailbox? mb) => #t
+   (mailbox-send! mb 25) => (void)  
+   ((mailbox-receive mb #f error-timeout id-thnk)) => 25
+   ((mailbox-receive mb 10 error-timeout id-thnk)) =error> "never"
+   (mailbox-send! mb #f) => (void)  
+   ((mailbox-receive mb #f error-timeout id-thnk)) => #f
+   (mailbox-send! mb 21) => (void)
+   ((mailbox-receive mb 10 error-timeout (want-thnk 25))) =error> "never"
+   ((mailbox-receive mb 10 error-timeout (want-thnk 21))) => 21
+   (mailbox-send! mb 23) => (void)
+   (mailbox-send! mb 24) => (void)
+   ((mailbox-receive mb 10 error-timeout (want-thnk 23))) => 23
+   ((mailbox-receive mb 10 error-timeout (want-thnk 24))) => 24
+   (mailbox-send! mb 24) => (void)
+   (mailbox-send! mb 23) => (void)
+   ((mailbox-receive mb 10 error-timeout (want-thnk 23))) => 23
+   ((mailbox-receive mb 10 error-timeout (want-thnk 24))) => 24  
+   ))
+
+(printf "Channel~n")
+(test-it! ch:new-mailbox ch:mailbox? ch:mailbox-send! ch:mailbox-receive)
+(printf "Semaphore~n")
+(test-it! sema:new-mailbox sema:mailbox? sema:mailbox-send! sema:mailbox-receive)