diff --git a/collects/frtime/core/dv.ss b/collects/frtime/core/dv.ss index fce55e0679..19368c7f83 100644 --- a/collects/frtime/core/dv.ss +++ b/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])] diff --git a/collects/frtime/core/erl.ss b/collects/frtime/core/erl.ss index f9b56b90e5..ab74b5592f 100644 --- a/collects/frtime/core/erl.ss +++ b/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) diff --git a/collects/frtime/core/heap.ss b/collects/frtime/core/heap.ss index 8f533ec686..ee7b9b1853 100644 --- a/collects/frtime/core/heap.ss +++ b/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?)]) diff --git a/collects/frtime/core/mailbox.ss b/collects/frtime/core/mailbox.ss index ef679f6b3f..499cd88172 100644 --- a/collects/frtime/core/mailbox.ss +++ b/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))]) \ No newline at end of file diff --git a/collects/frtime/tests/dv.ss b/collects/frtime/tests/dv.ss new file mode 100644 index 0000000000..12597379ea --- /dev/null +++ b/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) + + )) + + + \ No newline at end of file diff --git a/collects/frtime/tests/erl.ss b/collects/frtime/tests/erl.ss index d1240b312d..4db3df32a3 100644 --- a/collects/frtime/tests/erl.ss +++ b/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) \ No newline at end of file +(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)) \ No newline at end of file diff --git a/collects/frtime/tests/heap.ss b/collects/frtime/tests/heap.ss index e758292615..bad8417764 100644 --- a/collects/frtime/tests/heap.ss +++ b/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 + )) \ No newline at end of file diff --git a/collects/frtime/tests/mailbox.ss b/collects/frtime/tests/mailbox.ss new file mode 100644 index 0000000000..fa254b4f6c --- /dev/null +++ b/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) \ No newline at end of file