Changeset 36707 in project


Ignore:
Timestamp:
10/21/18 19:21:17 (3 weeks ago)
Author:
kon
Message:

more sugar, very little is pure, stronger type where possible, commentary

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

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/trunk/mailbox.egg

    r36583 r36707  
    44((synopsis "Thread-safe queues with timeout")
    55 (category hell)
    6  (version "3.3.1)
     6 (version "3.3.1")
    77 (author "[[felix winkelman]] and [[kon lovett]]")
    88 (license "BSD")
  • release/5/mailbox/trunk/mailbox.scm

    r36583 r36707  
    7575
    7676;;; Support
     77
     78;;miscmacros, Felix Winkelmann
     79
     80;; evaluates body with an explicit exit continuation
     81;;
     82  (define-syntax let/cc
     83    (syntax-rules ()
     84      ((let/cc k e0 e1 ...)
     85       (call-with-current-continuation
     86        (lambda (k) e0 e1 ...)))))
    7787
    7888;;record-variants, Jim Ursett
     
    167177(define-inline (->boolean obj) (and obj #t))
    168178
    169 ;;;(only type-errors define-error-type)
     179;;(only type-errors define-error-type)
    170180
    171181;;
     
    355365;;;
    356366
    357 (define-type unique-object vector)
     367(define-type unique-object (vector-of symbol))
    358368
    359369;Unique objects used as tags
     
    366376;;; Mailbox Exceptions
    367377
     378(define-inline (optional-timeout-value x #!optional (def (void)))
     379  (if ($eq? x NO-TOVAL-TAG) def x) )
     380
    368381(define (make-mailbox-timeout-condition loc mb timout timout-value)
    369   (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
     382  (let ((tv (optional-timeout-value timout-value)))
    370383    (make-composite-condition
    371384      (make-property-condition 'exn
     
    380393;; Select next waiting thread for the mailbox
    381394
     395(define-inline (%mailbox-waiters-pop!? mb)
     396  (and (not (%mailbox-waiters-empty? mb)) (%mailbox-waiters-pop! mb)) )
     397
    382398(define (ready-mailbox-thread! mb)
    383399  ;ready oldest waiting thread
    384   (unless (%mailbox-waiters-empty? mb)
    385     (let ((thread (%mailbox-waiters-pop! mb)))
    386       ;ready the thread based on wait mode
    387       (if (not ($thread-blocked? thread))
    388         (thread-resume! thread)
    389         ;else wake early if sleeping
    390         (when ($thread-blocked-for-timeout? thread)
    391           ;ready the thread
    392           (##sys#thread-unblock! thread)
    393           ;tell 'wait-mailbox-thread!' we unblocked early
    394           (thread-signal! thread UNBLOCKED-TAG) ) ) )
    395     (void) ) )
     400  (and-let* ((th (%mailbox-waiters-pop!? mb)))
     401    ;ready the thread based on wait mode
     402    (if (not ($thread-blocked? th))
     403      ;then restart
     404      (thread-resume! th)
     405      ;else wake early if sleeping
     406      ;all others dropped on the floor
     407      (when ($thread-blocked-for-timeout? th)
     408        ;ready the thread
     409        (##sys#thread-unblock! th)
     410        ;tell 'wait-mailbox-thread!' we unblocked early
     411        (thread-signal! th UNBLOCKED-TAG) ) ) )
     412    (void) )
    396413
    397414;; Sleep current thread until timeout, known condition,
     
    401418;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
    402419  ;sleep current thread for desired seconds, unless unblocked "early".
    403   (call/cc
    404     (lambda (return)
    405       (with-exception-handler
    406         (lambda (exp)
    407           (if ($eq? unblocked-tag exp)
    408             (return #f)
    409             ;propagate any "real" exception.
    410             (signal exp) ) )
    411         (lambda ()
    412           (thread-sleep! tim) #t) ) ) ) )
     420  (let/cc return
     421    (with-exception-handler
     422      (lambda (exp)
     423        (if ($eq? unblocked-tag exp)
     424          (return #f)
     425          ;propagate any "real" exception.
     426          (signal exp) ) )
     427      (lambda ()
     428        (thread-sleep! tim) #t) ) ) )
    413429
    414430;; Wait current thread on the mailbox until timeout, available message
     
    507523;; Mailbox Constructor
    508524
    509 (: make-mailbox (#!optional * --> mailbox))
     525(: make-mailbox (#!optional * -> mailbox))
    510526;
    511527(define (make-mailbox #!optional (nm (gensym 'mailbox)))
     
    524540  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
    525541
    526 (: mailbox-empty? (mailbox --> boolean))
     542(: mailbox-empty? (mailbox -> boolean))
    527543;
    528544(define (mailbox-empty? mb)
    529545  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    530546
    531 (: mailbox-count (mailbox --> fixnum))
     547(: mailbox-count (mailbox -> fixnum))
    532548;
    533549(define (mailbox-count mb)
    534550  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
    535551
    536 (: mailbox-waiting? (mailbox --> boolean))
     552(: mailbox-waiting? (mailbox -> boolean))
    537553;
    538554(define (mailbox-waiting? mb)
    539555  (not ($null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
    540556
    541 (: mailbox-waiters (mailbox --> list))
     557(: mailbox-waiters (mailbox -> list))
    542558;
    543559(define (mailbox-waiters mb)
     
    588604;; Mailbox Cursor Constructor
    589605
    590 (: make-mailbox-cursor (mailbox --> mailbox-cursor))
     606(: make-mailbox-cursor (mailbox -> mailbox-cursor))
    591607;
    592608(define (make-mailbox-cursor mb)
     
    605621  (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
    606622
    607 (: mailbox-cursor-rewound? (mailbox-cursor --> boolean))
     623(: mailbox-cursor-rewound? (mailbox-cursor -> boolean))
    608624;
    609625(define (mailbox-cursor-rewound? mbc)
    610626  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
    611627
    612 (: mailbox-cursor-unwound? (mailbox-cursor --> boolean))
     628(: mailbox-cursor-unwound? (mailbox-cursor -> boolean))
    613629;
    614630(define (mailbox-cursor-unwound? mbc)
Note: See TracChangeset for help on using the changeset viewer.