Changeset 33774 in project for release


Ignore:
Timestamp:
12/30/16 15:29:24 (2 years ago)
Author:
juergen
Message:

simple-exceptions with some routines from simple-contracts

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

Legend:

Unmodified
Added
Removed
  • release/4/simple-exceptions/tags/0.3/simple-exceptions.scm

    r33128 r33774  
    3636
    3737(module simple-exceptions
    38   (export simple-exceptions exception? exception-of? make-exception location
    39           message arguments raise with-exn-handler guard assert*)
     38  (simple-exceptions exception? exception-of? make-exception
     39   pre-exception post-exception << >> true? false?
     40   location message arguments raise with-exn-handler guard assert*)
    4041  (import scheme
    4142          (only chicken
     
    4344                make-property-condition make-composite-condition
    4445                get-condition-property continuation-capture
    45                 continuation-graft))
     46                continuation-graft error print))
    4647  (reexport (only chicken
    4748                  current-exception-handler handle-exceptions condition-case))
     
    8485             (map (lambda (kind) (make-property-condition kind))
    8586                  kind-keys)))))
     87
     88;;; exceptions
     89;;; ----------
     90(define pre-exception
     91  (make-exception "precondition violated" 'arguments))
     92(define post-exception
     93  (make-exception "postcondition violated" 'results))
     94
     95;;; (<< x x? ...)
     96;;; -------------
     97;;; pass in checked arguments in an and fashion
     98(define-syntax <<
     99  (ir-macro-transformer
     100    (lambda (form inject compare?)
     101      (let ((x (cadr form)) (checks (cddr form)))
     102        `(let ((arg ,x) (all-names ',checks))
     103           (let loop ((checks ,(cons 'list checks)) (names ',checks))
     104             (cond
     105               ((null? checks) arg) ; passed on success
     106               (((car checks) arg)
     107                (loop (cdr checks) (cdr names)))
     108               (else
     109                 (raise (pre-exception '<<
     110                                        arg
     111                                        all-names
     112                                        (car names)))))))))))
     113
     114;;; (>> x x? ...)
     115;;; -------------
     116;;; pass out checked returns in an and fashion
     117(define-syntax >>
     118  (ir-macro-transformer
     119    (lambda (form inject compare?)
     120      (let ((x (cadr form)) (checks (cddr form)))
     121        `(let ((return ,x) (all-names ',checks))
     122           (let loop ((checks ,(cons 'list checks)) (names ',checks))
     123             (cond
     124               ((null? checks) return) ; passed on success
     125               (((car checks) return)
     126                (loop (cdr checks) (cdr names)))
     127               (else
     128                 (raise (post-exception '>>
     129                                        return
     130                                        all-names
     131                                        (car names)))))))))))
    86132
    87133;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
     
    169215             (current-exception-handler old-handler)))))));)
    170216
     217(define (true? xpr) #t)
     218(define (false? xpr) #f)
     219
    171220;;; (simple-exceptions [sym])
    172221;;; -------------------------
    173222;;; documentation procedure
    174223(define simple-exceptions
    175   (let (
    176     (signatures '(
    177       (assert* loc xpr . xprs)
     224  (let ((als '(
     225    (simple-exceptions
     226      procedure:
     227      (simple-exceptions sym ..)
     228      "documentation procedure")
     229    (assert*
     230      macro:
     231      (assert* loc xpr ....)
     232      "checks, if its arguments xpr .... are  not #f")
     233    (exception?
     234      procedure:
    178235      (exception? xpr)
     236      "type predicate")
     237    (exception-of?
     238      procedure:
    179239      (exception-of? kind-key)
     240      "returns a predicate which checks, if its argument"
     241      "is an exception of kind kind-key")
     242    (make-exception
     243      procedure:
    180244      (make-exception msg . kind-keys)
     245      "returns a procedure with arguments loc and args"
     246      "Note, that msg and kind-keys are independent of a concrete use of"
     247      "this exception, while loc and args depend exactly on that use.")
     248    (location
     249      procedure:
    181250      (location exn)
     251      "returns the location property of its exception argument")
     252    (message
     253      procedure:
    182254      (message exn)
     255      "returns the message property of its exception argument")
     256    (arguments
     257      procedure:
    183258      (arguments exn)
     259      "returns the arguments property of its exception argument")
     260    (raise
     261      procedure:
    184262      (raise exn)
     263      "raises a non-continuable exception")
     264    (with-exn-handler
     265      procedure:
    185266      (with-exn-handler handler thunk)
     267      "wraps Chicken's with-exception-handler into pop-and-call"
     268      "to avoid the generation of infinite loops")
     269    (guard
     270      macro:
     271      (guard (exn cond-clause . cond-clauses) xpr . xprs)
     272      "R6RS and R7RS high-level exception-handler")
     273    (handle-exception
     274      macro:
    186275      (handle-exceptions exn handle-xpr xpr . xprs)
    187       (guard (exn cond-clause . cond-clauses) xpr . xprs)
    188       (condition-case xpr ([var] (kind ...) body) . other-clauses)))
    189     )
     276      "reexport of Chicken's routine")
     277    (condition-case
     278      macro:
     279      (condition-case xpr ([var] (kind ...) body) . other-clauses)
     280      "reexport of Chicken's macro")
     281    (<<
     282      macro:
     283      (<< x x? ...)
     284      "precondition test"
     285      "passes x unchanged only if all predicates x? return #t on it")
     286    (>>
     287      macro:
     288      (>> x x? ...)
     289      "postcondition test"
     290      "passes x unchanged only if all predicates x? return #t on it")
     291    (pre-exception
     292      exception:
     293      (pre-exception loc arg ...)
     294      "raised when a precondition is violated"
     295      "catched with (exn arguments)")
     296    (post-exception
     297      exception:
     298      (post-exception loc arg ...)
     299      "raised when a postcondition is violated"
     300      "catched with (exn results)")
     301    (true?
     302      procedure?
     303      (true? xpr)
     304      "returns always #t")
     305    (false?
     306      procedure?
     307      (false? xpr)
     308      "returns always #f")
     309    )))
    190310    (case-lambda
    191       (() (map car signatures))
    192       ((sym) (assq sym signatures)))))
     311      (()
     312       (map car als))
     313      ((sym)
     314       (let ((pair (assq sym als)))
     315         (if pair
     316           (for-each print (cdr pair))
     317           (error "Not in list"
     318                  sym
     319                  (map car als))))))))
    193320
    194321) ; module simple-exceptions
  • release/4/simple-exceptions/tags/0.3/simple-exceptions.setup

    r33128 r33774  
    77 'simple-exceptions
    88 '("simple-exceptions.so" "simple-exceptions.import.so")
    9  '((version "0.2")))
     9 '((version "0.3")))
  • release/4/simple-exceptions/tags/0.3/tests/run.scm

    r33128 r33774  
    44(define-test (simple-exceptions?)
    55  (check
     6    "CHECKS"
     7    (= (<< 5 integer? odd?) 5)
     8    (not (condition-case
     9           (>> 5 integer? even?)
     10           ((exn results) #f)))
     11    (not (<< ((lambda () #f)) boolean?))
     12
     13    "EXCEPTIONS"
    614    (define foo-exn (make-exception "foo-msg"))
    715    (define bar-exn (make-exception "bar-msg" 'bar))
     
    4351           ((exn list-empty) #f)))
    4452
     53    "GUARD"
    4554    (null? (guard
    4655             (exn (((exception-of? 'list-empty) exn)
  • release/4/simple-exceptions/trunk/simple-exceptions.scm

    r33128 r33774  
    3636
    3737(module simple-exceptions
    38   (export simple-exceptions exception? exception-of? make-exception location
    39           message arguments raise with-exn-handler guard assert*)
     38  (simple-exceptions exception? exception-of? make-exception
     39   pre-exception post-exception << >> true? false?
     40   location message arguments raise with-exn-handler guard assert*)
    4041  (import scheme
    4142          (only chicken
     
    4344                make-property-condition make-composite-condition
    4445                get-condition-property continuation-capture
    45                 continuation-graft))
     46                continuation-graft error print))
    4647  (reexport (only chicken
    4748                  current-exception-handler handle-exceptions condition-case))
     
    8485             (map (lambda (kind) (make-property-condition kind))
    8586                  kind-keys)))))
     87
     88;;; exceptions
     89;;; ----------
     90(define pre-exception
     91  (make-exception "precondition violated" 'arguments))
     92(define post-exception
     93  (make-exception "postcondition violated" 'results))
     94
     95;;; (<< x x? ...)
     96;;; -------------
     97;;; pass in checked arguments in an and fashion
     98(define-syntax <<
     99  (ir-macro-transformer
     100    (lambda (form inject compare?)
     101      (let ((x (cadr form)) (checks (cddr form)))
     102        `(let ((arg ,x) (all-names ',checks))
     103           (let loop ((checks ,(cons 'list checks)) (names ',checks))
     104             (cond
     105               ((null? checks) arg) ; passed on success
     106               (((car checks) arg)
     107                (loop (cdr checks) (cdr names)))
     108               (else
     109                 (raise (pre-exception '<<
     110                                        arg
     111                                        all-names
     112                                        (car names)))))))))))
     113
     114;;; (>> x x? ...)
     115;;; -------------
     116;;; pass out checked returns in an and fashion
     117(define-syntax >>
     118  (ir-macro-transformer
     119    (lambda (form inject compare?)
     120      (let ((x (cadr form)) (checks (cddr form)))
     121        `(let ((return ,x) (all-names ',checks))
     122           (let loop ((checks ,(cons 'list checks)) (names ',checks))
     123             (cond
     124               ((null? checks) return) ; passed on success
     125               (((car checks) return)
     126                (loop (cdr checks) (cdr names)))
     127               (else
     128                 (raise (post-exception '>>
     129                                        return
     130                                        all-names
     131                                        (car names)))))))))))
    86132
    87133;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
     
    169215             (current-exception-handler old-handler)))))));)
    170216
     217(define (true? xpr) #t)
     218(define (false? xpr) #f)
     219
    171220;;; (simple-exceptions [sym])
    172221;;; -------------------------
    173222;;; documentation procedure
    174223(define simple-exceptions
    175   (let (
    176     (signatures '(
    177       (assert* loc xpr . xprs)
     224  (let ((als '(
     225    (simple-exceptions
     226      procedure:
     227      (simple-exceptions sym ..)
     228      "documentation procedure")
     229    (assert*
     230      macro:
     231      (assert* loc xpr ....)
     232      "checks, if its arguments xpr .... are  not #f")
     233    (exception?
     234      procedure:
    178235      (exception? xpr)
     236      "type predicate")
     237    (exception-of?
     238      procedure:
    179239      (exception-of? kind-key)
     240      "returns a predicate which checks, if its argument"
     241      "is an exception of kind kind-key")
     242    (make-exception
     243      procedure:
    180244      (make-exception msg . kind-keys)
     245      "returns a procedure with arguments loc and args"
     246      "Note, that msg and kind-keys are independent of a concrete use of"
     247      "this exception, while loc and args depend exactly on that use.")
     248    (location
     249      procedure:
    181250      (location exn)
     251      "returns the location property of its exception argument")
     252    (message
     253      procedure:
    182254      (message exn)
     255      "returns the message property of its exception argument")
     256    (arguments
     257      procedure:
    183258      (arguments exn)
     259      "returns the arguments property of its exception argument")
     260    (raise
     261      procedure:
    184262      (raise exn)
     263      "raises a non-continuable exception")
     264    (with-exn-handler
     265      procedure:
    185266      (with-exn-handler handler thunk)
     267      "wraps Chicken's with-exception-handler into pop-and-call"
     268      "to avoid the generation of infinite loops")
     269    (guard
     270      macro:
     271      (guard (exn cond-clause . cond-clauses) xpr . xprs)
     272      "R6RS and R7RS high-level exception-handler")
     273    (handle-exception
     274      macro:
    186275      (handle-exceptions exn handle-xpr xpr . xprs)
    187       (guard (exn cond-clause . cond-clauses) xpr . xprs)
    188       (condition-case xpr ([var] (kind ...) body) . other-clauses)))
    189     )
     276      "reexport of Chicken's routine")
     277    (condition-case
     278      macro:
     279      (condition-case xpr ([var] (kind ...) body) . other-clauses)
     280      "reexport of Chicken's macro")
     281    (<<
     282      macro:
     283      (<< x x? ...)
     284      "precondition test"
     285      "passes x unchanged only if all predicates x? return #t on it")
     286    (>>
     287      macro:
     288      (>> x x? ...)
     289      "postcondition test"
     290      "passes x unchanged only if all predicates x? return #t on it")
     291    (pre-exception
     292      exception:
     293      (pre-exception loc arg ...)
     294      "raised when a precondition is violated"
     295      "catched with (exn arguments)")
     296    (post-exception
     297      exception:
     298      (post-exception loc arg ...)
     299      "raised when a postcondition is violated"
     300      "catched with (exn results)")
     301    (true?
     302      procedure?
     303      (true? xpr)
     304      "returns always #t")
     305    (false?
     306      procedure?
     307      (false? xpr)
     308      "returns always #f")
     309    )))
    190310    (case-lambda
    191       (() (map car signatures))
    192       ((sym) (assq sym signatures)))))
     311      (()
     312       (map car als))
     313      ((sym)
     314       (let ((pair (assq sym als)))
     315         (if pair
     316           (for-each print (cdr pair))
     317           (error "Not in list"
     318                  sym
     319                  (map car als))))))))
    193320
    194321) ; module simple-exceptions
  • release/4/simple-exceptions/trunk/simple-exceptions.setup

    r33128 r33774  
    77 'simple-exceptions
    88 '("simple-exceptions.so" "simple-exceptions.import.so")
    9  '((version "0.2")))
     9 '((version "0.3")))
  • release/4/simple-exceptions/trunk/tests/run.scm

    r33128 r33774  
    44(define-test (simple-exceptions?)
    55  (check
     6    "CHECKS"
     7    (= (<< 5 integer? odd?) 5)
     8    (not (condition-case
     9           (>> 5 integer? even?)
     10           ((exn results) #f)))
     11    (not (<< ((lambda () #f)) boolean?))
     12
     13    "EXCEPTIONS"
    614    (define foo-exn (make-exception "foo-msg"))
    715    (define bar-exn (make-exception "bar-msg" 'bar))
     
    4351           ((exn list-empty) #f)))
    4452
     53    "GUARD"
    4554    (null? (guard
    4655             (exn (((exception-of? 'list-empty) exn)
Note: See TracChangeset for help on using the changeset viewer.