Changeset 14288 in project


Ignore:
Timestamp:
04/18/09 04:25:49 (11 years ago)
Author:
Kon Lovett
Message:

Added routines.

Location:
release/4/check-errors/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/check-errors/trunk/check-errors.setup

    r14086 r14288  
    77(copy-to-home "inline-type-checks.scm")
    88
    9 (setup-shared-extension-module 'conditions (extension-version "1.0.0"))
    10 
    119(setup-shared-extension-module 'type-errors (extension-version "1.0.0"))
    1210
    1311(setup-shared-extension-module 'type-checks (extension-version "1.0.0"))
    1412
     13(setup-shared-extension-module 'conditions (extension-version "1.0.0"))
     14
    1515(install-extension 'check-errors '() `((version ,(extension-version "1.0.0"))))
  • release/4/check-errors/trunk/conditions.scm

    r14229 r14288  
    1515  make-exn-condition
    1616  make-exn-condition+
     17  make-condition+
    1718  condition-predicate*
    18   (make-condition-predicate condition-predicate*))
     19  condition-property-accessor*
     20  (make-condition-predicate condition-predicate*)
     21  (make-condition-property-accessor condition-property-accessor*))
    1922
    20 (import scheme chicken (only srfi-1 alist-cons) #;srfi-12)
    21 (require-library srfi-1 #;srfi-12)
     23(import scheme chicken (only srfi-1 alist-cons) #;srfi-12 type-checks)
     24(require-library srfi-1 #;srfi-12 type-checks)
    2225
    2326;;
     
    3639;;   (<symbol> [<symbol> <object>]...)
    3740
     41(define (expand-property-conditions cnds)
     42   (map (lambda (cnd)
     43          (cond ((condition? cnd)  cnd )
     44                ((symbol? cnd)     (make-property-condition cnd) )
     45                ((pair? cnd)       (apply make-property-condition cnd) ) ) )
     46        cnds) )
     47
     48;;
     49
    3850(define (make-exn-condition+ loc msg args . cnds)
    3951  (apply make-composite-condition
    4052         (make-exn-condition loc msg args)
    41          (map (lambda (cnd)
    42                 (cond ((condition? cnd)  cnd )
    43                       ((symbol? cnd)     (make-property-condition cnd) )
    44                       ((pair? cnd)       (apply make-property-condition cnd) ) ) )
    45               cnds)) )
     53         (expand-property-conditions cnds)) )
     54
     55;;
     56
     57(define (make-condition+ . cnds)
     58  (apply make-composite-condition (expand-property-conditions cnds)) )
    4659
    4760;;
     
    4962(define condition-predicate*
    5063  (let ((preds '()))
    51     (lambda (tag)
    52       (let ((cell (assq tag preds)))
     64    (lambda (kind)
     65      (check-symbol 'condition-predicate* kind)
     66      (let ((cell (assq kind preds)))
    5367        (if cell (cdr cell)
    54             (let ((pred (condition-predicate tag)))
    55               (set! preds (alist-cons tag pred preds))
     68            (let ((pred (condition-predicate kind)))
     69              (set! preds (alist-cons kind pred preds))
    5670              pred ) ) ) ) ) )
     71
     72;;
     73
     74(define condition-property-accessor*
     75  (let ((accrs '()))
     76    (lambda (kind prop #!optional dflt)
     77      (check-symbol 'condition-property-accessor* kind)
     78      (check-symbol 'condition-property-accessor* prop)
     79      (let ((cell (assoc (cons kind prop) accrs)))
     80        (if cell (cdr cell)
     81            (let ((accr (condition-property-accessor kind prop dflt)))
     82              (set! accrs (alist-cons (cons kind prop) accr accrs))
     83              accr ) ) ) ) ) )
    5784
    5885;;
     
    6087(define-syntax make-condition-predicate
    6188  (syntax-rules ()
    62     ((_ tag0 ...) (lambda (obj) (and ((condition-predicate* 'tag0) obj) ...) ) ) ) )
     89    ((_ kind0 ...) (lambda (obj) (and ((condition-predicate* 'kind0) obj) ...) ) ) ) )
     90
     91;;
     92
     93(define-syntax make-condition-property-accessor
     94  (syntax-rules ()
     95    ((_ kind prop) (make-condition-property-accessor kind prop #f) )
     96    ((_ kind prop dflt) (condition-property-accessor* 'kind 'prop dflt) ) ) )
    6397
    6498) ;module conditions
  • release/4/check-errors/trunk/tests/run.scm

    r14229 r14288  
    2525(test-error (check-boolean 'test 'x))
    2626
    27 (define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
    28 (define testc? (make-condition-predicate exn test extra))
    29 (define testc-extra-test (condition-property-accessor 'extra 'test))
    30 
    31 (test 23 (testc-extra-test testc))
    32 (test-assert (testc? testc))
    33 
    3427(check-fixnum 'test 1)
    3528(check-positive-fixnum 'test 1)
     
    4942(check-cardinal-number 'test 0)
    5043(check-procedure 'test check-procedure)
    51 #;(check-input-port 'test 'x)
    52 #;(check-output-port 'test 'x)
     44(check-input-port 'test (current-input-port))
     45(check-output-port 'test (current-output-port))
    5346(check-list 'test '(x))
    5447(check-pair 'test '(x . y))
     
    6154(check-char 'test #\x)
    6255(check-boolean 'test #t)
     56
     57(define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
     58(define testc? (make-condition-predicate exn test extra))
     59(test-assert (testc? testc))
     60(test 23 ((condition-property-accessor 'extra 'test) testc))
     61
     62(define testc-extra-test (make-condition-property-accessor extra test))
     63(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
     64(test 23 (testc-extra-test testc))
     65(test 'foobar (testc-extra-foo testc))
Note: See TracChangeset for help on using the changeset viewer.