Changeset 37475 in project


Ignore:
Timestamp:
03/27/19 12:54:00 (10 months ago)
Author:
juergen
Message:

checks 1.2

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

Legend:

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

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

    r37219 r37475  
    5151    ))
    5252
    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))
     53(define-syntax named-lambda
     54  (syntax-rules ()
     55    ((_ (name . args) xpr . xprs)
     56     (letrec ((name (lambda args xpr . xprs)))
     57       name))))
    7758
    7859;;;;;;;;;;; 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)))))
    11060
    11161;;; (<<< loc arg arg? ...)
     
    11565;;; loc names the location in the error message.
    11666(define-syntax <<<
    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)))))
     67  (syntax-rules ()
     68    ((_ loc arg)
     69     arg)
     70    ((_ loc arg ok?)
     71     (if (ok? arg)
     72       arg
     73       (error loc "precondition violated" '(ok? arg))))
     74    ((_ loc arg ok? ok1? ...)
     75     (if (ok? arg)
     76       (<<< loc arg ok1? ...)
     77       (error loc "precondition violated" (ok? arg))))
     78    ))
     79
     80;;; (<< arg arg? ...)
     81;;; -----------------
     82;;; check a procedure argument, arg, against each predicate arg? ...
     83;;; in sequence and pass it to the procedure in case of success.
     84(define-syntax <<
     85  (syntax-rules ()
     86    ((_ arg ok? ...)
     87     (<<< '<< arg ok? ...))))
    13688
    13789;;; (>>> loc result result? ...)
     
    14193;;; loc names the location in case of error.
    14294(define-syntax >>>
    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)))))
     95  (syntax-rules ()
     96    ((_ loc result)
     97     result)
     98    ((_ loc result ok?)
     99     (if (ok? result)
     100       result
     101       (error loc "postcondition violated" '(ok? result))))
     102    ((_ loc result ok? ok1? ...)
     103     (if (ok? result)
     104       (>>> loc result ok1? ...)
     105       (error loc "postcondition violated" '(ok? result))))
     106    ))
     107
     108;;; (>> result result? ...)
     109;;; -----------------------
     110;;; check a return value of a function, result, against each predicate
     111;;; result? ...in sequence and return it in case of success.
     112(define-syntax >>
     113  (syntax-rules ()
     114    ((_ result ok? ...)
     115     (>>> '>> result ok? ...))))
     116
     117;;;;;; procedure versions need to name arg and result respectively
     118
     119(define (<<<% loc arg-name arg . tests)
     120  (let loop ((tests tests))
     121    (cond
     122      ((null? tests) arg)
     123      (((car tests) arg)
     124       (loop (cdr tests)))
     125      (else (error loc
     126                   "precondition violated"
     127                   `(,(car tests) ,arg-name))))))
     128
     129
     130(define (<<% arg-name arg . tests)
     131  (apply <<<% '<< arg-name arg tests))
     132
     133(define (>>>% loc result-name result . tests)
     134  (let loop ((tests tests))
     135    (cond
     136      ((null? tests) result)
     137      (((car tests) result)
     138       (loop (cdr tests)))
     139      (else (error loc
     140                   "postcondition violated"
     141                   `(,(car tests) ,result-name))))))
     142
     143
     144(define (>>% result-name result . tests)
     145  (apply >>>% '>> result-name result tests))
    150146
    151147(define (true? xpr) #t)
     
    156152;;; can replace anonymous procedures in << and >>
    157153;;; 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))))
    163 
    164154;;; (checks [sym])
    165155;;; -------------------------
  • release/5/checks/trunk/checks.egg

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

    r37219 r37475  
    5151    ))
    5252
    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))
     53(define-syntax named-lambda
     54  (syntax-rules ()
     55    ((_ (name . args) xpr . xprs)
     56     (letrec ((name (lambda args xpr . xprs)))
     57       name))))
    7758
    7859;;;;;;;;;;; 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)))))
    11060
    11161;;; (<<< loc arg arg? ...)
     
    11565;;; loc names the location in the error message.
    11666(define-syntax <<<
    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)))))
     67  (syntax-rules ()
     68    ((_ loc arg)
     69     arg)
     70    ((_ loc arg ok?)
     71     (if (ok? arg)
     72       arg
     73       (error loc "precondition violated" '(ok? arg))))
     74    ((_ loc arg ok? ok1? ...)
     75     (if (ok? arg)
     76       (<<< loc arg ok1? ...)
     77       (error loc "precondition violated" (ok? arg))))
     78    ))
     79
     80;;; (<< arg arg? ...)
     81;;; -----------------
     82;;; check a procedure argument, arg, against each predicate arg? ...
     83;;; in sequence and pass it to the procedure in case of success.
     84(define-syntax <<
     85  (syntax-rules ()
     86    ((_ arg ok? ...)
     87     (<<< '<< arg ok? ...))))
    13688
    13789;;; (>>> loc result result? ...)
     
    14193;;; loc names the location in case of error.
    14294(define-syntax >>>
    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)))))
     95  (syntax-rules ()
     96    ((_ loc result)
     97     result)
     98    ((_ loc result ok?)
     99     (if (ok? result)
     100       result
     101       (error loc "postcondition violated" '(ok? result))))
     102    ((_ loc result ok? ok1? ...)
     103     (if (ok? result)
     104       (>>> loc result ok1? ...)
     105       (error loc "postcondition violated" '(ok? result))))
     106    ))
     107
     108;;; (>> result result? ...)
     109;;; -----------------------
     110;;; check a return value of a function, result, against each predicate
     111;;; result? ...in sequence and return it in case of success.
     112(define-syntax >>
     113  (syntax-rules ()
     114    ((_ result ok? ...)
     115     (>>> '>> result ok? ...))))
     116
     117;;;;;; procedure versions need to name arg and result respectively
     118
     119(define (<<<% loc arg-name arg . tests)
     120  (let loop ((tests tests))
     121    (cond
     122      ((null? tests) arg)
     123      (((car tests) arg)
     124       (loop (cdr tests)))
     125      (else (error loc
     126                   "precondition violated"
     127                   `(,(car tests) ,arg-name))))))
     128
     129
     130(define (<<% arg-name arg . tests)
     131  (apply <<<% '<< arg-name arg tests))
     132
     133(define (>>>% loc result-name result . tests)
     134  (let loop ((tests tests))
     135    (cond
     136      ((null? tests) result)
     137      (((car tests) result)
     138       (loop (cdr tests)))
     139      (else (error loc
     140                   "postcondition violated"
     141                   `(,(car tests) ,result-name))))))
     142
     143
     144(define (>>% result-name result . tests)
     145  (apply >>>% '>> result-name result tests))
    150146
    151147(define (true? xpr) #t)
     
    156152;;; can replace anonymous procedures in << and >>
    157153;;; 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))))
    163 
    164154;;; (checks [sym])
    165155;;; -------------------------
Note: See TracChangeset for help on using the changeset viewer.