Changeset 29156 in project


Ignore:
Timestamp:
06/22/13 23:30:06 (7 years ago)
Author:
Kon Lovett
Message:

add call-chain supp, use hash-table instead of alist, add module of condition predicates & accessors

Location:
release/4/condition-utils/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/condition-utils/trunk/condition-utils.meta

    r27570 r29156  
    1111  (check-errors "1.12.0"))
    1212 (test-depends test)
    13  (files "condition-utils.setup" "condition-utils.meta" "condition-utils.release-info" "condition-utils.scm" "tests/run.scm") )
     13 (files "condition-utils.setup" "condition-utils.meta"
     14  "condition-utils.release-info" "condition-utils.scm"
     15  "standard-conditions.scm" "tests/run.scm") )
  • release/4/condition-utils/trunk/condition-utils.scm

    r19663 r29156  
    11;;;; condition-utils.scm
     2;;;; Kon Lovett, Jun '13
    23;;;; Kon Lovett, Aug '10
    34;;;; Kon Lovett, Apr '09
     
    56;; Issues
    67;;
    7 ;; - The memoized condition-predicate & condition-property-accessor facility
    8 ;; uses an association-list. Past approximately 10 items this will become
    9 ;; slower than a hash-table.
    108
    119(module condition-utils
    1210
    1311  (;export
    14     make-exn-condition
    15     make-exn-condition+
     12    ;
     13    condition-irritants
    1614    make-condition+
    1715    condition-predicate*
    1816    condition-property-accessor*
    1917    (make-condition-predicate condition-predicate*)
    20     (make-condition-property-accessor condition-property-accessor*))
     18    (make-condition-property-accessor condition-property-accessor*)
     19    ;
     20    make-exn-condition
     21    make-exn-condition+
     22  )
    2123
    22   (import scheme chicken #;(only type-checks check-symbol))
     24  (import scheme chicken)
    2325
    24   (require-library #;type-checks)
     26  (use srfi-1 srfi-69 #;type-checks)
    2527
    26 ;;
     28;;;
    2729
    28 (define (make-exn-condition #!optional (loc #f) (msg #f) (args #f))
    29   (make-property-condition 'exn
    30     'location loc
    31     'message (or msg "")
    32     'arguments (or args '())) )
     30; Symbols are convention. Any object supported.
     31
     32(define (check-kind loc obj)
     33  #;(check-symbol loc obj 'property-kind)
     34  (void) )
     35
     36(define (check-property-tag loc obj)
     37  #;(check-symbol loc obj 'property-tag)
     38  (void) )
     39
     40;;;
     41
     42;; Interpret condition expression
    3343
    3444;; <condition>  ->  <condition>
     
    3949
    4050(define (expand-property-conditions cnds)
    41    (map (lambda (cnd)
    42           (cond
    43             ((condition? cnd)  cnd )
    44             ((symbol? cnd)     (make-property-condition cnd) )
    45             ((pair? cnd)       (apply make-property-condition cnd) ) ) )
     51   (map (lambda (x)
     52          (cond ((condition? x)  x )
     53                ((symbol? x)     (make-property-condition x) )
     54                ((pair? x)       (apply make-property-condition x) ) ) )
    4655        cnds) )
    4756
    48 ;;
     57;;;
    4958
    50 (define (make-exn-condition+ loc msg args . cnds)
    51   (apply make-composite-condition
    52          (make-exn-condition loc msg args)
    53          (expand-property-conditions cnds)) )
     59;; All condition properties
    5460
    55 ;;
     61(define (condition-irritants exn)
     62  (fold
     63    (lambda (kndlst lst) (append! lst (cdr kndlst)) )
     64    '()
     65    (condition->list exn)) )
     66
     67;; Condition from condition expression; composite when indicated
    5668
    5769(define (make-condition+ . cnds)
    58   (apply make-composite-condition (expand-property-conditions cnds)) )
     70  (let ((ls (expand-property-conditions cnds)))
     71    (if (= 1 (length ls)) (car ls)
     72    (apply make-composite-condition ls) ) ) )
    5973
    6074;;
    6175
    6276(define condition-predicate*
    63   (let ((+preds+ '()))
     77  (let ((+preds+ (make-hash-table eq?)))
    6478    (lambda (kind)
    65       #;(check-symbol 'condition-predicate* kind)
    66       (let ((p (assq kind +preds+)))
    67         (if p (cdr p)
    68           (let ((pred (condition-predicate kind)))
    69             (set! +preds+ (cons (cons kind pred) +preds+))
    70             pred ) ) ) ) ) )
    71 
    72 ;;
    73 
    74 (define condition-property-accessor*
    75   (let ((+getters+ '()))
    76     (lambda (kind prop #!optional dflt)
    77       #;(check-symbol 'condition-property-accessor* kind)
    78       #;(check-symbol 'condition-property-accessor* prop)
    79       (let ((key (cons kind prop)))
    80         (let ((p (assoc key +getters+)))
    81           (if p (cdr p)
    82             (let ((getter (condition-property-accessor kind prop dflt)))
    83               (set! +getters+ (cons (cons key getter) +getters+))
    84               getter ) ) ) ) ) ) )
     79      #;(check-kind 'condition-predicate* kind)
     80      (let ((p (hash-table-ref/default +preds+ kind #f)))
     81        (or p
     82            (let ((pred (condition-predicate kind)))
     83              (hash-table-set! +preds+ kind pred)
     84              pred ) ) ) ) ) )
    8585
    8686;;
     
    8989  (syntax-rules ()
    9090    ((_ ?kind0 ...)
    91       (lambda (obj)
    92         (and ((condition-predicate* '?kind0) obj) ...) ) ) ) )
     91      (lambda (obj) (and ((condition-predicate* '?kind0) obj) ...) ) ) ) )
     92
     93;;
     94
     95(define condition-property-accessor*
     96  (let ((+getters+ (make-hash-table eq?)))
     97    (lambda (kind prop #!optional dflt)
     98      #;(check-kind 'condition-property-accessor* kind)
     99      #;(check-property-tag 'condition-property-accessor* prop)
     100      (let* ((key (cons kind prop))
     101             (p (hash-table-ref/default +getters+ kind #f)) )
     102        (or p
     103            (let ((getter (condition-property-accessor kind prop dflt)))
     104              (hash-table-set! +getters+ key getter)
     105              getter ) ) ) ) ) )
    93106
    94107;;
     
    103116      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
    104117
     118;;; EXN Condition
     119
     120;;
     121
     122(define (make-exn-condition #!optional (loc #f) (msg #f) (args #f) (calls #f))
     123  (apply make-property-condition 'exn
     124    (append!
     125      (list 'location loc)
     126      (list 'message (or msg ""))
     127      (list 'arguments (or args '()))
     128      (if calls (list 'call-chain calls) '()))) )
     129
     130;;
     131
     132(define (make-exn-condition+ loc msg args . cnds)
     133  (define (call-chain? x)
     134    ;(and (proper-list? x) (every vector? x))
     135    (and
     136      (pair? x)
     137      (vector? (car x))) )
     138  (let ((chn (and (not (null? cnds))
     139                  (call-chain? (car cnds))
     140                  (car cnds))))
     141    (apply make-composite-condition
     142           (apply make-exn-condition loc msg args (or chn '()))
     143           (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
     144
    105145) ;module condition-utils
  • release/4/condition-utils/trunk/condition-utils.setup

    r28405 r29156  
    55(verify-extension-name "condition-utils")
    66
    7 (setup-shared-extension-module 'condition-utils (extension-version "1.0.2")
     7(setup-shared-extension-module 'condition-utils (extension-version "1.0.3")
    88  #:inline? #t
    99  #:types? #t
     
    1313    -optimize-level 3
    1414    -no-procedure-checks))
     15
     16(setup-shared-extension-module 'standard-conditions (extension-version "1.0.3")
     17  #:inline? #t
     18  #:types? #t
     19  #:compile-options '(
     20    -scrutinize
     21    -fixnum-arithmetic
     22    -optimize-level 3
     23    -no-procedure-checks))
  • release/4/condition-utils/trunk/tests/run.scm

    r28405 r29156  
    11(use test)
     2
    23(use condition-utils)
    34
    45(define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
    56(define testc? (make-condition-predicate exn test extra))
    6 (test-assert (testc? testc))
    7 (test 23 ((condition-property-accessor 'extra 'test) testc))
     7(test-assert "composite of exn test extra" (testc? testc))
     8(test "test property of extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))
    89
    910(define testc-extra-test (make-condition-property-accessor extra test))
     
    1213(test 'foobar (testc-extra-foo testc))
    1314
     15(use standard-conditions)
     16
     17(test-assert (exn-condition? testc))
     18(test 'test (exn-location testc))
     19(test "test" (exn-message testc))
     20(test '(test) (exn-arguments testc))
     21(test #f (exn-call-chain testc))
     22
    1423(test-exit)
Note: See TracChangeset for help on using the changeset viewer.