Changeset 13721 in project


Ignore:
Timestamp:
03/12/09 19:23:09 (11 years ago)
Author:
Kon Lovett
Message:

Fixed paren probs.

Location:
release/4/mailbox
Files:
2 edited

Legend:

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

    r13691 r13721  
    77;;
    88;; - Uses ##sys#current-thread & ##sys#thread-unblock!
     9;;
     10;; - Has knowledge of Unit srfi-18 time object internals.
     11
     12;;; Prelude
    913
    1014(declare
     
    1620  (no-procedure-checks)
    1721  (bound-to-procedure
    18     ##sys#check-structure
    19     ##sys#check-list
    20     ##sys#check-symbol
    2122    ##sys#signal-hook
    2223    ##sys#thread-unblock!)
     
    2425    ##sys#current-thread) )
    2526
    26 
    27 ;;;
     27;;
    2828
    2929(include "chicken-primitive-object-inlines")
    3030(include "chicken-thread-object-inlines")
    3131
    32 (require-library ports srfi-18)
    33 
    34 
    35 ;;; Queue Support
    36 
    37 (define-inline (%make-queue)
    38   (%make-structure 'queue '() '()))
    39 
    40 (define-inline (%queue? obj)
    41   (%structure-instance? obj 'queue) )
    42 
    43 (define-inline (%queue-first-pair q)
    44   (%structure-ref q 1) )
    45 
    46 (define-inline (%queue-last-pair q)
    47   (%structure-ref q 2) )
     32;; Queue Support
     33
     34(define-inline (%make-queue) (%make-structure 'queue '() '()))
     35
     36(define-inline (%queue? obj) (%structure-instance? obj 'queue))
     37
     38(define-inline (%queue-first-pair q) (%structure-ref q 1))
     39
     40(define-inline (%queue-last-pair q) (%structure-ref q 2))
    4841
    4942(define-inline (%queue-valid? obj)
    5043  (and #;(%queue? obj) (%fx= 3 (%structure-length obj))
    51        (%list? (%queue-first-pair q))
    52        (%list? (%queue-last-pair q)) ) )
    53 
    54 (define-inline (%queue-empty? q)
    55   (%null? (%queue-first-pair q)) )
    56 
    57 (define-inline (%queue-count q)
    58   (%length (%queue-first-pair q)) )
    59 
    60 (define-inline (%queue-first-pair-set! q v)
    61   (%structure-set!/mutate  q 1 v) )
    62 
    63 (define-inline (%queue-last-pair-set! q v)
    64   (%structure-set!/mutate q 2 v) )
     44       (%list? (%queue-first-pair obj))
     45       (%list? (%queue-last-pair obj)) ) )
     46
     47(define-inline (%queue-empty? q) (%null? (%queue-first-pair q)))
     48
     49(define-inline (%queue-count q) (%length (%queue-first-pair q)))
     50
     51(define-inline (%queue-first-pair-set! q v) (%structure-set!/mutate  q 1 v))
     52
     53(define-inline (%queue-last-pair-set! q v) (%structure-set!/mutate q 2 v))
    6554
    6655;; Queue Operations
    6756
    68 (define-inline (%queue-last-pair-empty! q)
    69   (%structure-set!/immediate q 2 '()) )
     57(define-inline (%queue-last-pair-empty! q) (%structure-set!/immediate q 2 '()))
    7058
    7159(define-inline (%queue-add! q datum)
     
    10896        (scanning (%cdr this-pair) this-pair) ) ) )
    10997
    110 
    111 ;;; Mailbox Support
    112 
    113 (define-inline (%make-mailbox nm)
    114   (%make-structure 'mailbox nm (%make-queue) '()) )
    115 
    116 (define-inline (%mailbox? obj)
    117   (%structure-instance? obj 'mailbox) )
    118 
    119 (define-inline (%mailbox-name mb)
    120   (%structure-ref mb 1) )
     98;; Mailbox Support
     99
     100(define-inline (%make-mailbox nm) (%make-structure 'mailbox nm (%make-queue) '()))
     101
     102(define-inline (%mailbox? obj) (%structure-instance? obj 'mailbox))
     103
     104(define-inline (%mailbox-name mb) (%structure-ref mb 1))
    121105
    122106;; Message queue
    123107
    124 (define-inline (%mailbox-queue mb)
    125   (%structure-ref mb 2) )
    126 
    127 (define-inline (%mailbox-queue-first-pair mb)
    128   (%queue-first-pair (%mailbox-queue mb)) )
    129 
    130 (define-inline (%mailbox-queue-last-pair mb)
    131   (%queue-last-pair (%mailbox-queue mb)) )
    132 
    133 (define-inline (%mailbox-queue-empty? mb)
    134   (%queue-empty? (%mailbox-queue mb)) )
    135 
    136 (define-inline (%mailbox-queue-count mb)
    137   (%queue-count (%mailbox-queue mb)) )
    138 
    139 (define-inline (%mailbox-queue-add! mb x)
    140   (%queue-add! (%mailbox-queue mb) x) )
    141 
    142 (define-inline (%mailbox-queue-remove! mb)
    143   (%queue-remove! (%mailbox-queue mb)) )
    144 
    145 (define-inline (%mailbox-queue-push-back! mb x)
    146   (%queue-push-back! (%mailbox-queue mb) x) )
    147 
    148 (define-inline (%mailbox-queue-push-back-list! mb ls)
    149   (%queue-push-back-list! (%mailbox-queue mb) ls) )
     108(define-inline (%mailbox-queue mb) (%structure-ref mb 2))
     109
     110(define-inline (%mailbox-queue-first-pair mb) (%queue-first-pair (%mailbox-queue mb)))
     111
     112(define-inline (%mailbox-queue-last-pair mb) (%queue-last-pair (%mailbox-queue mb)))
     113
     114(define-inline (%mailbox-queue-empty? mb) (%queue-empty? (%mailbox-queue mb)))
     115
     116(define-inline (%mailbox-queue-count mb) (%queue-count (%mailbox-queue mb)))
     117
     118(define-inline (%mailbox-queue-add! mb x) (%queue-add! (%mailbox-queue mb) x))
     119
     120(define-inline (%mailbox-queue-remove! mb) (%queue-remove! (%mailbox-queue mb)))
     121
     122(define-inline (%mailbox-queue-push-back! mb x) (%queue-push-back! (%mailbox-queue mb) x))
     123
     124(define-inline (%mailbox-queue-push-back-list! mb ls) (%queue-push-back-list! (%mailbox-queue mb) ls))
    150125
    151126;; Waiting threads
    152127
    153 (define-inline (%mailbox-waiters mb)
    154   (%structure-ref mb 3) )
    155 
    156 (define-inline (%mailbox-waiters-empty? mb)
    157   (%null? (%mailbox-waiters mb)) )
    158 
    159 (define-inline (%mailbox-waiters-count mb)
    160   (%length (%mailbox-waiters mb)) )
    161 
    162 (define-inline (%mailbox-waiters-set! mb v)
    163   (%structure-set!/mutate  mb 3 v) )
     128(define-inline (%mailbox-waiters mb) (%structure-ref mb 3))
     129
     130(define-inline (%mailbox-waiters-empty? mb) (%null? (%mailbox-waiters mb)))
     131
     132(define-inline (%mailbox-waiters-count mb) (%length (%mailbox-waiters mb)))
     133
     134(define-inline (%mailbox-waiters-set! mb v) (%structure-set!/mutate  mb 3 v))
    164135
    165136(define-inline (%mailbox-waiters-add! mb th)
     
    178149(define-inline (%mailbox-valid? obj)
    179150  (and #;(%mailbox? obj) (%fx= 4 (%structure-length obj))
    180        (%queue-valid? (%mailbox-queue mb))
    181        (%list (%mailbox-waiters mb)) ) )
    182 
    183 
    184 ;;; Mailbox Cursor Support
    185 
    186 (define-inline (%make-mailbox-cursor mb)
    187   (%make-structure 'mailbox-cursor '() #f mb) )
    188 
    189 (define-inline (%mailbox-cursor? obj)
    190   (%structure-instance? obj 'mailbox-cursor) )
    191 
    192 (define-inline (%mailbox-cursor-next-pair mbc)
    193   (%structure-ref mbc 1) )
    194 
    195 (define-inline (%mailbox-cursor-prev-pair mbc)
    196   (%structure-ref mbc 2) )
    197 
    198 (define-inline (%mailbox-cursor-mailbox mbc)
    199   (%structure-ref mbc 3) )
     151       (%queue-valid? (%mailbox-queue obj))
     152       (%list? (%mailbox-waiters obj)) ) )
     153
     154;; Mailbox Cursor Support
     155
     156(define-inline (%make-mailbox-cursor mb) (%make-structure 'mailbox-cursor '() #f mb))
     157
     158(define-inline (%mailbox-cursor? obj) (%structure-instance? obj 'mailbox-cursor))
     159
     160(define-inline (%mailbox-cursor-next-pair mbc) (%structure-ref mbc 1))
     161
     162(define-inline (%mailbox-cursor-prev-pair mbc) (%structure-ref mbc 2))
     163
     164(define-inline (%mailbox-cursor-mailbox mbc) (%structure-ref mbc 3))
    200165
    201166(define-inline (%mailbox-cursor-valid? obj)
    202167  (and #;(%mailbox-cursor? obj) (%fx= 4 (%structure-length obj))
    203        (%mailbox-valid? (%mailbox-cursor-mailbox mbc))
    204        (%list? (%mailbox-cursor-next-pair mbc))
    205        (let ((pp (%mailbox-cursor-prev-pair mbc)))
     168       (%mailbox-valid? (%mailbox-cursor-mailbox obj))
     169       (%list? (%mailbox-cursor-next-pair obj))
     170       (let ((pp (%mailbox-cursor-prev-pair obj)))
    206171         (or (not pp) (%list? pp) ) ) ) )
    207172
    208 (define-inline (%mailbox-cursor-winding? mbc)
    209   (and (%mailbox-cursor-prev-pair mbc)
    210        #t) )
    211 
    212 (define-inline (%mailbox-cursor-next-pair-set! mbc v)
    213   (%structure-set!/mutate  mbc 1 v) )
    214 
    215 (define-inline (%mailbox-cursor-next-pair-empty! mbc)
    216   (%structure-set!/immediate mbc 1 '()) )
    217 
    218 (define-inline (%mailbox-cursor-prev-pair-set! mbc v)
    219   (%structure-set!/mutate  mbc 2 v) )
    220 
    221 (define-inline (%mailbox-cursor-prev-pair-clear! mbc)
    222   (%structure-set!/immediate mbc 2 #f) )
     173(define-inline (%mailbox-cursor-winding? mbc) (%->boolean (%mailbox-cursor-prev-pair mbc)))
     174
     175(define-inline (%mailbox-cursor-next-pair-set! mbc v) (%structure-set!/mutate  mbc 1 v))
     176
     177(define-inline (%mailbox-cursor-next-pair-empty! mbc) (%structure-set!/immediate mbc 1 '()))
     178
     179(define-inline (%mailbox-cursor-prev-pair-set! mbc v) (%structure-set!/mutate  mbc 2 v))
     180
     181(define-inline (%mailbox-cursor-prev-pair-clear! mbc) (%structure-set!/immediate mbc 2 #f))
    223182
    224183(define-inline (%mailbox-cursor-rewind! mbc)
     
    231190    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
    232191
    233 
    234 ;;; Time Support
    235 
    236 (define-inline (%time? obj)
    237   (%structure-instance? obj 'time) )
     192;; Time Support
     193
     194(define-inline (%time? obj) (%structure-instance? obj 'time))
    238195
    239196(define-inline (%time-valid? obj)
     
    243200       (%fixnum? (%structure-ref obj 3)) ) )
    244201
    245 (define-inline (%timeout? obj)
    246   (or (%time? obj) (%number? obj)) )
    247 
    248 
    249 ;;; Unique Object Support
    250 
    251 (define-inline (%make-unique-object #!optional ident)
    252   (if ident (%make-vector 1 ident)
    253       '#() ) )
    254 
    255 
    256 ;;; Argument Checking
    257 
    258 (define-inline (%error-type-mailbox loc obj)
    259   (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mailbox") obj) )
    260 
    261 (define-inline (%error-type-mailbox-cursor loc obj)
    262   (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mailbox-cursor") obj) )
    263 
    264 (define-inline (%error-type-timeout loc obj)
    265   (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a timeout object") obj) )
    266 
    267 (define-inline (%error-corrupted-mailbox loc obj)
    268   (##sys#signal-hook #:type-error loc (##core#immutable '"mailbox corrupted") obj) )
    269 
    270 (define-inline (%error-corrupted-mailbox-cursor loc obj)
    271   (##sys#signal-hook #:type-error loc (##core#immutable '"mailbox-cursor corrupted") obj) )
    272 
    273 (define-inline (%error-corrupted-time loc obj)
    274   (##sys#signal-hook #:type-error loc (##core#immutable '"time corrupted") obj) )
     202(define-inline (%timeout? obj) (or (%number? obj) (%time? obj)))
     203
     204;; Argument Checking
     205
     206(define-inline (%check-symbol loc obj) (unless (%symbol? obj) (error-type-symbol loc obj)))
     207
     208(define-inline (%check-list loc obj) (unless (%list? obj) (error-type-list obj loc)))
    275209
    276210(define-inline (%check-mailbox loc obj)
    277   (unless (%mailbox? obj)
    278     (%error-type-mailbox loc obj) )
    279   (unless (%mailbox-valid? obj)
    280     (%error-corrupted-mailbox loc obj) ) )
     211  (unless (%mailbox? obj) (error-type-mailbox loc obj))
     212  (unless (%mailbox-valid? obj) (error-corrupted-mailbox loc obj)) )
    281213
    282214(define-inline (%check-mailbox-cursor loc obj)
    283   (unless (%mailbox-cursor? obj)
    284     (%error-type-mailbox-cursor loc obj) )
    285   (unless (%mailbox-cursor-valid? obj)
    286     (%error-corrupted-mailbox loc obj) ) )
     215  (unless (%mailbox-cursor? obj) (error-type-mailbox-cursor loc obj))
     216  (unless (%mailbox-cursor-valid? obj) (error-corrupted-mailbox-cursor loc obj)) )
    287217
    288218(define-inline (%check-timeout loc obj)
    289   (unless (%timeout? obj)
    290     (%error-type-timeout loc obj) )
    291   (unless (and (%time? obj) (%time-valid? obj))
    292     (%error-corrupted-time loc obj) ) )
    293 
    294 (define-inline (%check-symbol loc obj)
    295   (##sys#check-symbol obj loc) )
    296 
    297 (define-inline (%check-list loc obj)
    298   (##sys#check-list obj loc) )
    299 
     219  (unless (%timeout? obj) (error-type-timeout loc obj))
     220  (unless (and (%time? obj) (%time-valid? obj)) (error-corrupted-time loc obj)) )
    300221
    301222;;;
     223
     224(require-library ports srfi-18)
    302225
    303226(module mailbox (;export
     
    345268    thread-signal! thread-resume! thread-sleep! thread-suspend!) )
    346269
     270;;; Errors
     271
     272(define (error-type-list loc obj)
     273  (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
     274
     275(define (error-type-symbol loc obj)
     276  (##sys#signal-hook #:type-error loc "bad argument type - not a symbol" obj) )
     277
     278(define (error-type-mailbox loc obj)
     279  (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox" obj) )
     280
     281(define (error-type-mailbox-cursor loc obj)
     282  (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox-cursor" obj) )
     283
     284(define (error-type-timeout loc obj)
     285  (##sys#signal-hook #:type-error loc "bad argument type - not a timeout object" obj) )
     286
     287(define (error-corrupted-mailbox loc obj)
     288  (##sys#signal-hook #:runtime-error loc "mailbox corrupted" obj) )
     289
     290(define (error-corrupted-mailbox-cursor loc obj)
     291  (##sys#signal-hook #:runtime-error loc "mailbox-cursor corrupted" obj) )
     292
     293(define (error-corrupted-time loc obj)
     294  (##sys#signal-hook #:runtime-error loc "time corrupted" obj) )
    347295
    348296;;; Mailbox Exceptions
     
    356304   (make-property-condition 'mailbox)
    357305   (make-property-condition 'timeout)) )
    358 
    359306
    360307;;; Mailbox Threading
     
    414361      MESSAGE-WAITING-TAG ) )
    415362
    416 
    417363;;; Mailbox
    418364
     
    488434  (%mailbox-queue-push-back-list! mb ls)
    489435  (ready-mailbox! mb) )
    490 
    491436
    492437;;; Mailbox Cursor
  • release/4/mailbox/trunk/mailbox.scm

    r13718 r13721  
    4242(define-inline (%queue-valid? obj)
    4343  (and #;(%queue? obj) (%fx= 3 (%structure-length obj))
    44        (%list? (%queue-first-pair q))
    45        (%list? (%queue-last-pair q)) ) )
     44       (%list? (%queue-first-pair obj))
     45       (%list? (%queue-last-pair obj)) ) )
    4646
    4747(define-inline (%queue-empty? q) (%null? (%queue-first-pair q)))
     
    149149(define-inline (%mailbox-valid? obj)
    150150  (and #;(%mailbox? obj) (%fx= 4 (%structure-length obj))
    151        (%queue-valid? (%mailbox-queue mb))
    152        (%list (%mailbox-waiters mb)) ) )
     151       (%queue-valid? (%mailbox-queue obj))
     152       (%list? (%mailbox-waiters obj)) ) )
    153153
    154154;; Mailbox Cursor Support
     
    166166(define-inline (%mailbox-cursor-valid? obj)
    167167  (and #;(%mailbox-cursor? obj) (%fx= 4 (%structure-length obj))
    168        (%mailbox-valid? (%mailbox-cursor-mailbox mbc))
    169        (%list? (%mailbox-cursor-next-pair mbc))
    170        (let ((pp (%mailbox-cursor-prev-pair mbc)))
     168       (%mailbox-valid? (%mailbox-cursor-mailbox obj))
     169       (%list? (%mailbox-cursor-next-pair obj))
     170       (let ((pp (%mailbox-cursor-prev-pair obj)))
    171171         (or (not pp) (%list? pp) ) ) ) )
    172172
     
    213213
    214214(define-inline (%check-mailbox-cursor loc obj)
    215   (unless (%mailbox-cursor? obj) (error-type-mailbox-cursor loc obj) 
    216   (unless (%mailbox-cursor-valid? obj) (error-corrupted-mailbox loc obj)) )
     215  (unless (%mailbox-cursor? obj) (error-type-mailbox-cursor loc obj))
     216  (unless (%mailbox-cursor-valid? obj) (error-corrupted-mailbox-cursor loc obj)) )
    217217
    218218(define-inline (%check-timeout loc obj)
Note: See TracChangeset for help on using the changeset viewer.