Changeset 37196 in project


Ignore:
Timestamp:
02/02/19 17:10:12 (3 months ago)
Author:
juergen
Message:

simple-exceptions 1.3 with outsourced checks

Location:
release/5/simple-exceptions
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/5/simple-exceptions/tags/1.3/simple-exceptions.egg

    r37040 r37196  
    44 (test-dependencies simple-tests)
    55 (author "Juergen Lorenz")
    6  (version "1.2")
     6 (version "1.3")
    77 (components (extension simple-exceptions)))
  • release/5/simple-exceptions/tags/1.3/simple-exceptions.scm

    r37040 r37196  
    3939   assert-exception argument-exception result-exception
    4040   exn? exn-of? make-exn argument-exn result-exn assert-exn
    41    << >> <<< >>> true? false? named-lambda
    42    location message arguments raise with-exn-handler guard assert*)
    43 
    44   (import scheme (only (chicken base) void print case-lambda error)
     41   location message arguments raise with-exn-handler guard)
     42
     43  (import scheme (only (chicken base) assert void print case-lambda error)
    4544                 (chicken condition)
    4645                 (chicken module)
     
    106105(define assert-exn assert-exception)
    107106
    108 ;;; (named-lambda (name . args) xpr . xprs)
    109 ;;; -----------------------------------
    110 ;;; can replace anonymous procedures in << and >>
    111 ;;; to improve error messages
    112 (define-syntax named-lambda
    113   (syntax-rules ()
    114     ((_ (name . args) xpr . xprs)
    115      (letrec ((name (lambda args xpr . xprs)))
    116        name))))
    117 
    118 ;;; (<<< loc [arg-name])
    119 ;;; --------------------
    120 ;;; returns a localized argument checker (<< arg . preds)
    121 ;;; at location loc with name arg-name
    122 (define (<<< loc . arg-name)
    123   (case-lambda
    124     (() '())
    125     ((arg . preds)
    126      (if (null? preds)
    127        arg
    128        (let ((name (cond
    129                      ((symbol? (car preds)) (car preds)) ; deprecated
    130                      ((not (null? arg-name)) (car arg-name))
    131                      (else #f)))
    132              (preds (if (symbol? (car preds)) (cdr preds) preds)))
    133          (let loop ((preds preds))
    134            (cond
    135              ((null? preds)
    136               arg)
    137              (((car preds) arg)
    138               (loop (cdr preds)))
    139              (else
    140                (if name
    141                  (raise (argument-exception loc name arg (car preds)))
    142                  (raise (argument-exception loc arg (car preds)))
    143                  )))))))))
    144 
    145 ;;; (<< arg [arg-name] arg? ...)
    146 ;;; ----------------------------
    147 ;;; pass in a checked argument in an and fashion
    148 (define <<
    149   (case-lambda
    150     (() '())
    151     ((arg . preds)
    152      (if (null? preds)
    153        arg
    154        (if (symbol? (car preds)) ; deprecated
    155          (apply (<<< '<< (car preds)) arg (cdr preds))
    156          (apply (<<< '<<) arg preds))))))
    157 
    158 ;;; (>>> loc [result-name])
    159 ;;; -----------------------
    160 ;;; returns a localized result checker (>> result . preds)
    161 ;;; at location loc
    162 (define (>>> loc . result-name)
    163   (case-lambda
    164     (() '())
    165     ((result . preds)
    166      (if (null? preds)
    167        result
    168        (let ((name (cond
    169                      ((symbol? (car preds)) (car preds)) ; deprecated
    170                      ((not (null? result-name)) (car result-name))
    171                      (else #f)))
    172              (preds (if (symbol? (car preds)) (cdr preds) preds)))
    173          (let loop ((preds preds))
    174            (cond
    175              ((null? preds)
    176               result)
    177              (((car preds) result)
    178               (loop (cdr preds)))
    179              (else
    180                (if name
    181                  (raise (result-exception loc name result (car preds)))
    182                  (raise (result-exception loc result (car preds)))
    183                  )))))))))
    184 
    185 ;;; (>> result [result-name] result? ...)
    186 ;;; -------------------------------------
    187 ;;; pass out a checked result in an and fashion
    188 (define >>
    189   (case-lambda
    190     (() '())
    191     ((result . preds)
    192      (if (null? preds)
    193        result
    194        (if (symbol? (car preds)) ; deprecated
    195          (apply (>>> '>> (car preds)) result (cdr preds))
    196          (apply (>>> '>>) result preds))))))
    197 
    198107;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
    199108;;; ---------------------------------------------------
     
    204113     (handle-exceptions exn (cond cond-clause . cond-clauses)
    205114                        xpr . xprs))))
    206 
    207 ;;; (assert* loc xpr . xprs)
    208 ;;; ------------------------
    209 ;;; checks, if its arguments xpr . xprs are not #f.
    210 (define-syntax assert*
    211   (syntax-rules ()
    212     ((_ loc)
    213      (void))
    214     ((_ loc xpr . xprs)
    215      (if xpr
    216        (assert* loc . xprs)
    217        (raise (assert-exception loc 'xpr))))))
    218        ;(raise ((make-exception "assertion violated" 'assert)
    219        ;        loc 'xpr))))))
    220 
    221115;;; (location exn)
    222116;;; --------------
    223117;;; returns the location property of its exception argument
    224118(define (location exn)
    225   (assert* 'location (exception? exn))
     119  (assert (exception? exn)
     120    'location "assertion failed" '(exception?  exn))
    226121  (get-condition-property exn 'exn 'location 'unknown))
    227122
     
    230125;;; returns the message property of its exception argument
    231126(define (message exn)
    232   (assert* 'message (exception? exn))
     127  (assert (exception? exn)
     128    'message "assertion failed" '(exception?  exn))
    233129  (get-condition-property exn 'exn 'message "no message supplied"))
    234130
     
    237133;;; returns the arguments property of its exception argument
    238134(define (arguments exn)
    239   (assert* 'arguments (exception? exn))
     135  (assert (exception? exn)
     136    'arguments "assertion failed" '(exception?  exn))
    240137  (get-condition-property exn 'exn 'arguments '()))
    241138
     
    270167           (k (lambda () (handler exn))))
    271168         thunk)))))
    272 ;(define (with-exn-handler handler thunk)
    273 ;  (continuation-capture
    274 ;     (lambda (k)
    275 ;       (let ((old-handler (current-exception-handler)))
    276 ;         (dynamic-wind
    277 ;           (lambda ()
    278 ;             (current-exception-handler
    279 ;               (lambda (exn)
    280 ;                 (continuation-graft k (lambda () (handler exn))))))
    281 ;           thunk
    282 ;           (lambda ()
    283 ;             (current-exception-handler old-handler)))))))
    284 
    285 (define (true? xpr) #t)
    286 (define (false? xpr) #f)
    287169
    288170;;; (simple-exceptions [sym])
     
    295177      (simple-exceptions sym ..)
    296178      "documentation procedure")
    297     (assert*
    298       macro:
    299       (assert* loc xpr ....)
    300       "checks, if its arguments xpr .... are  not #f")
    301179    (exception?
    302180      procedure:
     
    359237      (condition-case xpr ([var] (kind ...) body) . other-clauses)
    360238      "reexport of Chicken's macro")
    361     (named-lambda
    362       macro:
    363       (named-lambda name args xpr . xprs)
    364       "can be used in place of lambda,"
    365       "possibly improving error messages")
    366     (<<<
    367       procedure:
    368       (<<< loc [arg-name])
    369       "returns a localized precondition test"
    370       "(<< arg [arg-name] arg? ...)"
    371       "at location loc with name arg-name")
    372     (<<
    373       procedure:
    374       (<< arg [arg-name] arg? ...)
    375       "precondition test"
    376       "passes arg unchanged only if all predicates arg? return #t on it"
    377       "or raises a argument-exception at location '<<")
    378     (>>>
    379       procedure:
    380       (>>> loc [result-name])
    381       "returns a localized postcondition test"
    382       "(>> result [result-name] result? ...)"
    383       "at location loc with name result-name")
    384     (>>
    385       procedure:
    386       (>> result [result-name] result? ...)
    387       "postcondition test"
    388       "passes result unchanged only if all predicates result? return #t on it"
    389       "or raises a result-exception at location '>>")
    390239    (argument-exception
    391240      exception:
     
    415264      (assert-exn loc arg ...)
    416265      "alias to assert-exception")
    417     (true?
    418       procedure?
    419       (true? xpr)
    420       "returns always #t")
    421     (false?
    422       procedure?
    423       (false? xpr)
    424       "returns always #f")
    425266    )))
    426267    (case-lambda
  • release/5/simple-exceptions/tags/1.3/tests/run.scm

    r37040 r37196  
    11(import simple-tests simple-exceptions)
    2 
    3   (define (baz n)
    4     (abs (<< n 'baz number?)))
    52
    63  (define foo-exn (make-exn "foo-msg"))
     
    1714
    1815(define-test (simple-exceptions?)
    19   "NAMED LAMBDA"
    20   (= ((named-lambda (! n)
    21         (if (zero? n)
    22           1
    23           (* n (! (- n 1)))))
    24       5)
    25      120)
    26   "CHECKS"
    27   (null? (<<))
    28   (= (>> 5) 5)
    29   (= (<< 5) 5)
    30   (= (<< 5 integer? odd? (named-lambda (5<= x) (<= 5 x))) 5)
    31   (= ((<<< 'foo 'x) 5 integer? odd?) 5)
    32   (= ((<<< 'foo) 5 integer? odd?) 5)
    33   (= ((>>> 'foo 'x) 5 integer? odd?) 5)
    34   (= ((>>> 'foo) 5 integer? odd?) 5)
    35   (not (condition-case
    36          (>> 5 integer? even?)
    37          ((exn result) #f)))
    38   (not (<< ((lambda () #f)) boolean?))
    39   '(define (baz n) (abs (<< n 'baz number?)))
    40   (not (condition-case (baz "baz")
    41          ((exn argument) #f)))
    42   (not (with-exn-handler
    43          (lambda (exn)
    44            (if ((exn-of? 'argument) exn)
    45              #f
    46              #t))
    47          (lambda () (baz "baz"))))
    48 
    49   "EXCEPTIONS"
    5016  '(define foo-exn (make-exn "foo-msg"))
    5117  '(define bar-exn (make-exn "bar-msg" 'bar))
     
    5824  (not ((exn-of? 'bar) (foo-exn 'nowhere)))
    5925 
    60   (equal?
    61     (arguments ((make-exn "msg" 'baz) 'nowhere "bar"))
    62     (list "bar"))
    63 
    6426  ((exn-of? 'key)
    6527   ((make-exn "msg" 'key) 'nowhere))
     
    146108              (raise 'bar)))
    147109
    148   (not (condition-case (assert* 'nowhere
    149                                 (= 1 1)
    150                                 (= 1 2))
    151          ((exn assert) #f)))
    152110  )
    153111
  • release/5/simple-exceptions/trunk/simple-exceptions.egg

    r37040 r37196  
    44 (test-dependencies simple-tests)
    55 (author "Juergen Lorenz")
    6  (version "1.2")
     6 (version "1.3")
    77 (components (extension simple-exceptions)))
  • release/5/simple-exceptions/trunk/simple-exceptions.scm

    r37040 r37196  
    3939   assert-exception argument-exception result-exception
    4040   exn? exn-of? make-exn argument-exn result-exn assert-exn
    41    << >> <<< >>> true? false? named-lambda
    42    location message arguments raise with-exn-handler guard assert*)
    43 
    44   (import scheme (only (chicken base) void print case-lambda error)
     41   location message arguments raise with-exn-handler guard)
     42
     43  (import scheme (only (chicken base) assert void print case-lambda error)
    4544                 (chicken condition)
    4645                 (chicken module)
     
    106105(define assert-exn assert-exception)
    107106
    108 ;;; (named-lambda (name . args) xpr . xprs)
    109 ;;; -----------------------------------
    110 ;;; can replace anonymous procedures in << and >>
    111 ;;; to improve error messages
    112 (define-syntax named-lambda
    113   (syntax-rules ()
    114     ((_ (name . args) xpr . xprs)
    115      (letrec ((name (lambda args xpr . xprs)))
    116        name))))
    117 
    118 ;;; (<<< loc [arg-name])
    119 ;;; --------------------
    120 ;;; returns a localized argument checker (<< arg . preds)
    121 ;;; at location loc with name arg-name
    122 (define (<<< loc . arg-name)
    123   (case-lambda
    124     (() '())
    125     ((arg . preds)
    126      (if (null? preds)
    127        arg
    128        (let ((name (cond
    129                      ((symbol? (car preds)) (car preds)) ; deprecated
    130                      ((not (null? arg-name)) (car arg-name))
    131                      (else #f)))
    132              (preds (if (symbol? (car preds)) (cdr preds) preds)))
    133          (let loop ((preds preds))
    134            (cond
    135              ((null? preds)
    136               arg)
    137              (((car preds) arg)
    138               (loop (cdr preds)))
    139              (else
    140                (if name
    141                  (raise (argument-exception loc name arg (car preds)))
    142                  (raise (argument-exception loc arg (car preds)))
    143                  )))))))))
    144 
    145 ;;; (<< arg [arg-name] arg? ...)
    146 ;;; ----------------------------
    147 ;;; pass in a checked argument in an and fashion
    148 (define <<
    149   (case-lambda
    150     (() '())
    151     ((arg . preds)
    152      (if (null? preds)
    153        arg
    154        (if (symbol? (car preds)) ; deprecated
    155          (apply (<<< '<< (car preds)) arg (cdr preds))
    156          (apply (<<< '<<) arg preds))))))
    157 
    158 ;;; (>>> loc [result-name])
    159 ;;; -----------------------
    160 ;;; returns a localized result checker (>> result . preds)
    161 ;;; at location loc
    162 (define (>>> loc . result-name)
    163   (case-lambda
    164     (() '())
    165     ((result . preds)
    166      (if (null? preds)
    167        result
    168        (let ((name (cond
    169                      ((symbol? (car preds)) (car preds)) ; deprecated
    170                      ((not (null? result-name)) (car result-name))
    171                      (else #f)))
    172              (preds (if (symbol? (car preds)) (cdr preds) preds)))
    173          (let loop ((preds preds))
    174            (cond
    175              ((null? preds)
    176               result)
    177              (((car preds) result)
    178               (loop (cdr preds)))
    179              (else
    180                (if name
    181                  (raise (result-exception loc name result (car preds)))
    182                  (raise (result-exception loc result (car preds)))
    183                  )))))))))
    184 
    185 ;;; (>> result [result-name] result? ...)
    186 ;;; -------------------------------------
    187 ;;; pass out a checked result in an and fashion
    188 (define >>
    189   (case-lambda
    190     (() '())
    191     ((result . preds)
    192      (if (null? preds)
    193        result
    194        (if (symbol? (car preds)) ; deprecated
    195          (apply (>>> '>> (car preds)) result (cdr preds))
    196          (apply (>>> '>>) result preds))))))
    197 
    198107;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
    199108;;; ---------------------------------------------------
     
    204113     (handle-exceptions exn (cond cond-clause . cond-clauses)
    205114                        xpr . xprs))))
    206 
    207 ;;; (assert* loc xpr . xprs)
    208 ;;; ------------------------
    209 ;;; checks, if its arguments xpr . xprs are not #f.
    210 (define-syntax assert*
    211   (syntax-rules ()
    212     ((_ loc)
    213      (void))
    214     ((_ loc xpr . xprs)
    215      (if xpr
    216        (assert* loc . xprs)
    217        (raise (assert-exception loc 'xpr))))))
    218        ;(raise ((make-exception "assertion violated" 'assert)
    219        ;        loc 'xpr))))))
    220 
    221115;;; (location exn)
    222116;;; --------------
    223117;;; returns the location property of its exception argument
    224118(define (location exn)
    225   (assert* 'location (exception? exn))
     119  (assert (exception? exn)
     120    'location "assertion failed" '(exception?  exn))
    226121  (get-condition-property exn 'exn 'location 'unknown))
    227122
     
    230125;;; returns the message property of its exception argument
    231126(define (message exn)
    232   (assert* 'message (exception? exn))
     127  (assert (exception? exn)
     128    'message "assertion failed" '(exception?  exn))
    233129  (get-condition-property exn 'exn 'message "no message supplied"))
    234130
     
    237133;;; returns the arguments property of its exception argument
    238134(define (arguments exn)
    239   (assert* 'arguments (exception? exn))
     135  (assert (exception? exn)
     136    'arguments "assertion failed" '(exception?  exn))
    240137  (get-condition-property exn 'exn 'arguments '()))
    241138
     
    270167           (k (lambda () (handler exn))))
    271168         thunk)))))
    272 ;(define (with-exn-handler handler thunk)
    273 ;  (continuation-capture
    274 ;     (lambda (k)
    275 ;       (let ((old-handler (current-exception-handler)))
    276 ;         (dynamic-wind
    277 ;           (lambda ()
    278 ;             (current-exception-handler
    279 ;               (lambda (exn)
    280 ;                 (continuation-graft k (lambda () (handler exn))))))
    281 ;           thunk
    282 ;           (lambda ()
    283 ;             (current-exception-handler old-handler)))))))
    284 
    285 (define (true? xpr) #t)
    286 (define (false? xpr) #f)
    287169
    288170;;; (simple-exceptions [sym])
     
    295177      (simple-exceptions sym ..)
    296178      "documentation procedure")
    297     (assert*
    298       macro:
    299       (assert* loc xpr ....)
    300       "checks, if its arguments xpr .... are  not #f")
    301179    (exception?
    302180      procedure:
     
    359237      (condition-case xpr ([var] (kind ...) body) . other-clauses)
    360238      "reexport of Chicken's macro")
    361     (named-lambda
    362       macro:
    363       (named-lambda name args xpr . xprs)
    364       "can be used in place of lambda,"
    365       "possibly improving error messages")
    366     (<<<
    367       procedure:
    368       (<<< loc [arg-name])
    369       "returns a localized precondition test"
    370       "(<< arg [arg-name] arg? ...)"
    371       "at location loc with name arg-name")
    372     (<<
    373       procedure:
    374       (<< arg [arg-name] arg? ...)
    375       "precondition test"
    376       "passes arg unchanged only if all predicates arg? return #t on it"
    377       "or raises a argument-exception at location '<<")
    378     (>>>
    379       procedure:
    380       (>>> loc [result-name])
    381       "returns a localized postcondition test"
    382       "(>> result [result-name] result? ...)"
    383       "at location loc with name result-name")
    384     (>>
    385       procedure:
    386       (>> result [result-name] result? ...)
    387       "postcondition test"
    388       "passes result unchanged only if all predicates result? return #t on it"
    389       "or raises a result-exception at location '>>")
    390239    (argument-exception
    391240      exception:
     
    415264      (assert-exn loc arg ...)
    416265      "alias to assert-exception")
    417     (true?
    418       procedure?
    419       (true? xpr)
    420       "returns always #t")
    421     (false?
    422       procedure?
    423       (false? xpr)
    424       "returns always #f")
    425266    )))
    426267    (case-lambda
  • release/5/simple-exceptions/trunk/tests/run.scm

    r37040 r37196  
    11(import simple-tests simple-exceptions)
    2 
    3   (define (baz n)
    4     (abs (<< n 'baz number?)))
    52
    63  (define foo-exn (make-exn "foo-msg"))
     
    1714
    1815(define-test (simple-exceptions?)
    19   "NAMED LAMBDA"
    20   (= ((named-lambda (! n)
    21         (if (zero? n)
    22           1
    23           (* n (! (- n 1)))))
    24       5)
    25      120)
    26   "CHECKS"
    27   (null? (<<))
    28   (= (>> 5) 5)
    29   (= (<< 5) 5)
    30   (= (<< 5 integer? odd? (named-lambda (5<= x) (<= 5 x))) 5)
    31   (= ((<<< 'foo 'x) 5 integer? odd?) 5)
    32   (= ((<<< 'foo) 5 integer? odd?) 5)
    33   (= ((>>> 'foo 'x) 5 integer? odd?) 5)
    34   (= ((>>> 'foo) 5 integer? odd?) 5)
    35   (not (condition-case
    36          (>> 5 integer? even?)
    37          ((exn result) #f)))
    38   (not (<< ((lambda () #f)) boolean?))
    39   '(define (baz n) (abs (<< n 'baz number?)))
    40   (not (condition-case (baz "baz")
    41          ((exn argument) #f)))
    42   (not (with-exn-handler
    43          (lambda (exn)
    44            (if ((exn-of? 'argument) exn)
    45              #f
    46              #t))
    47          (lambda () (baz "baz"))))
    48 
    49   "EXCEPTIONS"
    5016  '(define foo-exn (make-exn "foo-msg"))
    5117  '(define bar-exn (make-exn "bar-msg" 'bar))
     
    5824  (not ((exn-of? 'bar) (foo-exn 'nowhere)))
    5925 
    60   (equal?
    61     (arguments ((make-exn "msg" 'baz) 'nowhere "bar"))
    62     (list "bar"))
    63 
    6426  ((exn-of? 'key)
    6527   ((make-exn "msg" 'key) 'nowhere))
     
    146108              (raise 'bar)))
    147109
    148   (not (condition-case (assert* 'nowhere
    149                                 (= 1 1)
    150                                 (= 1 2))
    151          ((exn assert) #f)))
    152110  )
    153111
Note: See TracChangeset for help on using the changeset viewer.