Changeset 35026 in project


Ignore:
Timestamp:
01/16/18 05:21:08 (9 months ago)
Author:
kon
Message:

fix xtra eval

Location:
release/4/mailbox/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/trunk/mailbox.scm

    r34448 r35026  
    11;;;; mailbox.scm
     2;;;; Kon Lovett, Aug '17
    23;;;; Kon Lovett, Mar '09
    3 ;;;; Kon Lovett, Aug '17
    44;;;; From Chicken 3 "mailbox" by Felix & Kon
    55
     
    5353  mailbox-cursor-extract-and-rewind!)
    5454
    55 (import scheme)
    56 
    57 (import chicken)
    58 
    59 (import
     55(import scheme chicken)
     56
     57(use
    6058  (only ports with-output-to-port)
    6159  (only srfi-1 append! delete! list-copy last-pair)
     
    6462    thread-signal! thread-sleep!
    6563    thread-suspend! thread-resume!
    66     time?) )
    67 (require-library
    68   ports
    69   srfi-1 srfi-18)
    70 
    71 (import
     64    time?)
    7265  (only type-errors define-error-type error-list)
    7366  (only condition-utils make-exn-condition+ make-condition-predicate)
    7467  record-variants )
    75 (require-library
    76   type-errors condition-utils
    77   record-variants)
    7868
    7969;yes, yes, not a module form
     
    348338  (syntax-rules ()
    349339    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
    350       (let waiting ()
    351         (cond
    352           ((%mailbox-queue-empty? ?mb)
    353             (let ((res (wait-mailbox-thread! ?loc ?mb ?timout ?timout-value)))
    354               ;When a thread ready then check mailbox again, could be empty.
    355               (if ($eq? UNBLOCKED-TAG res)
    356                 (waiting)
    357                 ;else some sort of problem
    358                 res ) ) )
    359           (else
    360             ?expr0 ... ) ) ) ) ) )
     340      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
     341        (let waiting ()
     342          (cond
     343            ((%mailbox-queue-empty? _mb)
     344              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
     345                ;When a thread ready then check mailbox again, could be empty.
     346                (if ($eq? UNBLOCKED-TAG res)
     347                  (waiting)
     348                  ;else some sort of problem
     349                  res ) ) )
     350            (else
     351              ?expr0 ... ) ) ) ) ) ) )
    361352
    362353#; ;XXX
  • release/4/mailbox/trunk/mailbox.setup

    r34364 r35026  
    55(verify-extension-name 'mailbox)
    66
    7 (setup-shared-extension-module 'mailbox (extension-version "2.2.2")
     7(setup-shared-extension-module 'mailbox (extension-version "2.2.3")
    88  #:compile-options '(
    99    -scrutinize
  • release/4/mailbox/trunk/tests/mailbox-primordial-test.scm

    r34359 r35026  
    1313                           (thread-signal! primordial 'example))))
    1414
    15 ;; (used to - KRL) this hangs forever and eats all my cycles (with timeout)
     15#; ;; this hangs forever and eats all my cycles (with timeout)
    1616(handle-exceptions exn
    1717  (print "+ wait with timeout NOT OK for primordial thread: " (condition->list exn))
  • release/4/mailbox/trunk/tests/run.scm

    r34361 r35026  
    1 ;;;; mailbox tests/run.scm
    21
    3 ;(system "csc reader-writer-test.scm") (system "./reader-writer-test")
    4 (system "csi -n -s reader-writer-test.scm")
     2(define EGG-NAME "mailbox")
    53
    6 ;(system "csc mailbox-cursor-test.scm") (system "./mailbox-cursor-test")
    7 (system "csi -n -s mailbox-cursor-test.scm")
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    85
    9 #|
    10 (system "csc mailbox-primordial-test.scm")
    11 (cond-expand
    12   (unix
    13     (system "./mailbox-primordial-test") )
    14   (else
    15     (system "mailbox-primordial-test") ) )
    16 |#
     6(use files)
     7
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
     10
     11(define *args* (argv))
     12
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
     24
     25;;;
     26
     27(set! EGG-NAME (egg-name))
     28
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-tests '("reader-writer" "mailbox-cursor" "mailbox-primordial"))
Note: See TracChangeset for help on using the changeset viewer.