Changeset 34358 in project


Ignore:
Timestamp:
08/25/17 18:48:53 (3 months ago)
Author:
kon
Message:

re-flow, use typ chks as 1st arg

File:
1 edited

Legend:

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

    r34353 r34358  
    11;;;; mailbox.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, Aug '17
    34;;;; From Chicken 3 "mailbox" by Felix & Kon
    45
     
    2627(module mailbox
    2728
    28   (;export
    29     ;Mailbox Exception API
    30     mailbox-timeout-condition? mailbox-timeout-exception?
    31     ;Mailbox API
    32     make-mailbox
    33     mailbox?
    34     mailbox-name
    35     mailbox-empty?
    36     mailbox-count
    37     mailbox-waiting?
    38     mailbox-waiters
    39     mailbox-send!
    40     mailbox-wait!
    41     mailbox-receive!
    42     mailbox-push-back!
    43     mailbox-push-back-list!
    44     ;Mailbox Cursor API
    45     make-mailbox-cursor
    46     mailbox-cursor?
    47     mailbox-cursor-mailbox
    48     mailbox-cursor-next
    49     mailbox-cursor-rewind
    50     mailbox-cursor-rewound?
    51     mailbox-cursor-unwound?
    52     mailbox-cursor-extract-and-rewind!)
    53 
    54   (import
    55     scheme
    56     chicken
    57     (only ports with-output-to-port)
    58     (only srfi-1 append! delete! list-copy last-pair)
    59     (only srfi-18
    60       current-thread
    61       thread-signal! thread-sleep!
    62       thread-suspend! thread-resume!
    63       time?)
    64     (only type-errors define-error-type error-list)
    65     (only condition-utils make-exn-condition+ make-condition-predicate)
    66     record-variants)
    67 
    68   (require-library
    69     ports srfi-1 srfi-18
    70     type-errors condition-utils
    71     record-variants)
    72 
    73   (declare
    74     (disable-interrupts) ;A MUST!
    75     (always-bound ##sys#primordial-thread)
    76     (bound-to-procedure
    77       ##sys#signal-hook
    78       ##sys#thread-unblock!) )
     29(;export
     30  ;Mailbox Exception API
     31  mailbox-timeout-condition? mailbox-timeout-exception?
     32  ;Mailbox API
     33  make-mailbox
     34  mailbox?
     35  mailbox-name
     36  mailbox-empty?
     37  mailbox-count
     38  mailbox-waiting?
     39  mailbox-waiters
     40  mailbox-send!
     41  mailbox-wait!
     42  mailbox-receive!
     43  mailbox-push-back!
     44  mailbox-push-back-list!
     45  ;Mailbox Cursor API
     46  make-mailbox-cursor
     47  mailbox-cursor?
     48  mailbox-cursor-mailbox
     49  mailbox-cursor-next
     50  mailbox-cursor-rewind
     51  mailbox-cursor-rewound?
     52  mailbox-cursor-unwound?
     53  mailbox-cursor-extract-and-rewind!)
     54
     55(import scheme)
     56
     57(import chicken)
     58
     59(import
     60  (only ports with-output-to-port)
     61  (only srfi-1 append! delete! list-copy last-pair)
     62  (only srfi-18
     63    current-thread
     64    thread-signal! thread-sleep!
     65    thread-suspend! thread-resume!
     66    time?) )
     67(require-library
     68  ports
     69  srfi-1 srfi-18)
     70
     71(import
     72  (only type-errors define-error-type error-list)
     73  (only condition-utils make-exn-condition+ make-condition-predicate)
     74  record-variants )
     75(require-library
     76  type-errors condition-utils
     77  record-variants)
     78
     79;yes, yes, not a module form
     80(declare
     81  (disable-interrupts) ;A MUST!
     82  (always-bound ##sys#primordial-thread)
     83  (bound-to-procedure
     84    ##sys#signal-hook
     85    ##sys#thread-unblock!) )
    7986
    8087;;; Primitives
    8188
    82   (include "chicken-primitive-object-inlines")
    83   (include "chicken-thread-object-inlines")
    84   (include "inline-type-checks")
    85   (include "inline-queue")
     89(include "chicken-primitive-object-inlines")
     90(include "chicken-thread-object-inlines")
     91(include "inline-type-checks")
     92(include "inline-queue")
    8693
    8794(define-inline (->boolean obj) (and obj #t))
     
    104111    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
    105112    (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
    106     (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...))))
    107     )
     113    (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...)))) )
    108114  (else
    109115    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
     
    122128    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
    123129    (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
    124     (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
    125     ) )
     130    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
    126131
    127132;;; Mailbox Support
     
    318323
    319324(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
     325
     326;DEPRECATE
    320327(define mailbox-timeout-exception? mailbox-timeout-condition?)
    321328
     
    325332  (%make-mailbox nm) )
    326333
    327 (define (mailbox? obj) (%mailbox? obj))
     334(define (mailbox? obj)
     335  (%mailbox? obj) )
    328336
    329337;; Mailbox Properties
    330338
    331339(define (mailbox-name mb)
    332   (%check-mailbox 'mailbox-name mb)
    333   (%mailbox-name mb) )
     340  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
    334341
    335342(define (mailbox-empty? mb)
    336   (%check-mailbox 'mailbox-empty? mb)
    337   (%mailbox-queue-empty? mb) )
     343  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    338344
    339345(define (mailbox-count mb)
    340   (%check-mailbox 'mailbox-count mb)
    341   (%mailbox-queue-count mb) )
     346  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
    342347
    343348(define (mailbox-waiting? mb)
    344   (%check-mailbox 'mailbox-waiting? mb)
    345   (not ($null? (%mailbox-waiters mb))) )
     349  (not
     350    ($null?
     351      (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
    346352
    347353(define (mailbox-waiters mb)
    348   (%check-mailbox 'mailbox-waiters mb)
    349   ($list-copy (%mailbox-waiters mb)) )
     354  ($list-copy
     355    (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
    350356
    351357;; Mailbox Operations
    352358
    353359(define (mailbox-send! mb x)
    354   (%check-mailbox 'mailbox-send! mb)
    355   (%mailbox-queue-add! mb x)
     360  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
    356361  (ready-mailbox-thread! mb) )
    357362
    358363(define (mailbox-wait! mb #!optional timout)
    359   (%check-mailbox 'mailbox-wait! mb)
    360364  (when timout (%check-timeout 'mailbox-wait! timout))
    361   (on-mailbox-available 'mailbox-wait! mb timout NO-TOVAL-TAG
     365  (on-mailbox-available 'mailbox-wait!
     366    (%check-mailbox 'mailbox-wait! mb)
     367    timout NO-TOVAL-TAG
    362368    (void) ) )
    363369
    364370(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
    365   (%check-mailbox 'mailbox-receive! mb)
    366371  (when timout (%check-timeout 'mailbox-receive! timout))
    367   (on-mailbox-available 'mailbox-receive! mb timout timout-value
     372  (on-mailbox-available 'mailbox-receive!
     373    (%check-mailbox 'mailbox-receive! mb)
     374    timout timout-value
    368375    (%mailbox-queue-remove! mb) ) )
    369376
    370377(define (mailbox-push-back! mb x)
    371   (%check-mailbox 'mailbox-send! mb)
    372   (%mailbox-queue-push-back! mb x)
     378  (%mailbox-queue-push-back!
     379    (%check-mailbox 'mailbox-send! mb) x)
    373380  (ready-mailbox-thread! mb) )
    374381
    375382(define (mailbox-push-back-list! mb ls)
    376   (%check-mailbox 'mailbox-send! mb)
    377   (%check-list ls 'mailbox-send!)
    378   (%mailbox-queue-push-back-list! mb ls)
     383  (%mailbox-queue-push-back-list!
     384    (%check-mailbox 'mailbox-send! mb)
     385    (%check-list ls 'mailbox-send!))
    379386  (ready-mailbox-thread! mb) )
    380387
     
    384391
    385392(define (make-mailbox-cursor mb)
    386   (%check-mailbox 'make-mailbox-cursor mb)
    387   (%make-mailbox-cursor mb) )
     393  (%make-mailbox-cursor
     394    (%check-mailbox 'make-mailbox-cursor mb)) )
    388395
    389396;; Mailbox Cursor Properties
     
    393400
    394401(define (mailbox-cursor-mailbox mbc)
    395   (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
    396   (%mailbox-cursor-mailbox mbc) )
     402  (%mailbox-cursor-mailbox
     403    (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
    397404
    398405(define (mailbox-cursor-rewound? mbc)
    399   (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
    400   (not (%mailbox-cursor-winding? mbc)) )
     406  (not
     407    (%mailbox-cursor-winding?
     408      (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
    401409
    402410(define (mailbox-cursor-unwound? mbc)
    403   (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)
    404   ($null? (%mailbox-cursor-next-pair mbc)) )
     411  ($null?
     412    (%mailbox-cursor-next-pair
     413      (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
    405414
    406415;; Mailbox Cursor Operations
    407416
    408417(define (mailbox-cursor-rewind mbc)
    409   (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
    410   (%mailbox-cursor-rewind! mbc) )
     418  (%mailbox-cursor-rewind!
     419    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
    411420
    412421#; ;XXX
     
    436445            (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
    437446              (cond
    438                 ((or ($eq? MESSAGE-WAITING-TAG res) ;so continue scanning
     447                ;continue scanning?
     448                ((or ($eq? MESSAGE-WAITING-TAG res)
    439449                     ($eq? UNBLOCKED-TAG res))
    440450                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    441451                  (scanning) )
    442                 (else                               ;otherwise timed-out
     452                ;otherwise timed-out
     453                (else
    443454                  res ) ) ) ) ) ) ) ) )
    444455
    445456(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    446   (%check-mailbox-cursor 'mailbox-cursor-next mbc)
    447457  (when timout (%check-timeout 'mailbox-cursor-next timout))
    448   (let ((mb (%mailbox-cursor-mailbox mbc)))
     458  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
    449459    ;Seed rewound cursor
    450460    (unless (%mailbox-cursor-winding? mbc)
     
    463473          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
    464474            (cond
    465               (($eq? UNBLOCKED-TAG res) ;so continue scanning
     475              ;continue scanning?
     476              (($eq? UNBLOCKED-TAG res)
    466477                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
    467478                (scanning) )
    468               (else                     ;some problem (timeout maybe)
     479              ;some problem (timeout maybe)
     480              (else
    469481                res ) ) ) ) ) ) ) )
    470482
    471483(define (mailbox-cursor-extract-and-rewind! mbc)
    472   (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
    473   (%mailbox-cursor-extract! mbc)
     484  (%mailbox-cursor-extract!
     485    (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
    474486  (%mailbox-cursor-rewind! mbc) )
    475487
Note: See TracChangeset for help on using the changeset viewer.