Changeset 13656 in project


Ignore:
Timestamp:
03/10/09 10:04:07 (11 years ago)
Author:
Kon Lovett
Message:

Release.

File:
1 edited

Legend:

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

    r13533 r13656  
    1515  (local)
    1616  (no-procedure-checks)
    17   (no-bound-checks)
    1817  (bound-to-procedure
    1918    ##sys#check-structure
     
    6665
    6766(define-inline (%queue-add! q datum)
    68   (let ([new-pair (%cons datum '())])
     67  (let ((new-pair (%cons datum '())))
    6968    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
    7069        (%set-cdr! (%queue-last-pair q) new-pair) )
     
    7271
    7372(define-inline (%queue-remove! q)
    74   (let* ([first-pair (%queue-first-pair q)]
    75          [next-pair (%cdr first-pair)])
     73  (let* ((first-pair (%queue-first-pair q))
     74         (next-pair (%cdr first-pair)))
    7675    (%queue-first-pair-set! q next-pair)
    7776    (when (%null? next-pair) (%queue-last-pair-empty! q) )
     
    7978
    8079(define-inline (%queue-push-back! q item)
    81   (let ([newlist (%cons item (%queue-first-pair q))])
     80  (let ((newlist (%cons item (%queue-first-pair q))))
    8281    (%queue-first-pair-set! q newlist)
    8382    (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    8483
    8584(define-inline (%queue-push-back-list! q itemlist)
    86   (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
     85  (let ((newlist (%append! (%list-copy itemlist) (%queue-first-pair q))))
    8786    (%queue-first-pair-set! q newlist)
    8887    (if (%null? newlist) (%queue-last-pair-empty! q)
     
    9190(define-inline (%queue-extract-pair! q targ-pair)
    9291  ; Scan queue list until we find the item to remove
    93   (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
     92  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
    9493    ; Found it?
    9594    (if (%eq? this-pair targ-pair)
    9695        ;then cut out the pair
    97         (let ([next-pair (%cdr this-pair)])
     96        (let ((next-pair (%cdr this-pair)))
    9897          ; At the head of the list, or in the body?
    9998          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
     
    166165
    167166(define-inline (%mailbox-waiters-pop! mb)
    168   (let ([ts (%mailbox-waiters mb)])
     167  (let ((ts (%mailbox-waiters mb)))
    169168    (%mailbox-waiters-set! mb (%cdr ts))
    170169    (%car ts) ) )
     
    210209(define-inline (%mailbox-cursor-extract! mbc)
    211210  ; Unless 'mailbox-cursor-next' has been called don't remove
    212   (and-let* ([prev-pair (%mailbox-cursor-prev-pair mbc)])
     211  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    213212    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
    214213
     
    315314  ; Ready oldest waiting thread
    316315  (unless (%mailbox-waiters-empty? mb)
    317     (let ([thread (%mailbox-waiters-pop! mb)])
     316    (let ((thread (%mailbox-waiters-pop! mb)))
    318317      ; Ready the thread based on wait mode
    319318      (if (not (%thread-blocked? thread)) (thread-resume! thread)
     
    334333  ; Waiting action
    335334  (cond
    336     [to-tim           ; Timeout wanted so sleep until something happens
    337       (let ([early? #f])
     335    (to-tim           ; Timeout wanted so sleep until something happens
     336      (let ((early? #f))
    338337        ; Sleep current thread until desired seconds elapsed
    339338        (condition-case (thread-sleep! to-tim)
    340           [exn ()
     339          (exn ()
    341340            ; Unless unblocked "early" then a real exception so propagate
    342341            (if (%eq? UNBLOCKED-TAG exn) (set! early? #t)
    343                 (signal exn) ) ] )
     342                (signal exn) ) ) )
    344343        ; Awake
    345344        (cond
    346           [early?       ; Unblocked early so we have a message
    347             MESSAGE-WAITING-TAG ]
    348           [else         ; Timedout
     345          (early?       ; Unblocked early so we have a message
     346            MESSAGE-WAITING-TAG )
     347          (else         ; Timedout
    349348            ; Remove from wait queue
    350349            (%mailbox-waiters-delete! mb (%current-thread))
     
    354353                              (make-mailbox-timeout-condition loc to-tim to-def)) )
    355354            ; No message waiting
    356             to-def ] ) ) ]
    357       [else           ; Suspend until something delivered
     355            to-def ) ) ) )
     356      (else           ; Suspend until something delivered
    358357        (thread-suspend! (%current-thread))
    359         MESSAGE-WAITING-TAG ] ) )
     358        MESSAGE-WAITING-TAG ) ) )
    360359
    361360(define (wait-mailbox-if-empty! loc mb to-tim to-def)
     
    370369
    371370(define mailbox-timeout-exception?
    372   (let ([exf (condition-predicate 'exn)]
    373         [mbf (condition-predicate 'mailbox)]
    374         [tmf (condition-predicate 'timeout)])
     371  (let ((exf (condition-predicate 'exn))
     372        (mbf (condition-predicate 'mailbox))
     373        (tmf (condition-predicate 'timeout)))
    375374    (lambda (obj)
    376375      (and (exf obj) (mbf obj) (tmf obj)) ) ) )
     
    422421  (%check-mailbox 'mailbox-receive! mb)
    423422  (when to-tim (%check-timeout 'mailbox-receive! to-tim))
    424   (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
     423  (let ((res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)))
    425424    ; Return next item in mailbox, if any
    426425    (if (%eq? MESSAGE-WAITING-TAG res) (%mailbox-queue-remove! mb)
     
    471470  (when to-tim (%check-timeout 'mailbox-cursor-next to-tim))
    472471  ; Waiting mailbox peek.
    473   (let ([mb (%mailbox-cursor-mailbox mbc)])
    474     (let-values ([(mailbox-waiter cursor-pair-getter)
     472  (let ((mb (%mailbox-cursor-mailbox mbc)))
     473    (let-values (((mailbox-waiter cursor-pair-getter)
    475474                  (if (%mailbox-cursor-winding? mbc)
    476475                      ;then wait for something to be appended
     
    479478                      ;else grab the start of a, probably, non-empty queue
    480479                      (values wait-mailbox-if-empty!
    481                               (lambda () (%mailbox-queue-first-pair mb))) ) ] )
    482       (let scanning ([next-pair (%mailbox-cursor-next-pair mbc)])
     480                              (lambda () (%mailbox-queue-first-pair mb))) ) ) )
     481      (let scanning ((next-pair (%mailbox-cursor-next-pair mbc)))
    483482        ; Anything next?
    484483        (if (not (%null? next-pair))
    485484            ;then peek into the queue for the next item
    486             (let ([item (%car next-pair)])
     485            (let ((item (%car next-pair)))
    487486              (%mailbox-cursor-prev-pair-set! mbc next-pair)
    488487              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    489488              item )
    490489            ;else wait for something in the mailbox
    491             (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
     490            (let ((res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)))
    492491              (cond
    493                 [(%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
     492                ((%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
    494493                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    495                   (scanning (%mailbox-cursor-next-pair mbc)) ]
    496                 [else                            ; otherwise timedout
    497                   res ] ) ) ) ) ) ) )
     494                  (scanning (%mailbox-cursor-next-pair mbc)) )
     495                (else                            ; otherwise timedout
     496                  res ) ) ) ) ) ) ) )
    498497
    499498(define (mailbox-cursor-extract-and-rewind! mbc)
Note: See TracChangeset for help on using the changeset viewer.