Changeset 13503 in project


Ignore:
Timestamp:
03/05/09 08:17:42 (11 years ago)
Author:
Kon Lovett
Message:

Release.

Location:
release/4/mailbox
Files:
4 edited
3 copied

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/tags/2.0.0/mailbox.scm

    r13502 r13503  
    199199  scheme
    200200  (only chicken
    201     optional  ;due to #!optional implementation
     201    optional                ;due to #!optional implementation
     202    handle-exceptions       ;due to condition-case implementation
     203    let-optionals           ;due to let-values implementation
     204    with-exception-handler  ;due to condition-case  implementation
    202205    and-let* let-values
    203206    unless when
    204207    make-composite-condition make-property-condition condition-predicate
     208    condition-case
    205209    error signal
    206210    gensym
     
    215219
    216220(define (%queue-add! q datum)
    217   (let ([new-pair (%cons datum '())))
     221  (let ([new-pair (%cons datum '())])
    218222    (if (%null? (%queue-first-pair q))
    219223        (%queue-first-pair-set! q new-pair)
  • release/4/mailbox/tags/2.0.0/mailbox.setup

    r13499 r13503  
    1 (include "setup-header")
     1;;;; mailbox.setup
    22
    3 (install-dynld+syntax mailbox mailbox-support *version*)
     3;;
    44
    5 (install-test "mailbox-test.scm")
     5(required-chicken-version 4.0)
     6
     7;;
     8
     9(define *version* (if (file-exists? "version") (string-chomp (read-all "version") "\n") "trunk"))
     10
     11;;
     12
     13(define (make-fn bn . en)
     14  (apply make-pathname #f (->string bn) en) )
     15
     16(define (doc-fn bn)
     17  (make-fn bn "html") )
     18
     19(define (source-fn bn)
     20  (make-fn bn "scm") )
     21
     22(define (shared-fn bn)
     23  (make-fn bn ##sys#load-dynamic-extension) )
     24
     25(define (static-fn bn)
     26  (make-fn bn "o") )
     27
     28(define (import-fn bn)
     29  (make-fn bn "import") )
     30
     31(define (source-import-fn bn)
     32  (source-fn (import-fn bn)) )
     33
     34(define (shared-import-fn bn)
     35  (shared-fn (import-fn bn)) )
     36
     37;;
     38
     39(define (compile-static-extension nam . args)
     40  (compile ,(source-fn nam)
     41    -optimize-level 2 -debug-level 1
     42    -c -unit ,nam -output-file ,(static-fn nam)
     43    ,@args) )
     44
     45(define (compile-shared-extension nam . args)
     46  (compile ,(source-fn nam)
     47    -optimize-level 2 -debug-level 1
     48    -shared -output-file ,(shared-fn nam)
     49    -emit-import-library ,nam
     50    ,@args)
     51  (compile ,(source-import-fn nam)
     52    -optimize-level 2 -debug-level 0
     53    -shared -output-file ,(shared-import-fn nam)) )
     54
     55;;
     56
     57(define (install-shared-extension nam #!key (compile '()) (install '()))
     58  (apply compile-shared-extension nam compile)
     59  (install-extension nam
     60   `(,(shared-fn nam) ,(shared-import-fn nam))
     61   `((version ,*version*)
     62     (documentation ,(doc-fn nam))
     63     ,@install)) )
     64
     65(define (install-shared-static-extension nam  #!key (compile '()) (install '()))
     66  (apply compile-shared-extension nam compile)
     67  (apply compile-static-extension nam compile)
     68  (install-extension nam
     69   `(,(shared-fn nam) ,(static-fn nam) ,(shared-import-fn nam))
     70   `((version ,*version*)
     71     (static ,(static-fn nam))
     72     (documentation ,(doc-fn nam))
     73     ,@install)) )
     74
     75;;;
     76
     77(install-shared-extension 'mailbox)
  • release/4/mailbox/tags/2.0.0/tests/run.scm

    r13502 r13503  
    1414(define-constant MESSAGE-LIMIT 5)
    1515
    16 (define-constant TIMEOUT 0.5 #;0.25)
     16(define-constant TIMEOUT #;0.5 0.25)
    1717
    1818(define (current-thread-name)
     
    4545                        (thread-labeled-print "Started!")
    4646                        (let loop ([cnt 0])
    47                                 (thread-labeled-print "Sleep @ " (current-seconds))
    48                                 (thread-sleep! TIMEOUT)
    49                                 (thread-labeled-print "Awake @ " (current-seconds))
    50                                 (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
    51                                 (if (= MESSAGE-LIMIT cnt)
     47        (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
     48        (if (= MESSAGE-LIMIT cnt)
    5249            (mailbox-send! mailbox-one 'quit)
    53             (loop (add1 cnt))) ) )
     50            (let ([sleep@seconds (current-seconds)])
     51              (thread-labeled-print "Sleep at " sleep@seconds " sec")
     52              (thread-sleep! TIMEOUT)
     53              (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
     54              (loop (add1 cnt)) ) ) ) )
    5455                'writer-one) )
    5556
     
    5960                        (thread-labeled-print "Started!")
    6061                        (let loop ()
    61                                 (condition-case
    62                                                 (begin
    63                                                         (thread-labeled-print "Receiving @ " (current-seconds))
    64                                                         (let ([msg (mailbox-receive! mailbox-one 0.25 #;0.5)])
    65                                                                 (thread-labeled-print " Message: " msg)
    66                                                                 (unless (eq? 'quit msg) (loop) ) ) )
    67                                         [(exn mailbox timeout)
    68                                                 (thread-labeled-print "Timed Out @ " (current-seconds))
    69                                                 (loop)]
    70                                         [exp ()
    71                                                 (thread-labeled-print "Exception: " exp)]) ) )
     62                          (let ([receive@seconds (current-seconds)])
     63          (condition-case
     64              (begin
     65                (thread-labeled-print "Receiving at " receive@seconds  " sec")
     66                (let ([msg (mailbox-receive! mailbox-one TIMEOUT)])
     67                  (thread-labeled-print "Message " msg)
     68                  (unless (eq? 'quit msg) (loop) ) ) )
     69            [(exn mailbox timeout)
     70              (thread-labeled-print "Timedout after " (- (current-seconds) receive@seconds) " sec")
     71              (loop)]
     72            [exp ()
     73              (thread-labeled-print "Exception: " exp)]) ) ) )
    7274                'reader-one) )
     75
     76(newline)
     77(print "** Test mailbox **")
     78(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
     79(newline)
    7380
    7481(thread-start! writer-thread-one)
     
    113120                        (let ([mbc (make-mailbox-cursor mailbox-one)])
    114121                                (let loop ([msg (mailbox-cursor-next mbc)])
    115                                         (thread-labeled-print "Message: " msg)
     122                                        (thread-labeled-print "Message " msg)
    116123                                        (unless (eq? 'quit msg)
    117124                                                (when (and (even? (cdr msg)) (not (zero? (modulo (cdr msg) MESSAGE-LIMIT))))
    118                                                         (thread-labeled-print "Removing Message: " msg)
     125                                                        (thread-labeled-print "Removing Message " msg)
    119126                                                        (mailbox-cursor-extract-and-rewind! mbc) )
    120127                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
     
    127134                        (let ([mbc (make-mailbox-cursor mailbox-one)])
    128135                                (let loop ([msg (mailbox-cursor-next mbc)])
    129                                         (thread-labeled-print "Message: " msg)
     136                                        (thread-labeled-print "Message " msg)
    130137                                        (unless (eq? 'quit msg)
    131138                                                (when (odd? (cdr msg))
    132                                                         (thread-labeled-print "Removing Message: " msg)
     139                                                        (thread-labeled-print "Removing Message " msg)
    133140                                                        (mailbox-cursor-extract-and-rewind! mbc) )
    134141                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
    135142                'reader-two) )
     143
     144(newline)
     145(print "** Test mailbox-cursor **")
     146(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
     147(newline)
    136148
    137149(thread-start! writer-thread-one)
  • release/4/mailbox/trunk/mailbox.scm

    r13502 r13503  
    199199  scheme
    200200  (only chicken
    201     optional  ;due to #!optional implementation
     201    optional                ;due to #!optional implementation
     202    handle-exceptions       ;due to condition-case implementation
     203    let-optionals           ;due to let-values implementation
     204    with-exception-handler  ;due to condition-case  implementation
    202205    and-let* let-values
    203206    unless when
    204207    make-composite-condition make-property-condition condition-predicate
     208    condition-case
    205209    error signal
    206210    gensym
     
    215219
    216220(define (%queue-add! q datum)
    217   (let ([new-pair (%cons datum '())))
     221  (let ([new-pair (%cons datum '())])
    218222    (if (%null? (%queue-first-pair q))
    219223        (%queue-first-pair-set! q new-pair)
  • release/4/mailbox/trunk/mailbox.setup

    r13499 r13503  
    1 (include "setup-header")
     1;;;; mailbox.setup
    22
    3 (install-dynld+syntax mailbox mailbox-support *version*)
     3;;
    44
    5 (install-test "mailbox-test.scm")
     5(required-chicken-version 4.0)
     6
     7;;
     8
     9(define *version* (if (file-exists? "version") (string-chomp (read-all "version") "\n") "trunk"))
     10
     11;;
     12
     13(define (make-fn bn . en)
     14  (apply make-pathname #f (->string bn) en) )
     15
     16(define (doc-fn bn)
     17  (make-fn bn "html") )
     18
     19(define (source-fn bn)
     20  (make-fn bn "scm") )
     21
     22(define (shared-fn bn)
     23  (make-fn bn ##sys#load-dynamic-extension) )
     24
     25(define (static-fn bn)
     26  (make-fn bn "o") )
     27
     28(define (import-fn bn)
     29  (make-fn bn "import") )
     30
     31(define (source-import-fn bn)
     32  (source-fn (import-fn bn)) )
     33
     34(define (shared-import-fn bn)
     35  (shared-fn (import-fn bn)) )
     36
     37;;
     38
     39(define (compile-static-extension nam . args)
     40  (compile ,(source-fn nam)
     41    -optimize-level 2 -debug-level 1
     42    -c -unit ,nam -output-file ,(static-fn nam)
     43    ,@args) )
     44
     45(define (compile-shared-extension nam . args)
     46  (compile ,(source-fn nam)
     47    -optimize-level 2 -debug-level 1
     48    -shared -output-file ,(shared-fn nam)
     49    -emit-import-library ,nam
     50    ,@args)
     51  (compile ,(source-import-fn nam)
     52    -optimize-level 2 -debug-level 0
     53    -shared -output-file ,(shared-import-fn nam)) )
     54
     55;;
     56
     57(define (install-shared-extension nam #!key (compile '()) (install '()))
     58  (apply compile-shared-extension nam compile)
     59  (install-extension nam
     60   `(,(shared-fn nam) ,(shared-import-fn nam))
     61   `((version ,*version*)
     62     (documentation ,(doc-fn nam))
     63     ,@install)) )
     64
     65(define (install-shared-static-extension nam  #!key (compile '()) (install '()))
     66  (apply compile-shared-extension nam compile)
     67  (apply compile-static-extension nam compile)
     68  (install-extension nam
     69   `(,(shared-fn nam) ,(static-fn nam) ,(shared-import-fn nam))
     70   `((version ,*version*)
     71     (static ,(static-fn nam))
     72     (documentation ,(doc-fn nam))
     73     ,@install)) )
     74
     75;;;
     76
     77(install-shared-extension 'mailbox)
  • release/4/mailbox/trunk/tests/run.scm

    r13502 r13503  
    1414(define-constant MESSAGE-LIMIT 5)
    1515
    16 (define-constant TIMEOUT 0.5 #;0.25)
     16(define-constant TIMEOUT #;0.5 0.25)
    1717
    1818(define (current-thread-name)
     
    4545                        (thread-labeled-print "Started!")
    4646                        (let loop ([cnt 0])
    47                                 (thread-labeled-print "Sleep @ " (current-seconds))
    48                                 (thread-sleep! TIMEOUT)
    49                                 (thread-labeled-print "Awake @ " (current-seconds))
    50                                 (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
    51                                 (if (= MESSAGE-LIMIT cnt)
     47        (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
     48        (if (= MESSAGE-LIMIT cnt)
    5249            (mailbox-send! mailbox-one 'quit)
    53             (loop (add1 cnt))) ) )
     50            (let ([sleep@seconds (current-seconds)])
     51              (thread-labeled-print "Sleep at " sleep@seconds " sec")
     52              (thread-sleep! TIMEOUT)
     53              (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
     54              (loop (add1 cnt)) ) ) ) )
    5455                'writer-one) )
    5556
     
    5960                        (thread-labeled-print "Started!")
    6061                        (let loop ()
    61                                 (condition-case
    62                                                 (begin
    63                                                         (thread-labeled-print "Receiving @ " (current-seconds))
    64                                                         (let ([msg (mailbox-receive! mailbox-one 0.25 #;0.5)])
    65                                                                 (thread-labeled-print " Message: " msg)
    66                                                                 (unless (eq? 'quit msg) (loop) ) ) )
    67                                         [(exn mailbox timeout)
    68                                                 (thread-labeled-print "Timed Out @ " (current-seconds))
    69                                                 (loop)]
    70                                         [exp ()
    71                                                 (thread-labeled-print "Exception: " exp)]) ) )
     62                          (let ([receive@seconds (current-seconds)])
     63          (condition-case
     64              (begin
     65                (thread-labeled-print "Receiving at " receive@seconds  " sec")
     66                (let ([msg (mailbox-receive! mailbox-one TIMEOUT)])
     67                  (thread-labeled-print "Message " msg)
     68                  (unless (eq? 'quit msg) (loop) ) ) )
     69            [(exn mailbox timeout)
     70              (thread-labeled-print "Timedout after " (- (current-seconds) receive@seconds) " sec")
     71              (loop)]
     72            [exp ()
     73              (thread-labeled-print "Exception: " exp)]) ) ) )
    7274                'reader-one) )
     75
     76(newline)
     77(print "** Test mailbox **")
     78(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
     79(newline)
    7380
    7481(thread-start! writer-thread-one)
     
    113120                        (let ([mbc (make-mailbox-cursor mailbox-one)])
    114121                                (let loop ([msg (mailbox-cursor-next mbc)])
    115                                         (thread-labeled-print "Message: " msg)
     122                                        (thread-labeled-print "Message " msg)
    116123                                        (unless (eq? 'quit msg)
    117124                                                (when (and (even? (cdr msg)) (not (zero? (modulo (cdr msg) MESSAGE-LIMIT))))
    118                                                         (thread-labeled-print "Removing Message: " msg)
     125                                                        (thread-labeled-print "Removing Message " msg)
    119126                                                        (mailbox-cursor-extract-and-rewind! mbc) )
    120127                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
     
    127134                        (let ([mbc (make-mailbox-cursor mailbox-one)])
    128135                                (let loop ([msg (mailbox-cursor-next mbc)])
    129                                         (thread-labeled-print "Message: " msg)
     136                                        (thread-labeled-print "Message " msg)
    130137                                        (unless (eq? 'quit msg)
    131138                                                (when (odd? (cdr msg))
    132                                                         (thread-labeled-print "Removing Message: " msg)
     139                                                        (thread-labeled-print "Removing Message " msg)
    133140                                                        (mailbox-cursor-extract-and-rewind! mbc) )
    134141                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
    135142                'reader-two) )
     143
     144(newline)
     145(print "** Test mailbox-cursor **")
     146(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
     147(newline)
    136148
    137149(thread-start! writer-thread-one)
Note: See TracChangeset for help on using the changeset viewer.