Changeset 14191 in project


Ignore:
Timestamp:
04/08/09 18:56:51 (11 years ago)
Author:
Kon Lovett
Message:

Update.

Location:
release/4/mailbox
Files:
4 edited
7 copied

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/tags/2.0.0/chicken-primitive-object-inlines.scm

    r14079 r14191  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/mailbox/tags/2.1.0/chicken-primitive-object-inlines.scm

    r14185 r14191  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/mailbox/tags/2.1.0/mailbox.meta

    r14185 r14191  
    22
    33((egg "mailbox.egg")
     4 (synopsis "Thread-safe queues with timeout")
    45 (category hell)
    56 (author "[[felix winkelman]] and [[kon lovett]]")
    67 (license "BSD")
    78 (doc-from-wiki)
    8  (needs setup-helper)
    9  (synopsis "Thread-safe queues with timeout")
     9 (needs check-errors setup-helper)
    1010 (files
    1111  "chicken-primitive-object-inlines.scm"
  • release/4/mailbox/tags/2.1.0/mailbox.scm

    r14185 r14191  
    2929(include "chicken-primitive-object-inlines")
    3030(include "chicken-thread-object-inlines")
     31(include "inline-type-checks")
    3132
    3233;; Queue Support
     
    204205;; Argument Checking
    205206
    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)))
    209 
    210207(define-inline (%check-mailbox loc obj)
    211   (unless (%mailbox? obj) (error-type-mailbox loc obj))
     208  (unless (%mailbox? obj) (error-mailbox loc obj))
    212209  (unless (%mailbox-valid? obj) (error-corrupted-mailbox loc obj)) )
    213210
    214211(define-inline (%check-mailbox-cursor loc obj)
    215   (unless (%mailbox-cursor? obj) (error-type-mailbox-cursor loc obj))
     212  (unless (%mailbox-cursor? obj) (error-mailbox-cursor loc obj))
    216213  (unless (%mailbox-cursor-valid? obj) (error-corrupted-mailbox-cursor loc obj)) )
    217214
    218215(define-inline (%check-timeout loc obj)
    219   (unless (%timeout? obj) (error-type-timeout loc obj))
     216  (unless (%timeout? obj) (error-timeout loc obj))
    220217  (unless (and (%time? obj) (%time-valid? obj)) (error-corrupted-time loc obj)) )
    221218
    222219;;;
    223 
    224 (require-library ports srfi-18)
    225220
    226221(module mailbox (;export
    227222  ;
    228   mailbox-timeout-exception?
     223  mailbox-timeout-condition? mailbox-timeout-exception?
    229224  ;
    230225  make-mailbox
     
    266261    with-output-to-port)
    267262  (only srfi-18
    268     thread-signal! thread-resume! thread-sleep! thread-suspend!) )
     263    thread-signal! thread-resume! thread-sleep! thread-suspend!)
     264  (only type-errors
     265    define-error-type error-list error-symbol)
     266  (only conditions
     267    make-exn-condition+ make-condition-predicate))
     268
     269(require-library ports srfi-18 type-errors conditions)
    269270
    270271;;; Errors
    271272
    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) )
     273(define-error-type mailbox)
     274(define-error-type mailbox-cursor)
     275(define-error-type timeout)
    286276
    287277(define (error-corrupted-mailbox loc obj)
     
    297287
    298288(define (make-mailbox-timeout-condition loc to-tim to-def)
    299   (make-composite-condition
    300    (make-property-condition 'exn
    301     'location loc
    302     'message "mailbox wait timeout occured"
    303     'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
    304    (make-property-condition 'mailbox)
    305    (make-property-condition 'timeout)) )
     289  (let ((args (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def))))
     290    (make-exn-condition+ loc "mailbox wait timeout occured" args 'mailbox 'timeout) ) )
    306291
    307292;;; Mailbox Threading
     
    365350;; Mailbox Exceptions
    366351
    367 (define mailbox-timeout-exception?
    368   (let ((exf (condition-predicate 'exn))
    369         (mbf (condition-predicate 'mailbox))
    370         (tmf (condition-predicate 'timeout)))
    371     (lambda (obj)
    372       (and (exf obj) (mbf obj) (tmf obj)) ) ) )
     352(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
     353(define mailbox-timeout-exception? mailbox-timeout-condition?)
    373354
    374355;; Mailbox Constructor
  • release/4/mailbox/trunk/chicken-primitive-object-inlines.scm

    r14079 r14191  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/mailbox/trunk/mailbox.meta

    r13617 r14191  
    22
    33((egg "mailbox.egg")
     4 (synopsis "Thread-safe queues with timeout")
    45 (category hell)
    56 (author "[[felix winkelman]] and [[kon lovett]]")
    67 (license "BSD")
    78 (doc-from-wiki)
    8  (needs setup-helper)
    9  (synopsis "Thread-safe queues with timeout")
     9 (needs check-errors setup-helper)
    1010 (files
    1111  "chicken-primitive-object-inlines.scm"
  • release/4/mailbox/trunk/mailbox.scm

    r13721 r14191  
    2929(include "chicken-primitive-object-inlines")
    3030(include "chicken-thread-object-inlines")
     31(include "inline-type-checks")
    3132
    3233;; Queue Support
     
    204205;; Argument Checking
    205206
    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)))
    209 
    210207(define-inline (%check-mailbox loc obj)
    211   (unless (%mailbox? obj) (error-type-mailbox loc obj))
     208  (unless (%mailbox? obj) (error-mailbox loc obj))
    212209  (unless (%mailbox-valid? obj) (error-corrupted-mailbox loc obj)) )
    213210
    214211(define-inline (%check-mailbox-cursor loc obj)
    215   (unless (%mailbox-cursor? obj) (error-type-mailbox-cursor loc obj))
     212  (unless (%mailbox-cursor? obj) (error-mailbox-cursor loc obj))
    216213  (unless (%mailbox-cursor-valid? obj) (error-corrupted-mailbox-cursor loc obj)) )
    217214
    218215(define-inline (%check-timeout loc obj)
    219   (unless (%timeout? obj) (error-type-timeout loc obj))
     216  (unless (%timeout? obj) (error-timeout loc obj))
    220217  (unless (and (%time? obj) (%time-valid? obj)) (error-corrupted-time loc obj)) )
    221218
    222219;;;
    223 
    224 (require-library ports srfi-18)
    225220
    226221(module mailbox (;export
    227222  ;
    228   mailbox-timeout-exception?
     223  mailbox-timeout-condition? mailbox-timeout-exception?
    229224  ;
    230225  make-mailbox
     
    266261    with-output-to-port)
    267262  (only srfi-18
    268     thread-signal! thread-resume! thread-sleep! thread-suspend!) )
     263    thread-signal! thread-resume! thread-sleep! thread-suspend!)
     264  (only type-errors
     265    define-error-type error-list error-symbol)
     266  (only conditions
     267    make-exn-condition+ make-condition-predicate))
     268
     269(require-library ports srfi-18 type-errors conditions)
    269270
    270271;;; Errors
    271272
    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) )
     273(define-error-type mailbox)
     274(define-error-type mailbox-cursor)
     275(define-error-type timeout)
    286276
    287277(define (error-corrupted-mailbox loc obj)
     
    297287
    298288(define (make-mailbox-timeout-condition loc to-tim to-def)
    299   (make-composite-condition
    300    (make-property-condition 'exn
    301     'location loc
    302     'message "mailbox wait timeout occured"
    303     'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
    304    (make-property-condition 'mailbox)
    305    (make-property-condition 'timeout)) )
     289  (let ((args (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def))))
     290    (make-exn-condition+ loc "mailbox wait timeout occured" args 'mailbox 'timeout) ) )
    306291
    307292;;; Mailbox Threading
     
    365350;; Mailbox Exceptions
    366351
    367 (define mailbox-timeout-exception?
    368   (let ((exf (condition-predicate 'exn))
    369         (mbf (condition-predicate 'mailbox))
    370         (tmf (condition-predicate 'timeout)))
    371     (lambda (obj)
    372       (and (exf obj) (mbf obj) (tmf obj)) ) ) )
     352(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
     353(define mailbox-timeout-exception? mailbox-timeout-condition?)
    373354
    374355;; Mailbox Constructor
Note: See TracChangeset for help on using the changeset viewer.