Changeset 37191 in project


Ignore:
Timestamp:
02/02/19 15:50:42 (7 months ago)
Author:
juergen
Message:

checks 1.1 with additional procedure versions of macros

Location:
release/5/checks
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/checks/tags/1.1/checks.egg

    r37164 r37191  
    55 (test-dependencies simple-tests)
    66 (author "[[/users/juergen-lorenz|Juergen Lorenz]]")
    7  (version "1.0")
     7 (version "1.1")
    88 (components (extension checks)))
    99
  • release/5/checks/tags/1.1/checks.scm

    r37164 r37191  
    3535
    3636
    37 (module checks (assert* << >> <<< >>> true? false?)
     37(module checks (checks assert*
     38                <<% << >>% >> <<<% <<< >>>% >>>
     39                 true? false? named-lambda)
    3840  (import scheme (only (chicken base) assert print case-lambda error))
    3941
     
    4951    ))
    5052
    51 ;;;;; (<<< loc arg-name arg . preds)
    52 ;;;;; ------------------------------
    53 ;;;;; pass in an argument, arg, after having it checked against each
    54 ;;;;; predicate in sequence
    55 ;;;;; loc and arg-name are used only in the error message.
    56 ;;;(define (<<< loc name arg . preds)
    57 ;;;  (let loop ((preds preds))
    58 ;;;    (cond
    59 ;;;      ((null? preds)
    60 ;;;       arg)
    61 ;;;      (((car preds) arg)
    62 ;;;       (loop (cdr preds)))
    63 ;;;      (else
    64 ;;;        (error loc "precondition violated" name arg (car preds))
    65 ;;;        ))))
    66 ;;;;;; (<< arg-name arg arg? ...)
    67 ;;;;;; --------------------------
    68 ;;;;;; pass in an argument, arg, after having it checked against each
    69 ;;;;;; predicate, arg?, in sequence
    70 ;;;;;; arg-name is used only in the error message.
    71 ;;;(define (<< name arg . preds)
    72 ;;;  (apply <<< '<< name arg preds))
    73 
    74 
    75 (define-syntax ===  ; hidden
    76   (syntax-rules ()
    77     ((_ msg loc x) x)
    78     ((_ msg loc x x?)
    79      (if (x? x)
    80        x
    81        (error loc msg 'x x x?)))
    82     ((_ msg loc x x? x1? ...)
    83      (if (x? x)
    84        (=== msg loc x x1? ...)
    85        (error loc msg 'x x x?)))
    86     ))
    87 
    88 ;;;;;;;;;;; the macro version below avoids the naming of arg
     53;;;;;; procedure versions
     54
     55(define (===% msg loc name arg . tests)
     56  (cond
     57    ((null? tests) arg)
     58    (((car tests) arg)
     59     (apply ===% msg loc name arg (cdr tests)))
     60    (else
     61      (error loc msg name arg (car tests)))))
     62
     63;(define (==% msg name arg . tests)
     64;  (apply ===% msg '==% name arg tests))
     65
     66(define (<<<% loc name arg . tests)
     67  (apply ===% "precondition violated" loc name arg tests))
     68
     69(define (<<% name arg . tests)
     70  (apply <<<% '<< name arg tests))
     71
     72(define (>>>% loc name arg . tests)
     73  (apply ===% "postcondition violated" loc name arg tests))
     74
     75(define (>>% name arg . tests)
     76  (apply >>>% '>> name arg tests))
     77
     78;;;;;;;;;;; the macro versions below avoid the naming of arg or result
     79
     80;(define-syntax ===
     81;  (er-macro-transformer
     82;    (lambda (form rename compare?)
     83;      (let ((%===% (rename '===%))
     84;            (msg (cadr form))
     85;            (loc (caddr form))
     86;            (arg (cadddr form))
     87;            (tests (cddddr form)))
     88;        `(,%===% ,msg ,loc ',arg ,arg ,@tests)))))
     89;
     90;(define-syntax ==
     91;  (er-macro-transformer
     92;    (lambda (form rename compare?)
     93;      (let ((%==% (rename '==%))
     94;            (msg (cadr form))
     95;            (arg (caddr form))
     96;            (tests (cdddr form)))
     97;        `(,%==% ,msg '== ',arg ,arg ,@tests)))))
     98
     99;;; (<< arg arg? ...)
     100;;; -----------------
     101;;; check a procedure argument, arg, against each predicate arg? ...
     102;;; in sequence and pass it to the procedure in case of success.
     103(define-syntax <<
     104  (er-macro-transformer
     105    (lambda (form rename compare?)
     106      (let ((%<<% (rename '<<%))
     107            (arg (cadr form))
     108            (tests (cddr form)))
     109        `(,%<<% ',arg ,arg ,@tests)))))
     110
    89111;;; (<<< loc arg arg? ...)
    90112;;; ----------------------
     
    93115;;; loc names the location in the error message.
    94116(define-syntax <<<
    95   (syntax-rules ()
    96     ((_ loc arg arg? ...)
    97      (=== "precondition violated" loc arg arg? ...))))
    98 ;    ((_ loc arg) arg)
    99 ;    ((_ loc arg arg?)
    100 ;     (if (arg? arg)
    101 ;       arg
    102 ;       (error loc "precondition violated" 'arg arg arg?)))
    103 ;    ((_ loc arg arg? arg1? ...)
    104 ;     (if (arg? arg)
    105 ;       (<<< loc arg arg1? ...)
    106 ;       (error loc "precondition violated" 'arg arg arg?)))
    107 ;    ))
    108 
    109 ;;; (<< arg arg? ...)
    110 ;;; -----------------
    111 ;;; check a procedure argument, arg, against each predicate arg? ...
    112 ;;; in sequence and pass it to the procedure in case of success.
    113 (define-syntax <<
    114   (syntax-rules ()
    115     ((_ arg arg? ...)
    116      (<<< '<< arg arg? ...))))
     117  (er-macro-transformer
     118    (lambda (form rename compare?)
     119      (let ((%<<<% (rename '<<<%))
     120            (loc (cadr form))
     121            (arg (caddr form))
     122            (tests (cdddr form)))
     123        `(,%<<<% ,loc ',arg ,arg ,@tests)))))
     124
     125;;; (>> result result? ...)
     126;;; -----------------------
     127;;; check a return value of a function, result, against each predicate
     128;;; result? ...in sequence and return it in case of success.
     129(define-syntax >>
     130  (er-macro-transformer
     131    (lambda (form rename compare?)
     132      (let ((%>>% (rename '>>%))
     133            (result (cadr form))
     134            (tests (cddr form)))
     135        `(,%>>% ',result ,result ,@tests)))))
    117136
    118137;;; (>>> loc result result? ...)
     
    122141;;; loc names the location in case of error.
    123142(define-syntax >>>
    124   (syntax-rules ()
    125     ((_ loc result result? ...)
    126      (=== "postcondition violated" loc result result? ...))))
    127 ;    ((_ loc result) result)
    128 ;    ((_ loc result result?)
    129 ;     (if (result? result)
    130 ;       result
    131 ;       (error loc "postcondition violated" 'result result result?)))
    132 ;    ((_ loc result result? result1? ...)
    133 ;     (if (result? result)
    134 ;       (>>> loc result result1? ...)
    135 ;       (error loc "postcondition violated" 'result result result?)))
    136 ;    ))
    137 
    138 ;;; (>> result result? ...)
    139 ;;; -----------------------
    140 ;;; check a return value of a function, result, against each predicate
    141 ;;; result? ...in sequence and return it in case of success.
    142 (define-syntax >>
    143   (syntax-rules ()
    144     ((_ result result? ...)
    145      (>>> '>> result result? ...))))
     143  (er-macro-transformer
     144    (lambda (form rename compare?)
     145      (let ((%>>>% (rename '>>>%))
     146            (loc (cadr form))
     147            (result (caddr form))
     148            (tests (cdddr form)))
     149        `(,%>>>% ,loc ',result ,result ,@tests)))))
    146150
    147151(define (true? xpr) #t)
    148152(define (false? xpr) #f)
     153
     154;;; (named-lambda (name . args) xpr . xprs)
     155;;; -----------------------------------
     156;;; can replace anonymous procedures in << and >>
     157;;; to improve error messages
     158(define-syntax named-lambda
     159  (syntax-rules ()
     160    ((_ (name . args) xpr . xprs)
     161     (letrec ((name (lambda args xpr . xprs)))
     162       name))))
    149163
    150164;;; (checks [sym])
     
    193207      "Otherwise print an error message with the"
    194208      "offending predicate.")
     209    (<<<%
     210      procedure:
     211      (<<<% loc name arg arg? ...)
     212      "precondition test:"
     213      "check arg against each predicate arg? in sequence"
     214      "and return it in case of success."
     215      "Otherwise print an error message with the"
     216      "offending predicate at location loc with arg-name name.")
     217    (<<%
     218      procedure:
     219      (<<% name arg arg? ...)
     220      "precondition test:"
     221      "check arg against each predicate arg? in sequence"
     222      "and return it in case of success."
     223      "Otherwise print an error message with the"
     224      "offending predicate and arg-name name")
     225    (>>>%
     226      procedure:
     227      (>>>% loc name result result? ...)
     228      "postcondition test:"
     229      "check result against each predicate result? in sequence"
     230      "and return it in case of success."
     231      "Otherwise print an error message with the"
     232      "offending predicate at location loc with result-name name.")
     233    (>>%
     234      procedure:
     235      (<<% name result result? ...)
     236      "postcondition test:"
     237      "check result against each predicate result? in sequence"
     238      "and return it in case of success."
     239      "Otherwise print an error message with the"
     240      "offending predicate and result-name name.")
    195241    (true?
    196242      procedure?
     
    201247      (false? xpr)
    202248      "returns always #f")
     249    (named-lambda
     250      macro:
     251      (named-lambda name args xpr . xprs)
     252      "can be used in place of lambda,"
     253      "possibly improving error messages")
    203254    )))
    204255    (case-lambda
  • release/5/checks/tags/1.1/tests/run.scm

    r37164 r37191  
    66  (= (>> x) 5)
    77  (= (<< x) 5)
    8   ;(= (<<  integer? odd? (named-lambda (5<= x) (<= 5 x))) 5)
    9   (= (<<< 'foo x integer? odd?) 5)
    10   (= (>>> 'foo x integer? odd?) 5)
    11   (= (>>> 'foo x integer? odd?) 5)
     8  (= (>> x integer? odd?) 5)
     9  (= (>>% 'x x integer? odd?) 5)
     10  (= (<< x integer? odd?) 5)
     11  (= (<<% 'x x integer? odd?) 5)
     12  (= (<<< 'loc x integer? odd?) 5)
     13  (= (>>> 'loc x integer? odd?) 5)
     14  (= (<<<% 'loc 'x x integer? odd?) 5)
     15  (= (>>>% 'loc 'x x integer? odd?) 5)
     16  (not (condition-case
     17         (<<% 'x x integer? even?)
     18         ((exn) #f)))
     19  (not (condition-case
     20         (<<<% 'loc 'x x integer? even?)
     21         ((exn) #f)))
    1222  (not (condition-case
    1323         (>> x integer? even?)
    1424         ((exn) #f)))
    1525  (not (<< ((lambda () #f)) boolean?))
     26  (= ((named-lambda (! n)
     27        (if (zero? n)
     28          1
     29          (* n (! (- n 1)))))
     30      5)
     31     120)
    1632  )
    1733
  • release/5/checks/trunk/checks.egg

    r37164 r37191  
    55 (test-dependencies simple-tests)
    66 (author "[[/users/juergen-lorenz|Juergen Lorenz]]")
    7  (version "1.0")
     7 (version "1.1")
    88 (components (extension checks)))
    99
  • release/5/checks/trunk/checks.scm

    r37164 r37191  
    3535
    3636
    37 (module checks (assert* << >> <<< >>> true? false?)
     37(module checks (checks assert*
     38                <<% << >>% >> <<<% <<< >>>% >>>
     39                 true? false? named-lambda)
    3840  (import scheme (only (chicken base) assert print case-lambda error))
    3941
     
    4951    ))
    5052
    51 ;;;;; (<<< loc arg-name arg . preds)
    52 ;;;;; ------------------------------
    53 ;;;;; pass in an argument, arg, after having it checked against each
    54 ;;;;; predicate in sequence
    55 ;;;;; loc and arg-name are used only in the error message.
    56 ;;;(define (<<< loc name arg . preds)
    57 ;;;  (let loop ((preds preds))
    58 ;;;    (cond
    59 ;;;      ((null? preds)
    60 ;;;       arg)
    61 ;;;      (((car preds) arg)
    62 ;;;       (loop (cdr preds)))
    63 ;;;      (else
    64 ;;;        (error loc "precondition violated" name arg (car preds))
    65 ;;;        ))))
    66 ;;;;;; (<< arg-name arg arg? ...)
    67 ;;;;;; --------------------------
    68 ;;;;;; pass in an argument, arg, after having it checked against each
    69 ;;;;;; predicate, arg?, in sequence
    70 ;;;;;; arg-name is used only in the error message.
    71 ;;;(define (<< name arg . preds)
    72 ;;;  (apply <<< '<< name arg preds))
    73 
    74 
    75 (define-syntax ===  ; hidden
    76   (syntax-rules ()
    77     ((_ msg loc x) x)
    78     ((_ msg loc x x?)
    79      (if (x? x)
    80        x
    81        (error loc msg 'x x x?)))
    82     ((_ msg loc x x? x1? ...)
    83      (if (x? x)
    84        (=== msg loc x x1? ...)
    85        (error loc msg 'x x x?)))
    86     ))
    87 
    88 ;;;;;;;;;;; the macro version below avoids the naming of arg
     53;;;;;; procedure versions
     54
     55(define (===% msg loc name arg . tests)
     56  (cond
     57    ((null? tests) arg)
     58    (((car tests) arg)
     59     (apply ===% msg loc name arg (cdr tests)))
     60    (else
     61      (error loc msg name arg (car tests)))))
     62
     63;(define (==% msg name arg . tests)
     64;  (apply ===% msg '==% name arg tests))
     65
     66(define (<<<% loc name arg . tests)
     67  (apply ===% "precondition violated" loc name arg tests))
     68
     69(define (<<% name arg . tests)
     70  (apply <<<% '<< name arg tests))
     71
     72(define (>>>% loc name arg . tests)
     73  (apply ===% "postcondition violated" loc name arg tests))
     74
     75(define (>>% name arg . tests)
     76  (apply >>>% '>> name arg tests))
     77
     78;;;;;;;;;;; the macro versions below avoid the naming of arg or result
     79
     80;(define-syntax ===
     81;  (er-macro-transformer
     82;    (lambda (form rename compare?)
     83;      (let ((%===% (rename '===%))
     84;            (msg (cadr form))
     85;            (loc (caddr form))
     86;            (arg (cadddr form))
     87;            (tests (cddddr form)))
     88;        `(,%===% ,msg ,loc ',arg ,arg ,@tests)))))
     89;
     90;(define-syntax ==
     91;  (er-macro-transformer
     92;    (lambda (form rename compare?)
     93;      (let ((%==% (rename '==%))
     94;            (msg (cadr form))
     95;            (arg (caddr form))
     96;            (tests (cdddr form)))
     97;        `(,%==% ,msg '== ',arg ,arg ,@tests)))))
     98
     99;;; (<< arg arg? ...)
     100;;; -----------------
     101;;; check a procedure argument, arg, against each predicate arg? ...
     102;;; in sequence and pass it to the procedure in case of success.
     103(define-syntax <<
     104  (er-macro-transformer
     105    (lambda (form rename compare?)
     106      (let ((%<<% (rename '<<%))
     107            (arg (cadr form))
     108            (tests (cddr form)))
     109        `(,%<<% ',arg ,arg ,@tests)))))
     110
    89111;;; (<<< loc arg arg? ...)
    90112;;; ----------------------
     
    93115;;; loc names the location in the error message.
    94116(define-syntax <<<
    95   (syntax-rules ()
    96     ((_ loc arg arg? ...)
    97      (=== "precondition violated" loc arg arg? ...))))
    98 ;    ((_ loc arg) arg)
    99 ;    ((_ loc arg arg?)
    100 ;     (if (arg? arg)
    101 ;       arg
    102 ;       (error loc "precondition violated" 'arg arg arg?)))
    103 ;    ((_ loc arg arg? arg1? ...)
    104 ;     (if (arg? arg)
    105 ;       (<<< loc arg arg1? ...)
    106 ;       (error loc "precondition violated" 'arg arg arg?)))
    107 ;    ))
    108 
    109 ;;; (<< arg arg? ...)
    110 ;;; -----------------
    111 ;;; check a procedure argument, arg, against each predicate arg? ...
    112 ;;; in sequence and pass it to the procedure in case of success.
    113 (define-syntax <<
    114   (syntax-rules ()
    115     ((_ arg arg? ...)
    116      (<<< '<< arg arg? ...))))
     117  (er-macro-transformer
     118    (lambda (form rename compare?)
     119      (let ((%<<<% (rename '<<<%))
     120            (loc (cadr form))
     121            (arg (caddr form))
     122            (tests (cdddr form)))
     123        `(,%<<<% ,loc ',arg ,arg ,@tests)))))
     124
     125;;; (>> result result? ...)
     126;;; -----------------------
     127;;; check a return value of a function, result, against each predicate
     128;;; result? ...in sequence and return it in case of success.
     129(define-syntax >>
     130  (er-macro-transformer
     131    (lambda (form rename compare?)
     132      (let ((%>>% (rename '>>%))
     133            (result (cadr form))
     134            (tests (cddr form)))
     135        `(,%>>% ',result ,result ,@tests)))))
    117136
    118137;;; (>>> loc result result? ...)
     
    122141;;; loc names the location in case of error.
    123142(define-syntax >>>
    124   (syntax-rules ()
    125     ((_ loc result result? ...)
    126      (=== "postcondition violated" loc result result? ...))))
    127 ;    ((_ loc result) result)
    128 ;    ((_ loc result result?)
    129 ;     (if (result? result)
    130 ;       result
    131 ;       (error loc "postcondition violated" 'result result result?)))
    132 ;    ((_ loc result result? result1? ...)
    133 ;     (if (result? result)
    134 ;       (>>> loc result result1? ...)
    135 ;       (error loc "postcondition violated" 'result result result?)))
    136 ;    ))
    137 
    138 ;;; (>> result result? ...)
    139 ;;; -----------------------
    140 ;;; check a return value of a function, result, against each predicate
    141 ;;; result? ...in sequence and return it in case of success.
    142 (define-syntax >>
    143   (syntax-rules ()
    144     ((_ result result? ...)
    145      (>>> '>> result result? ...))))
     143  (er-macro-transformer
     144    (lambda (form rename compare?)
     145      (let ((%>>>% (rename '>>>%))
     146            (loc (cadr form))
     147            (result (caddr form))
     148            (tests (cdddr form)))
     149        `(,%>>>% ,loc ',result ,result ,@tests)))))
    146150
    147151(define (true? xpr) #t)
    148152(define (false? xpr) #f)
     153
     154;;; (named-lambda (name . args) xpr . xprs)
     155;;; -----------------------------------
     156;;; can replace anonymous procedures in << and >>
     157;;; to improve error messages
     158(define-syntax named-lambda
     159  (syntax-rules ()
     160    ((_ (name . args) xpr . xprs)
     161     (letrec ((name (lambda args xpr . xprs)))
     162       name))))
    149163
    150164;;; (checks [sym])
     
    193207      "Otherwise print an error message with the"
    194208      "offending predicate.")
     209    (<<<%
     210      procedure:
     211      (<<<% loc name arg arg? ...)
     212      "precondition test:"
     213      "check arg against each predicate arg? in sequence"
     214      "and return it in case of success."
     215      "Otherwise print an error message with the"
     216      "offending predicate at location loc with arg-name name.")
     217    (<<%
     218      procedure:
     219      (<<% name arg arg? ...)
     220      "precondition test:"
     221      "check arg against each predicate arg? in sequence"
     222      "and return it in case of success."
     223      "Otherwise print an error message with the"
     224      "offending predicate and arg-name name")
     225    (>>>%
     226      procedure:
     227      (>>>% loc name result result? ...)
     228      "postcondition test:"
     229      "check result against each predicate result? in sequence"
     230      "and return it in case of success."
     231      "Otherwise print an error message with the"
     232      "offending predicate at location loc with result-name name.")
     233    (>>%
     234      procedure:
     235      (<<% name result result? ...)
     236      "postcondition test:"
     237      "check result against each predicate result? in sequence"
     238      "and return it in case of success."
     239      "Otherwise print an error message with the"
     240      "offending predicate and result-name name.")
    195241    (true?
    196242      procedure?
     
    201247      (false? xpr)
    202248      "returns always #f")
     249    (named-lambda
     250      macro:
     251      (named-lambda name args xpr . xprs)
     252      "can be used in place of lambda,"
     253      "possibly improving error messages")
    203254    )))
    204255    (case-lambda
  • release/5/checks/trunk/tests/run.scm

    r37164 r37191  
    66  (= (>> x) 5)
    77  (= (<< x) 5)
    8   ;(= (<<  integer? odd? (named-lambda (5<= x) (<= 5 x))) 5)
    9   (= (<<< 'foo x integer? odd?) 5)
    10   (= (>>> 'foo x integer? odd?) 5)
    11   (= (>>> 'foo x integer? odd?) 5)
     8  (= (>> x integer? odd?) 5)
     9  (= (>>% 'x x integer? odd?) 5)
     10  (= (<< x integer? odd?) 5)
     11  (= (<<% 'x x integer? odd?) 5)
     12  (= (<<< 'loc x integer? odd?) 5)
     13  (= (>>> 'loc x integer? odd?) 5)
     14  (= (<<<% 'loc 'x x integer? odd?) 5)
     15  (= (>>>% 'loc 'x x integer? odd?) 5)
     16  (not (condition-case
     17         (<<% 'x x integer? even?)
     18         ((exn) #f)))
     19  (not (condition-case
     20         (<<<% 'loc 'x x integer? even?)
     21         ((exn) #f)))
    1222  (not (condition-case
    1323         (>> x integer? even?)
    1424         ((exn) #f)))
    1525  (not (<< ((lambda () #f)) boolean?))
     26  (= ((named-lambda (! n)
     27        (if (zero? n)
     28          1
     29          (* n (! (- n 1)))))
     30      5)
     31     120)
    1632  )
    1733
Note: See TracChangeset for help on using the changeset viewer.