Changeset 37040 in project


Ignore:
Timestamp:
01/15/19 12:49:21 (11 months ago)
Author:
juergen
Message:

simple-exceptions 1.2 improve argument and result checks

Location:
release/5/simple-exceptions
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed

  • release/5/simple-exceptions/tags/1.2/simple-exceptions.egg

    r36637 r37040  
    44 (test-dependencies simple-tests)
    55 (author "Juergen Lorenz")
    6  (version "1.1")
     6 (version "1.2")
    77 (components (extension simple-exceptions)))

  • release/5/simple-exceptions/tags/1.2/simple-exceptions.scm

    r36637 r37040  
    33ju (at) jugilo (dot) de
    44
    5 Copyright (c) 2014-2018, Juergen Lorenz
     5Copyright (c) 2014-2019, Juergen Lorenz
    66All rights reserved.
    77
    … …  
    116116       name))))
    117117
    118 ;;; (<<< loc)
    119 ;;; ---------
     118;;; (<<< loc [arg-name])
     119;;; --------------------
    120120;;; returns a localized argument checker (<< arg . preds)
    121 ;;; at location loc
    122 (define (<<< loc)
     121;;; at location loc with name arg-name
     122(define (<<< loc . arg-name)
    123123  (case-lambda
    124124    (() '())
    … …  
    126126     (if (null? preds)
    127127       arg
    128        (let ((arg-name (if (symbol? (car preds)) (car preds) #f))
     128       (let ((name (cond
     129                     ((symbol? (car preds)) (car preds)) ; deprecated
     130                     ((not (null? arg-name)) (car arg-name))
     131                     (else #f)))
    129132             (preds (if (symbol? (car preds)) (cdr preds) preds)))
    130133         (let loop ((preds preds))
    … …  
    135138              (loop (cdr preds)))
    136139             (else
    137                (if arg-name
    138                  (raise (argument-exception loc arg-name arg (car preds)))
    139                  (raise (argument-exception loc arg (car
    140                                                       preds))))))))))))
     140               (if name
     141                 (raise (argument-exception loc name arg (car preds)))
     142                 (raise (argument-exception loc arg (car preds)))
     143                 )))))))))
    141144
    142145;;; (<< arg [arg-name] arg? ...)
    143146;;; ----------------------------
    144147;;; pass in a checked argument in an and fashion
    145 ;(define (<< arg . preds)
    146 ;  (apply (<<< '<<) arg preds))
    147148(define <<
    148149  (case-lambda
    149150    (() '())
    150151    ((arg . preds)
    151      (apply (<<< '<<) arg preds))))
    152 
    153 ;;; (>>> loc)
    154 ;;; ---------
     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;;; -----------------------
    155160;;; returns a localized result checker (>> result . preds)
    156161;;; at location loc
    157 (define (>>> loc)
    158   (lambda (result . preds)
    159     (if (null? preds)
    160       result
    161       (let ((result-name (if (symbol? (car preds)) (car preds) #f))
    162             (preds (if (symbol? (car preds)) (cdr preds) preds)))
    163         (let loop ((preds preds))
    164           (cond
    165             ((null? preds)
    166              result)
    167             (((car preds) result)
    168              (loop (cdr preds)))
    169             (else
    170               (if result-name
    171                 (raise (result-exception loc result-name result (car preds)))
    172                 (raise (result-exception loc 'result result (car preds)))))))))))
     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                 )))))))))
    173184
    174185;;; (>> result [result-name] result? ...)
    175186;;; -------------------------------------
    176187;;; pass out a checked result in an and fashion
    177 (define (>> result . preds)
    178   (apply (>>> '>>) result preds))
     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))))))
    179197
    180198;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
    … …  
    348366    (<<<
    349367      procedure:
    350       (<<< loc)
     368      (<<< loc [arg-name])
    351369      "returns a localized precondition test"
    352370      "(<< arg [arg-name] arg? ...)"
    353       "at location loc")
     371      "at location loc with name arg-name")
    354372    (<<
    355373      procedure:
    … …  
    360378    (>>>
    361379      procedure:
    362       (>>> loc)
     380      (>>> loc [result-name])
    363381      "returns a localized postcondition test"
    364382      "(>> result [result-name] result? ...)"
    365       "at location loc")
     383      "at location loc with name result-name")
    366384    (>>
    367385      procedure:

  • release/5/simple-exceptions/tags/1.2/tests/run.scm

    r36637 r37040  
    2929  (= (<< 5) 5)
    3030  (= (<< 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)
    3135  (not (condition-case
    3236         (>> 5 integer? even?)

  • release/5/simple-exceptions/trunk/simple-exceptions.egg

    r36637 r37040  
    44 (test-dependencies simple-tests)
    55 (author "Juergen Lorenz")
    6  (version "1.1")
     6 (version "1.2")
    77 (components (extension simple-exceptions)))

  • release/5/simple-exceptions/trunk/simple-exceptions.scm

    r36637 r37040  
    33ju (at) jugilo (dot) de
    44
    5 Copyright (c) 2014-2018, Juergen Lorenz
     5Copyright (c) 2014-2019, Juergen Lorenz
    66All rights reserved.
    77
    … …  
    116116       name))))
    117117
    118 ;;; (<<< loc)
    119 ;;; ---------
     118;;; (<<< loc [arg-name])
     119;;; --------------------
    120120;;; returns a localized argument checker (<< arg . preds)
    121 ;;; at location loc
    122 (define (<<< loc)
     121;;; at location loc with name arg-name
     122(define (<<< loc . arg-name)
    123123  (case-lambda
    124124    (() '())
    … …  
    126126     (if (null? preds)
    127127       arg
    128        (let ((arg-name (if (symbol? (car preds)) (car preds) #f))
     128       (let ((name (cond
     129                     ((symbol? (car preds)) (car preds)) ; deprecated
     130                     ((not (null? arg-name)) (car arg-name))
     131                     (else #f)))
    129132             (preds (if (symbol? (car preds)) (cdr preds) preds)))
    130133         (let loop ((preds preds))
    … …  
    135138              (loop (cdr preds)))
    136139             (else
    137                (if arg-name
    138                  (raise (argument-exception loc arg-name arg (car preds)))
    139                  (raise (argument-exception loc arg (car
    140                                                       preds))))))))))))
     140               (if name
     141                 (raise (argument-exception loc name arg (car preds)))
     142                 (raise (argument-exception loc arg (car preds)))
     143                 )))))))))
    141144
    142145;;; (<< arg [arg-name] arg? ...)
    143146;;; ----------------------------
    144147;;; pass in a checked argument in an and fashion
    145 ;(define (<< arg . preds)
    146 ;  (apply (<<< '<<) arg preds))
    147148(define <<
    148149  (case-lambda
    149150    (() '())
    150151    ((arg . preds)
    151      (apply (<<< '<<) arg preds))))
    152 
    153 ;;; (>>> loc)
    154 ;;; ---------
     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;;; -----------------------
    155160;;; returns a localized result checker (>> result . preds)
    156161;;; at location loc
    157 (define (>>> loc)
    158   (lambda (result . preds)
    159     (if (null? preds)
    160       result
    161       (let ((result-name (if (symbol? (car preds)) (car preds) #f))
    162             (preds (if (symbol? (car preds)) (cdr preds) preds)))
    163         (let loop ((preds preds))
    164           (cond
    165             ((null? preds)
    166              result)
    167             (((car preds) result)
    168              (loop (cdr preds)))
    169             (else
    170               (if result-name
    171                 (raise (result-exception loc result-name result (car preds)))
    172                 (raise (result-exception loc 'result result (car preds)))))))))))
     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                 )))))))))
    173184
    174185;;; (>> result [result-name] result? ...)
    175186;;; -------------------------------------
    176187;;; pass out a checked result in an and fashion
    177 (define (>> result . preds)
    178   (apply (>>> '>>) result preds))
     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))))))
    179197
    180198;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
    … …  
    348366    (<<<
    349367      procedure:
    350       (<<< loc)
     368      (<<< loc [arg-name])
    351369      "returns a localized precondition test"
    352370      "(<< arg [arg-name] arg? ...)"
    353       "at location loc")
     371      "at location loc with name arg-name")
    354372    (<<
    355373      procedure:
    … …  
    360378    (>>>
    361379      procedure:
    362       (>>> loc)
     380      (>>> loc [result-name])
    363381      "returns a localized postcondition test"
    364382      "(>> result [result-name] result? ...)"
    365       "at location loc")
     383      "at location loc with name result-name")
    366384    (>>
    367385      procedure:

  • release/5/simple-exceptions/trunk/tests/run.scm

    r36637 r37040  
    2929  (= (<< 5) 5)
    3030  (= (<< 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)
    3135  (not (condition-case
    3236         (>> 5 integer? even?)
Note: See TracChangeset for help on using the changeset viewer.