Changeset 36562 in project for release/5/mailbox/trunk/mailbox.scm


Ignore:
Timestamp:
09/08/18 20:01:52 (15 months ago)
Author:
Kon Lovett
Message:

remove condition-utils & check-errors dependencies

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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.