Changeset 36562 in project


Ignore:
Timestamp:
09/08/18 20:01:52 (10 days ago)
Author:
kon
Message:

remove condition-utils & check-errors dependencies

Location:
release/5/mailbox/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/trunk/inline-queue.scm

    r36012 r36562  
    1 ;;;; inline-queue.scm
     1;;;; inline-queue.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Jun '10
    33
    4 ;;; Requires (include "chicken-primitive-object-inlines")
     4;; Issues
     5;;
     6;; - Requires (only record-variants define-record-type-variant)
     7;; & (include "chicken-primitive-object-inlines")
    58
    69;; Support
     10
     11;;
    712
    813(define-record-type-variant queue (unsafe unchecked inline)
     
    2328(define-inline (%queue-add! q datum)
    2429  (let ((new-pair ($cons datum '())))
    25     (if ($null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
    26         ($set-cdr! (%queue-last-pair q) new-pair) )
     30    (if ($null? (%queue-first-pair q))
     31      (%queue-first-pair-set! q new-pair)
     32      ($set-cdr! (%queue-last-pair q) new-pair) )
    2733    (%queue-last-pair-set! q new-pair) ) )
    2834
     
    4248  (let ((newlist ($append! ($list-copy itemlist) (%queue-first-pair q))))
    4349    (%queue-first-pair-set! q newlist)
    44     (if ($null? newlist) (%queue-last-pair-empty! q)
    45         (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )
     50    (if ($null? newlist)
     51      (%queue-last-pair-empty! q)
     52      (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )
    4653
    4754(define-inline (%queue-extract-pair! q targ-pair)
    48   ; Scan queue list until we find the item to remove
     55  ;scan queue list until we find the item to remove
    4956  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
    50     ; Keep scanning until found
    51     (if (not ($eq? this-pair targ-pair)) (scanning ($cdr this-pair) this-pair)
    52         ;found so cut out the pair
    53         (let ((next-pair ($cdr this-pair)))
    54           ; At the head of the list, or in the body?
    55           (if ($null? prev-pair) (%queue-first-pair-set! q next-pair)
    56               ($set-cdr! prev-pair next-pair) )
    57           ; When the cut pair is the last item update the last pair ref.
    58           (when ($eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) ) ) ) )
     57    ;keep scanning until found
     58    (if (not ($eq? this-pair targ-pair))
     59      ;not found
     60      (scanning ($cdr this-pair) this-pair)
     61      ;found so cut out the pair
     62      (let ((next-pair ($cdr this-pair)))
     63        ;at the head of the list, or in the body?
     64        (if ($null? prev-pair)
     65          (%queue-first-pair-set! q next-pair)
     66          ($set-cdr! prev-pair next-pair) )
     67        ;when the cut pair is the last item update the last pair ref.
     68        (when ($eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) ) ) ) )
  • release/5/mailbox/trunk/mailbox.egg

    r36209 r36562  
    44((synopsis "Thread-safe queues with timeout")
    55 (category hell)
    6  (version "3.1.0")
     6 (version "3.2.0")
    77 (author "[[felix winkelman]] and [[kon lovett]]")
    88 (license "BSD")
     
    1010        (srfi-1 "0.2")
    1111        (srfi-18 "0.1")
    12         (check-errors "3.1.0")
    13         (condition-utils "2.1.0")
    1412        (record-variants "1.0"))
    1513 (test-dependencies test)
  • release/5/mailbox/trunk/mailbox.scm

    r36209 r36562  
    6565  (chicken type)
    6666  (only (chicken port) with-output-to-port)
    67   (only (chicken format) format)
     67  (only (chicken format) printf)
     68  (only (chicken string) conc ->string)
    6869  (only (srfi 1) append! delete! list-copy last-pair)
    6970  (only (srfi 18)
     
    7273    thread-signal! thread-sleep!
    7374    thread-suspend! thread-resume!)
    74   (only type-errors define-error-type error-list)
    75   (only condition-utils make-condition-predicate)
    76   (only exn-condition make-exn-condition+)
    77   record-variants)
     75  (only record-variants define-record-type-variant))
     76
     77;;;
     78
     79;;
     80
     81(define-inline (->boolean x)
     82  (and x #t) )
     83
     84;;;(only type-errors define-error-type)
     85
     86;;
     87
     88(define-inline (localized-type-name-message typnam)
     89  ;FIXME en only
     90  (conc (appropriate-indefinite-article typnam) " " typnam) )
     91
     92;;
     93
     94(define +english-vowels+ '(#\a #\e #\i #\o #\u))
     95(define +english-indefinite-articles+ '(an a))
     96
     97(define-inline (vowel? ch)
     98  (->boolean (memq ch +english-vowels+)) )
     99
     100(define-inline (appropriate-indefinite-article wrd)
     101  (let ((s (->string wrd)))
     102    (if (vowel? (string-ref s 0))
     103      (car +english-indefinite-articles+)
     104      (cadr +english-indefinite-articles+) ) ) )
     105
     106;;
     107
     108(define-inline (make-bad-argument-message #!optional argnam)
     109  (if (not argnam)
     110    "bad argument"
     111    (conc "bad " #\` argnam #\' " argument") ) )
     112
     113(define-inline (make-type-name-message typnam)
     114  (or
     115    (localized-type-name-message typnam)
     116    (->string typnam)) )
     117
     118(define-inline (make-error-type-message typnam #!optional argnam)
     119  (string-append
     120    (make-bad-argument-message argnam)
     121    " type - not "
     122    (make-type-name-message typnam)) )
     123
     124;;
     125
     126(define-inline (error-list loc obj #!optional argnam)
     127  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
    78128
    79129;;; Primitives
     
    143193  (%raw-make-mailbox nm (%make-queue) '()) )
    144194
    145 (define-error-type mailbox)
     195(define (error-mailbox loc obj #!optional argnam)
     196  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox argnam) obj) )
     197
    146198(define-inline-check-type mailbox)
    147199
     
    205257  (%raw-make-mailbox-cursor '() #f mb) )
    206258
    207 (define-error-type mailbox-cursor)
     259(define (error-mailbox-cursor loc obj #!optional argnam)
     260  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
     261
    208262(define-inline-check-type mailbox-cursor)
    209263
     
    238292  (or (%time-number? obj) (time? obj)) )
    239293
    240 (define-error-type timeout)
     294(define (error-timeout loc obj #!optional argnam)
     295  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
     296
    241297(define-inline-check-type timeout)
    242298
     
    256312(define (make-mailbox-timeout-condition loc mb timout timout-value)
    257313  (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
    258     (make-exn-condition+
    259       loc "mailbox wait timeout occurred" (list timout tv)
    260       `(mailbox box ,mb)
    261       `(timeout time ,timout value ,tv) ) ) )
     314    (make-composite-condition
     315      (make-property-condition 'exn
     316        'location loc
     317        'message "mailbox wait timeout occurred"
     318        'arguments (list timout tv))
     319      (make-property-condition 'mailbox 'box mb)
     320      (make-property-condition 'timeout 'time timout 'value tv)) ) )
    262321
    263322;;; Mailbox Threading
     
    384443(: mailbox-timeout-condition? (* -> boolean : condition))
    385444;
    386 (define mailbox-timeout-condition?
    387   (make-condition-predicate exn mailbox timeout))
     445(define (mailbox-timeout-condition? obj)
     446  (and
     447    ((condition-predicate 'exn) obj)
     448    ((condition-predicate 'mailbox) obj)
     449    ((condition-predicate 'timeout) obj) ) )
    388450
    389451;; Mailbox Constructor
     
    556618  (with-output-to-port out
    557619    (lambda ()
    558       (format #t "#<mailbox ~A queued: ~A waiters: ~A>"
     620      (printf "#<mailbox ~A queued: ~A waiters: ~A>"
    559621        (%mailbox-name mb)
    560622        (%mailbox-queue-count mb)
     
    564626  (with-output-to-port out
    565627    (lambda ()
    566       (format #t "#<mailbox-cursor mailbox: ~A status: ~A>"
     628      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
    567629      (%mailbox-name (%mailbox-cursor-mailbox mbc))
    568630      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
Note: See TracChangeset for help on using the changeset viewer.