Changeset 13691 in project


Ignore:
Timestamp:
03/12/09 06:36:27 (11 years ago)
Author:
Kon Lovett
Message:

Use of core immutable.

Location:
release/4/mailbox
Files:
2 edited

Legend:

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

    r13656 r13691  
    4444  (%structure-ref q 1) )
    4545
    46 (define-inline (%queue-first-pair-set! q v)
    47   (%structure-set! q 1 v) )
    48 
    4946(define-inline (%queue-last-pair q)
    5047  (%structure-ref q 2) )
    5148
    52 (define-inline (%queue-last-pair-set! q v)
    53   (%structure-set! q 2 v) )
     49(define-inline (%queue-valid? obj)
     50  (and #;(%queue? obj) (%fx= 3 (%structure-length obj))
     51       (%list? (%queue-first-pair q))
     52       (%list? (%queue-last-pair q)) ) )
    5453
    5554(define-inline (%queue-empty? q)
     
    5857(define-inline (%queue-count q)
    5958  (%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) )
    6065
    6166;; Queue Operations
     
    6772  (let ((new-pair (%cons datum '())))
    6873    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
    69         (%set-cdr! (%queue-last-pair q) new-pair) )
     74        (%set-cdr!/mutate (%queue-last-pair q) new-pair) )
    7075    (%queue-last-pair-set! q new-pair) ) )
    7176
     
    97102          ; At the head of the list, or in the body?
    98103          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
    99               (%set-cdr! prev-pair next-pair) )
     104              (%set-cdr!/mutate prev-pair next-pair) )
    100105          ; When the cut pair is the last item update the last pair ref.
    101106          (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
     
    120125  (%structure-ref mb 2) )
    121126
     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
    122133(define-inline (%mailbox-queue-empty? mb)
    123134  (%queue-empty? (%mailbox-queue mb)) )
     
    138149  (%queue-push-back-list! (%mailbox-queue mb) ls) )
    139150
    140 (define-inline (%mailbox-queue-first-pair mb)
    141   (%queue-first-pair (%mailbox-queue mb)) )
    142 
    143 (define-inline (%mailbox-queue-last-pair mb)
    144   (%queue-last-pair (%mailbox-queue mb)) )
    145 
    146151;; Waiting threads
    147152
     
    149154  (%structure-ref mb 3) )
    150155
    151 (define-inline (%mailbox-waiters-set! mb v)
    152   (%structure-set! mb 3 v) )
    153 
    154156(define-inline (%mailbox-waiters-empty? mb)
    155157  (%null? (%mailbox-waiters mb)) )
     
    157159(define-inline (%mailbox-waiters-count mb)
    158160  (%length (%mailbox-waiters mb)) )
     161
     162(define-inline (%mailbox-waiters-set! mb v)
     163  (%structure-set!/mutate  mb 3 v) )
    159164
    160165(define-inline (%mailbox-waiters-add! mb th)
     
    169174    (%car ts) ) )
    170175
     176;;
     177
     178(define-inline (%mailbox-valid? obj)
     179  (and #;(%mailbox? obj) (%fx= 4 (%structure-length obj))
     180       (%queue-valid? (%mailbox-queue mb))
     181       (%list (%mailbox-waiters mb)) ) )
     182
    171183
    172184;;; Mailbox Cursor Support
     
    181193  (%structure-ref mbc 1) )
    182194
    183 (define-inline (%mailbox-cursor-next-pair-set! mbc v)
    184   (%structure-set! mbc 1 v) )
    185 
    186 (define-inline (%mailbox-cursor-next-pair-empty! mbc)
    187   (%structure-set!/immediate mbc 1 '()) )
    188 
    189195(define-inline (%mailbox-cursor-prev-pair mbc)
    190196  (%structure-ref mbc 2) )
    191197
    192 (define-inline (%mailbox-cursor-prev-pair-set! mbc v)
    193   (%structure-set! mbc 2 v) )
    194 
    195 (define-inline (%mailbox-cursor-prev-pair-clear! mbc)
    196   (%structure-set!/immediate mbc 2 #f) )
     198(define-inline (%mailbox-cursor-mailbox mbc)
     199  (%structure-ref mbc 3) )
     200
     201(define-inline (%mailbox-cursor-valid? obj)
     202  (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)))
     206         (or (not pp) (%list? pp) ) ) ) )
    197207
    198208(define-inline (%mailbox-cursor-winding? mbc)
     
    200210       #t) )
    201211
    202 (define-inline (%mailbox-cursor-mailbox mbc)
    203   (%structure-ref mbc 3) )
    204 
    205 (define-inline (%mailbox-cursor-rewind mbc)
     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) )
     223
     224(define-inline (%mailbox-cursor-rewind! mbc)
    206225  (%mailbox-cursor-next-pair-empty! mbc)
    207226  (%mailbox-cursor-prev-pair-clear! mbc) )
     
    218237  (%structure-instance? obj 'time) )
    219238
     239(define-inline (%time-valid? obj)
     240  (and #;(%time? obj) (%fx= 4 (%structure-length obj))
     241       (%fixnum? (%structure-ref obj 1))
     242       (%number? (%structure-ref obj 2))
     243       (%fixnum? (%structure-ref obj 3)) ) )
     244
    220245(define-inline (%timeout? obj)
    221246  (or (%time? obj) (%number? obj)) )
     
    231256;;; Argument Checking
    232257
     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) )
     275
    233276(define-inline (%check-mailbox loc obj)
    234   (##sys#check-structure obj 'mailbox loc) )
     277  (unless (%mailbox? obj)
     278    (%error-type-mailbox loc obj) )
     279  (unless (%mailbox-valid? obj)
     280    (%error-corrupted-mailbox loc obj) ) )
    235281
    236282(define-inline (%check-mailbox-cursor loc obj)
    237   (##sys#check-structure obj 'mailbox-cursor loc) )
     283  (unless (%mailbox-cursor? obj)
     284    (%error-type-mailbox-cursor loc obj) )
     285  (unless (%mailbox-cursor-valid? obj)
     286    (%error-corrupted-mailbox loc obj) ) )
    238287
    239288(define-inline (%check-timeout loc obj)
    240289  (unless (%timeout? obj)
    241     (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout object" obj) ) )
     290    (%error-type-timeout loc obj) )
     291  (unless (and (%time? obj) (%time-valid? obj))
     292    (%error-corrupted-time loc obj) ) )
    242293
    243294(define-inline (%check-symbol loc obj)
     
    464515(define (mailbox-cursor-rewind mbc)
    465516  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
    466   (%mailbox-cursor-rewind mbc) )
     517  (%mailbox-cursor-rewind! mbc) )
    467518
    468519(define (mailbox-cursor-next mbc #!optional to-tim (to-def (%undefined-value)))
     
    499550  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
    500551  (%mailbox-cursor-extract! mbc)
    501   (%mailbox-cursor-rewind mbc) )
     552  (%mailbox-cursor-rewind! mbc) )
    502553
    503554;;; Read/Print Syntax
  • release/4/mailbox/trunk/mailbox.scm

    r13664 r13691  
    257257
    258258(define-inline (%error-type-mailbox loc obj)
    259   (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox" obj) )
     259  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mailbox") obj) )
    260260
    261261(define-inline (%error-type-mailbox-cursor loc obj)
    262   (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox-cursor" obj) )
     262  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mailbox-cursor") obj) )
    263263
    264264(define-inline (%error-type-timeout loc obj)
    265   (##sys#signal-hook #:type-error loc "bad argument type - not a timeout object" obj) )
     265  (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a timeout object") obj) )
    266266
    267267(define-inline (%error-corrupted-mailbox loc obj)
    268   (##sys#signal-hook #:type-error loc "mailbox corrupted" obj) )
     268  (##sys#signal-hook #:type-error loc (##core#immutable '"mailbox corrupted") obj) )
    269269
    270270(define-inline (%error-corrupted-mailbox-cursor loc obj)
    271   (##sys#signal-hook #:type-error loc "mailbox-cursor corrupted" obj) )
     271  (##sys#signal-hook #:type-error loc (##core#immutable '"mailbox-cursor corrupted") obj) )
    272272
    273273(define-inline (%error-corrupted-time loc obj)
    274   (##sys#signal-hook #:type-error loc "time corrupted" obj) )
     274  (##sys#signal-hook #:type-error loc (##core#immutable '"time corrupted") obj) )
    275275
    276276(define-inline (%check-mailbox loc obj)
Note: See TracChangeset for help on using the changeset viewer.