Changeset 35353 in project


Ignore:
Timestamp:
03/26/18 19:33:05 (9 months ago)
Author:
kon
Message:

add types, add static build, use format

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

Legend:

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

    r35026 r35353  
    5757(use
    5858  (only ports with-output-to-port)
    59   (only srfi-1 append! delete! list-copy last-pair)
     59  (only extras format)
     60  (only srfi-1
     61    append! delete! list-copy last-pair)
    6062  (only srfi-18
    6163    current-thread
     
    120122;;; Support
    121123
     124(define-type srfi-18-time (struct time))
     125
    122126(define-inline (->boolean obj)
    123127  (and obj #t) )
     
    126130
    127131;; Mailbox
     132
     133(define-type mailbox (struct mailbox))
    128134
    129135(define-record-type-variant mailbox (unsafe unchecked inline)
     
    187193;;; Mailbox Cursor Support
    188194
     195(define-type mailbox-cursor (struct mailbox-cursor))
     196
    189197(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    190198  (%%make-mailbox-cursor np pp mb)
     
    220228;; Time Support
    221229
     230(define-type timeout (or number srfi-18-time))
     231
    222232(define-inline (%timeout? obj)
    223233  (or (number? obj) (time? obj)) )
     
    227237
    228238;;;
     239
     240(define-type unique-object vector)
    229241
    230242;Unique objects used as tags
     
    277289            ;Propagate any "real" exception.
    278290            (signal exp) ) )
    279         (lambda () (thread-sleep! tim) #t) ) ) ) )
     291        (lambda ()
     292          (thread-sleep! tim) #t) ) ) ) )
    280293
    281294;; Wait current thread on the mailbox until timeout, available message
     
    283296
    284297(define (wait-mailbox-thread! loc mb timout timout-value)
     298  ;
    285299  ;no available message due to timeout
    286300  (define (timeout-exit!)
     
    292306          (make-mailbox-timeout-condition loc mb timout timout-value))
    293307        SEQ-FAIL-TAG ) ) )
     308  ;
    294309  ;Push current thread on mailbox waiting queue
    295310  (%mailbox-waiters-add! mb ($current-thread))
     
    300315      (cond-expand
    301316        (sleep-primordial-thread
     317          ;
    302318          (cond
    303319            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
     
    311327              UNBLOCKED-TAG ) ) )
    312328        (else
     329          ;
    313330          (if (eq? ($current-thread) ##sys#primordial-thread)
    314331            (begin
     
    360377;; Mailbox Exceptions
    361378
    362 (define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
    363 
    364 ;DEPRECATE
     379(: mailbox-timeout-condition? (* -> boolean : condition))
     380;
     381(define mailbox-timeout-condition?
     382  (make-condition-predicate exn mailbox timeout))
     383
     384(: mailbox-timeout-exception? (deprecated mailbox-timeout-condition?))
     385;
    365386(define mailbox-timeout-exception? mailbox-timeout-condition?)
    366387
    367388;; Mailbox Constructor
    368389
     390(: make-mailbox (#!optional symbol --> mailbox))
     391;
    369392(define (make-mailbox #!optional (nm (gensym 'mailbox)))
    370393  (%make-mailbox nm) )
    371394
     395(: mailbox? (* -> boolean : mailbox))
     396;
    372397(define (mailbox? obj)
    373398  (%mailbox? obj) )
     
    375400;; Mailbox Properties
    376401
     402(: mailbox-name (mailbox --> symbol))
     403;
    377404(define (mailbox-name mb)
    378405  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
    379406
     407(: mailbox-empty? (mailbox --> boolean))
     408;
    380409(define (mailbox-empty? mb)
    381410  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    382411
     412(: mailbox-count (mailbox --> fixnum))
     413;
    383414(define (mailbox-count mb)
    384415  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
    385416
     417(: mailbox-waiting? (mailbox --> boolean))
     418;
    386419(define (mailbox-waiting? mb)
    387420  (not
     
    389422      (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
    390423
     424(: mailbox-waiters (mailbox --> list))
     425;
    391426(define (mailbox-waiters mb)
    392427  ($list-copy
     
    395430;; Mailbox Operations
    396431
     432(: mailbox-send! (mailbox * -> void))
     433;
    397434(define (mailbox-send! mb x)
    398435  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
    399436  (ready-mailbox-thread! mb) )
    400437
     438(: mailbox-wait! (mailbox #!optional timeout -> void))
     439;
    401440(define (mailbox-wait! mb #!optional timout)
    402441  (when timout (%check-timeout 'mailbox-wait! timout))
     
    406445    (void) ) )
    407446
     447(: mailbox-receive! (mailbox #!optional timeout * -> *))
     448;
    408449(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
    409450  (when timout (%check-timeout 'mailbox-receive! timout))
     
    413454    (%mailbox-queue-remove! mb) ) )
    414455
     456(: mailbox-push-back! (mailbox * -> void))
     457;
    415458(define (mailbox-push-back! mb x)
    416459  (%mailbox-queue-push-back!
     
    418461  (ready-mailbox-thread! mb) )
    419462
     463(: mailbox-push-back-list! (mailbox list -> void))
     464;
    420465(define (mailbox-push-back-list! mb ls)
    421466  (%mailbox-queue-push-back-list!
     
    428473;; Mailbox Cursor Constructor
    429474
     475(: make-mailbox-cursor (mailbox --> mailbox-cursor))
     476;
    430477(define (make-mailbox-cursor mb)
    431478  (%make-mailbox-cursor
     
    434481;; Mailbox Cursor Properties
    435482
     483(: mailbox-cursor? (* -> boolean : mailbox-cursor))
     484;
    436485(define (mailbox-cursor? obj)
    437486  (%mailbox-cursor? obj) )
    438487
     488(: mailbox-cursor-mailbox (mailbox-cursor --> mailbox))
     489;
    439490(define (mailbox-cursor-mailbox mbc)
    440491  (%mailbox-cursor-mailbox
    441492    (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
    442493
     494(: mailbox-cursor-rewound? (mailbox-cursor --> boolean))
     495;
    443496(define (mailbox-cursor-rewound? mbc)
    444497  (not
     
    446499      (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
    447500
     501(: mailbox-cursor-unwound? (mailbox-cursor --> boolean))
     502;
    448503(define (mailbox-cursor-unwound? mbc)
    449504  ($null?
     
    453508;; Mailbox Cursor Operations
    454509
     510(: mailbox-cursor-rewind (mailbox-cursor -> void))
     511;
    455512(define (mailbox-cursor-rewind mbc)
    456513  (%mailbox-cursor-rewind!
     
    492549                  res ) ) ) ) ) ) ) ) )
    493550
     551(: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
     552;
    494553(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    495554  (when timout (%check-timeout 'mailbox-cursor-next timout))
     
    519578                res ) ) ) ) ) ) ) )
    520579
     580(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
     581;
    521582(define (mailbox-cursor-extract-and-rewind! mbc)
    522583  (%mailbox-cursor-extract!
     
    529590  (with-output-to-port out
    530591    (lambda ()
    531       (display "#<mailbox")
    532       (display #\space) (display (%mailbox-name mb))
    533       (display " queued = ") (display (%mailbox-queue-count mb))
    534       (display " waiters = ") (display (%mailbox-waiters-count mb))
    535       (display ">") ) ) )
     592      (format #t "#<mailbox ~A queued: ~A waiters: ~A>"
     593        (%mailbox-name mb)
     594        (%mailbox-queue-count mb)
     595        (%mailbox-waiters-count mb)) ) ) )
    536596
    537597(define-record-printer (mailbox-cursor mbc out)
    538598  (with-output-to-port out
    539599    (lambda ()
    540       (display "#<mailbox-cursor")
    541       (display " mailbox = ") (display (%mailbox-name (%mailbox-cursor-mailbox mbc)))
    542       (display " status = ") (display (if (%mailbox-cursor-winding? mbc) "winding" "rewound"))
    543       (display ">") ) ) )
     600      (format #t "#<mailbox-cursor mailbox: ~A status: ~A>"
     601      (%mailbox-name (%mailbox-cursor-mailbox mbc))
     602      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
    544603
    545604) ;module mailbox
  • release/4/mailbox/trunk/mailbox.setup

    r35026 r35353  
    55(verify-extension-name 'mailbox)
    66
    7 (setup-shared-extension-module 'mailbox (extension-version "2.2.3")
     7(setup-shared+static-extension-module 'mailbox (extension-version "2.3.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -scrutinize
Note: See TracChangeset for help on using the changeset viewer.