Changeset 39584 in project


Ignore:
Timestamp:
02/08/21 16:45:11 (3 weeks ago)
Author:
juergen
Message:

simple-tests 3.1 with pe bug removed

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

Legend:

Unmodified
Added
Removed

  • release/5/simple-tests/tags/3.1/simple-tests.egg

    r39512 r39584  
    44 (category testing)
    55 (license "BSD")
    6  (version "2.3.2")
     6 (version "3.1")
    77 (author "Juergen Lorenz")
    8  (components (extension simple-tests
    9                         (csc-options "-O3" "-d0"))))
     8 (component-options (csc-options "-O3" "-d1"))
     9 (components (extension simple-tests)))
     10

  • release/5/simple-tests/tags/3.1/simple-tests.scm

    r39512 r39584  
    1 
    2 ; Author: Juergen Lorenz
    3 ; ju (at) jugilo (dot) de
    4 ;
    5 ; Copyright (c) 2011-2021, Juergen Lorenz
     1; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
    62; All rights reserved.
    73;
    … …  
    1612; notice, this list of conditions and the following disclaimer in the
    1713; documentation and/or other materials provided with the distribution.
    18 ;
    1914; Neither the name of the author nor the names of its contributors may be
    2015; used to endorse or promote products derived from this software without
    2116; specific prior written permission.
    22 ;
     17;  
    2318; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    2419; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
    … …  
    3227; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    3328; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    34 ;
     29
     30
    3531
    3632#|[
    3733This is a simple Unit Test Framework inspired by Peter Seibel's
    3834"Practical Common Lisp" together with some routines which might be
    39 useful for debugging.
    40 A second test interface is added with version 2.0
    41 ]|#
    42 
     35useful for debugging.  It underwent several changes in the maintenance
     36process, most of them are now marked deprecated but are still there in
     37favor of backwards compatibility.
     38
     39For the future, it's sufficient to use only the following six routines,
     40the parameter verbose? and the macros pe, ppp, check, make-tester and
     41test-all.
     42
     43pe, ppp and check are mostly used in the development phase, make-tester
     44and test-all are the actual test routines to go into tests/run.scm.
     45
     46A tester is a nullary predicate which produces a lot of information as
     47side-effects provided the parameter verbose? is true. These testers are
     48invoked in test-all.
     49
     50pe is a combination of pretty-print and expand enhanced with additional
     51text; ppp pretty-prints a list of expressions and its values, while
     52check does the same but accompanies these computed values with expected
     53ones, allowing for local variables in the checks.
     54]|#
    4355
    4456(module simple-tests (
    45   ; common
    46   simple-tests
     57  verbose?
     58  writeln
    4759  and?
    48   writeln
    4960  pe
     61  xpr:val
    5062  ppp
    5163  ppp*
     64  xpr:val*
    5265  ppp**
    53   xpr:val
    54   xpr:val*
     66  (define-test *failures* *locations*)
     67  (compound-test *failures* group-on-cdrs)
    5568  ==
    56   ; old interface
    57   define-test
    58   (compound-test group-on-cdrs)
    59   *locations*
    60   *failures*
    61   ; new interface
    6269  check
    6370  define-checks
    6471  do-checks
    65   (check-all check-all-proc)
     72  define-tester
     73  (test-all test-all-proc)
     74  (check-all test-all-proc)
     75  simple-tests
    6676  )
    6777
    68 (import scheme (chicken base) (chicken syntax) (chicken pretty-print))
     78(import scheme
     79        (only (chicken base)
     80              print case-lambda cut chop exit receive make-parameter)
     81        (only (chicken syntax) expand)
     82        (only (chicken module) import-for-syntax)
     83        (only (chicken pretty-print) pp)
     84        )
    6985
    7086(import-for-syntax (only (chicken base) chop))
    … …  
    7288;;;;;; Common interface ;;;;;;
    7389
    74 ;;; (simple-tests [sym])
    75 ;;; ---------------------
    76 ;;; documentation procedure
    77 (define simple-tests
    78   (let (
    79     (signatures '((simple-tests
    80                     procedure:
    81                     (simple-tests sym ..)
    82                     "documentation procedure")
    83                   (and?
    84                     procedure:
    85                     (and? xpr ...)
    86                     "Pascal like and procedure")
    87                   (writeln
    88                     procedure:
    89                     (writeln xpr ....)
    90                     "write analog of print")
    91                   (pe
    92                     procedure:
    93                     (pe macro-code)
    94                     " composes pretty-print and expand")
    95                   (ppp
    96                     macro:
    97                     (ppp xpr ...)
    98                     " print each xpr quoted in a headline"
    99                     "and pretty-print xpr's computed value")
    100                   (ppp*
    101                     macro:
    102                     (ppp* xpr ypr . xpr-yprs)
    103                     "print each xpr quoted in a headline"
    104                     "and pretty-print xpr's computed and"
    105                     "expected value, ypr")
    106                   (ppp**
    107                     macro:
    108                     (ppp** ((var val) ...) xpr ypr . xpr-yprs)
    109                     "wraps ppp* into a let")
    110                   (xpr:val
    111                     macro:
    112                     (xpr:val xpr ...)
    113                     "alias to ppp")
    114                   (xpr:val*
    115                     macro:
    116                     (xpr:val* xpr ypr . xpr-yprs)
    117                     "alias to ppp*")
    118                   (==
    119                     procedure:
    120                     (==)
    121                     (== x)
    122                     (== type? type-equal?)
    123                     "generic type equality as curried procedure:"
    124                     "the first resets the local database,"
    125                     "the second is the curried equality check"
    126                     "and the third adds a new equality procedure"
    127                     "to the local database")
    128 
    129                   (define-test
    130                     macro:
    131                     (define-test (name . parameters) form . forms)
    132                     "creates a test function")
    133                   (compound-test
    134                     macro:
    135                     (compound-test (name) test . tests)
    136                     "checks all tests created with define-test"
    137                     "and reports a summary of results")
    138 
    139                   (check
    140                     macro:
    141                     (check ((var val) ...) xpr ypr . xpr-yprs)
    142                     "compares xpr and ypr .... with == in the"
    143                     "environment defined by (var val) ...")
    144                   (define-checks
    145                     macro:
    146                     (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    147                     "returns a unary predicate, name?,"
    148                     "comparing xpr with ypr ...."
    149                     "and using var val ... within this checks."
    150                     "verbose? controls the reported results")
    151                   (do-checks
    152                     macro:
    153                     (do-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    154                     "alias to define-checks")
    155                   (check-all
    156                     macro:
    157                     (check-all name check-xpr ....)
    158                     "checks all check-expressions created by do-check"
    159                     "and reports the results")))
    160     )
    161     (case-lambda
    162       (() (map car signatures))
    163       ((sym)
    164        (let ((pair (assq sym signatures)))
    165          (if pair
    166            (for-each print (cdr pair))
    167            (print "Choose one of " (map car signatures))))))))
    168 
     90#|[
     91(verbose? ..)
     92--- parameter ---
     93gets or sets the value of the parameter verbose?
     94]|#
     95(define verbose?
     96  (make-parameter #t
     97                  (lambda (x)
     98                    (if (not x)
     99                      x
     100                      #t))))
     101
     102#|[
     103(writeln xpr ...)
     104--- procedure ---
     105write analog of print, expressions separated by whitespace
     106]|#
    169107(define (writeln . args)
    170108  (for-each (lambda (a)
    … …  
    174112  (newline))
    175113
    176 ;;; (and? . xprs)
    177 ;;; -------------
    178 ;;; non-short-circuited and which executes all side-effects
     114#|[
     115(and? . xprs)
     116--- procedure ---
     117non-short-circuited and which executes all side-effects
     118]|#
    179119(define (and? . xprs)
    180120  (let ((result #t))
    … …  
    183123    result))
    184124
    185 ;;; (pe macro-code)
    186 ;;; ---------------
    187 ;;; composes pretty-print and expand
     125#|[
     126(pe macro-code)
     127--- macro ---
     128composes pretty-print and expand with additional information
     129]|#
    188130(define (pe macro-code)
    189   (pp (expand macro-code)))
    190 
    191 #|[
    192 The following macro, xpr:val, pretty-prints the literal representation
    193 of each of its arguments as well as their respective values.  The call
    194 to eval-when guarantees, that the whole expression does nothing in
    195 compiled code.
    196 ]|#
    197 
    198 ;;; (xpr:val xpr ...)
    199 ;;; -----------------
    200 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    201 ;;; value.
     131  (newline)
     132  (print "Macro expansion:")
     133  (print "----------------")
     134  (pp macro-code)
     135  (print "->")
     136  (pp (expand macro-code))
     137  (print "----------------")
     138  (newline))
     139
     140;;; The following macro, xpr:val, pretty-prints the literal representation
     141;;; of each of its arguments as well as their respective values.  The call
     142;;; to eval-when guarantees, that the whole expression does nothing in
     143;;; compiled code.
     144
     145#|[
     146(xpr:val xpr ...)
     147--- macro ---
     148Deprecated!
     149Print each xpr quoted in a headline and pretty-print xpr's computed
     150value.
     151]|#
    202152(define-syntax xpr:val
    203153  (syntax-rules ()
    … …  
    212162       (else)))))
    213163
    214 ;;; (ppp xpr ...)
    215 ;;; -------------
    216 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    217 ;;; value. Alias to xpr:val.
     164#|[
     165(ppp xpr ...)
     166--- macro ---
     167print each xpr quoted in a headline and pretty-print xpr's computed
     168value. Alias to xpr:val.
     169]|#
    218170(define-syntax ppp
    219171  (syntax-rules ()
    220172    ((_ xpr ...)
    221      (xpr:val xpr ...))))
     173     (cond-expand
     174       ((not compiling)
     175        (begin (print "Computing " 'xpr " ...")
     176               (pp xpr)
     177               )
     178        ...
     179        )
     180       (else)))))
    222181
    223182(define-syntax help-ppp* ; internal
    … …  
    235194    ))
    236195;
    237 ;;;; (ppp* {xpr ypr} ...)
    238 ;;; --------------------
    239 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    240 ;;; and expected value, ypr.
     196#|[
     197(ppp* {xpr ypr} ...)
     198--- macro ---
     199Deprecated!
     200Print each xpr quoted in a headline and pretty-print xpr's computed
     201and expected value, ypr.
     202]|#
    241203(define-syntax ppp*
    242204  (syntax-rules ()
    … …  
    247209       (else)))))
    248210
    249 ;;; (xpr:val* {xpr ypr} ...)
    250 ;;; ------------------------
    251 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    252 ;;; and expected value, ypr.
    253 ;;; Alias to ppp*
    254 (define-syntax xpr:val*
     211#|[
     212(xpr:val* {xpr ypr} ...)
     213--- macro ---
     214Deprecated!
     215Print each xpr quoted in a headline and pretty-print xpr's computed
     216and expected value, ypr.
     217Alias to ppp*
     218]|#
     219(define-syntax xpr:val* ; deprecated
    255220  (syntax-rules ()
    256221    ((_ . pairs)
    257222     (ppp* . pairs))))
    258223
    259 ;;; (ppp** ((var val) ...) xpr ypr . other xpr-ypr-pairs)
    260 ;;; -----------------------------------------------------
    261 ;;; ppp* wrapped into a let
     224#|[
     225(ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     226--- macro ---
     227Deprecated!
     228ppp* wrapped into a let
     229]|#
    262230(define-syntax ppp**
    263231  (syntax-rules ()
    … …  
    268236;;;;;;;; old interface ;;;;;;;;;
    269237
    270 ;; helper macro because I don't want to export it
    271 (define-syntax disp
     238(define-syntax disp ; internal
    272239  (syntax-rules ()
    273240    ((_)
    … …  
    277244;;; ------------------------
    278245;;; reports succuss or failure of form and updates failures if necessary
    279 (define-syntax report-result
     246(define-syntax report-result ; internal
    280247  (syntax-rules ()
    281248    ((_ loc form)
    … …  
    299266         #f)))))
    300267
    301 ;;; (check-em . forms) ;; internal
     268;;; (check-em . forms)
    302269;;; ------------------
    303270;;; report result of all forms
    304 (define-syntax check-em
     271(define-syntax check-em ; internal
    305272  (syntax-rules ()
    306273    ((_ form ...)
    … …  
    309276             ...)))))
    310277
    311 ;; internal helper
    312 (define-syntax show-args
     278(define-syntax show-args ; internal
    313279 (syntax-rules ()
    314280   ((_ (name arg ...))
    … …  
    316282   ((_ arg) arg)))
    317283
    318 ;;; (define-test (name . parameters) form . forms)
    319 ;;; ----------------------------------------------
    320 ;;; creates a test function
     284#|[
     285(define-test (name . parameters) form . forms)
     286--- macro *locations* *failures* ---
     287Deprecated!
     288Creates a test function
     289]|#
    321290(define-syntax define-test
    322291  (syntax-rules ()
    … …  
    329298         ((check-em form . forms) *locations*))))))
    330299
    331 ;;; (compound-test (name) test . tests)
    332 ;;; -----------------------------------
    333 ;;; invokes all tests and reports a summary
     300#|[
     301(compound-test (name) test . tests)
     302--- macro group-on-cdrs *failures* ---
     303Deprecated!
     304Invokes all tests and reports a summary
     305]|#
    334306(define-syntax compound-test
    335307  (syntax-rules ()
    336308    ((_ (name) test0 test1 ...)
    337309     (begin
     310  (writeln "XXX" 'test0 test0 test1 ...) ;;;;;
     311  (writeln "YYY" (and? test0 test1 ...)) ;;;;;
    338312       (print "\nTesting " 'name " ...")
    339313       (print "----------------------------")
    … …  
    362336             (exit 1))))))))
    363337
    364 ;;; internal helper from bindings
     338;;; internal helper
    365339(define (filter ok? lst)
    366340  (let loop ((lst lst) (yes '()) (no '()))
    … …  
    383357        (loop no (cons yes result))))))
    384358
     359;;;*failures*
     360;;; ----------
     361;;; Deprecated!
     362;;; global variable
     363(define *failures* '())
     364
    385365;;; *locations*
    386366;;; -----------
    387 ;;; dynamic variable
     367;;; Deprecated!
     368;;; global variable
    388369(define *locations* '())
    389 
    390 ;;; *failures*
    391 ;;; ----------
    392 ;;; global variable collecting failure information
    393 (define *failures* '())
    394370
    395371;;;;;;; new interface ;;;;;;;;;;;
    … …  
    401377;  (string=? (symbol->string x) (symbol->string y)))
    402378
    403 ;;; (==)
    404 ;;; (== x)
    405 ;;; (== type? type-equal?)
    406 ;;; ----------------------
    407 ;;; generic type equality as curried procedure
     379#|[
     380(==)
     381(== x)
     382(== type? type-equal?)
     383--- procedure ---
     384Deprecated!
     385Generic type equality as curried procedure
     386]|#
    408387(define ==
    409388  (let* ((pairs (list (cons pair? (curry equal?))
    … …  
    438417;;; (check* ((var val) ...) xpr ypr . xpr-yprs) ;; internal
    439418;;; --------------------------------------------------------------
     419(define-syntax check* ; internal
     420  (ir-macro-transformer
     421    (lambda (form inject compare?)
     422      (let ((var-vals (cadr form))
     423            (xpr-yprs (cddr form))
     424            (select-failures
     425              (lambda (pairs)
     426                (let loop ((pairs pairs))
     427                  (cond
     428                    ((null? pairs) '())
     429                    ((caar pairs) (loop (cdr pairs)))
     430                    (else
     431                     (cons (car pairs) (loop (cdr pairs))))))))
     432            )
     433`(lambda (verbose?)
     434   (letrec ,var-vals
     435          (let ((tests '()))
     436            ,@(map (lambda (p)
     437                     `(begin
     438                        (let ((x ,(car p)))
     439                           ; protect against functions changing state
     440                          (when verbose?
     441                            (print "testing " ',(car p) " ...")
     442                            (print* "computed: ") (writeln x)
     443                            (print* "expected: ") (writeln ,(cadr p))
     444                            )
     445                          (set! tests
     446                                (cons (cons ((cut equal? <> x) ,(cadr p))
     447                                            ',(car p))
     448                                      tests)))
     449                                ;(cons (cons ((== x) ,(cadr p)) ',(car p))
     450                                ;            tests)))
     451                          ))
     452                   (chop xpr-yprs 2))
     453            (let ((fails (,select-failures (reverse tests))))
     454              (when verbose?
     455                (print "Failed test expressions:")
     456                (print "------------------------")
     457                (if (null? fails)
     458                  (print "none")
     459                  (for-each print (map cdr fails))))
     460              (if (null? fails) #t #f)))))
     461 ))))
    440462;(define-syntax check*
    441463;  (er-macro-transformer
    … …  
    495517;              (,%if (,%null? ,%fails) #t #f)))))
    496518; ))))
    497 (define-syntax check*
    498   (ir-macro-transformer
    499     (lambda (form inject compare?)
    500       (let ((var-vals (cadr form))
    501             (xpr-yprs (cddr form))
    502             (select-failures
    503               (lambda (pairs)
    504                 (let loop ((pairs pairs))
    505                   (cond
    506                     ((null? pairs) '())
    507                     ((caar pairs) (loop (cdr pairs)))
    508                     (else
    509                      (cons (car pairs) (loop (cdr pairs))))))))
    510             )
    511 `(lambda (verbose?)
    512    (letrec ,var-vals
    513           (let ((tests '()))
    514             ,@(map (lambda (p)
    515                      `(begin
    516                         (let ((x ,(car p)))
    517                            ; protect against functions changing state
    518                           (when verbose?
    519                             (print "testing " ',(car p) " ...")
    520                             (print* "computed: ") (writeln x)
    521                             (print* "expected: ") (writeln ,(cadr p))
    522                             )
    523                           (set! tests
    524                                   (cons (cons ((== x) ,(cadr p)) ',(car p))
    525                                           tests)))
    526                           ))
    527                    (chop xpr-yprs 2))
    528             (let ((fails (,select-failures (reverse tests))))
    529               (when verbose?
    530                 (print "Failed test expressions:")
    531                 (print "------------------------")
    532                 (if (null? fails)
    533                   (print "none")
    534                   (for-each print (map cdr fails))))
    535               (if (null? fails) #t #f)))))
    536  ))))
    537 ;;; (check ((var val) ...) xpr ypr . xpr-yprs)
    538 ;;; ------------------------------------------
    539 ;;; compare xpr and ypr .... in sequence with ==
    540 ;;; in the environment defined by var val ...
     519#|[
     520(check ((var val) ...) xpr ypr . xpr-yprs)
     521--- macro ---
     522Compare xpr and ypr .... in sequence with equal?
     523in the environment defined by var val ...
     524]|#
    541525(define-syntax check
    542526  (syntax-rules ()
    … …  
    544528     ((check* ((var val) ...) xpr ypr . xpr-yprs) #t))))
    545529
    546 ;;; (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    547 ;;; --------------------------------------------------------------
    548 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    549 ;;; and using var val ... within this checks,
    550 ;;; verbose? controls the reported summary.
     530#|[
     531(define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     532--- macro ---
     533Deprecated!
     534Returns a unary predicate, name?, comparing xpr with ypr ....
     535and using var val ... within this checks,
     536verbose? controls the reported summary.
     537]|#
    551538(define-syntax define-checks
    552539  (ir-macro-transformer
    … …  
    572559               ,@xpr-yprs) ,verbose?)))))))))
    573560
    574 ;;; (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
    575 ;;; ---------------------------------------------------------------
    576 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    577 ;;; and using var val ... within this checks,
    578 ;;; alias to define-checks
     561#|[
     562(do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     563--- macro ---
     564Deprecated!
     565Returns a unary predicate, name?, comparing xpr with ypr ....
     566and using var val ... within this checks,
     567alias to define-checks
     568]|#
    579569(define-syntax do-checks
    580570  (syntax-rules ()
    … …  
    583573       xpr ypr .  xpr-ypr-pairs))))
    584574
    585 (define (check-all-proc name . test-name-pairs) ; internal to check-all
    586   ; used internally in check-all, must be exported within check-all
     575#|[
     576(define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     577--- macro ---
     578Returns a thunk predicate, name?, comparing xpr with ypr ....
     579and using var val ... within this tests.
     580The parameter verbose? controls the reported summary, i. e.
     581the side effects.
     582]|#
     583(define-syntax define-tester
     584  (ir-macro-transformer
     585    (lambda (form inject compare?)
     586      (let ((header (cadr form))
     587            (xpr-yprs (cddr form)))
     588        (let ((name (car header))
     589              (var-vals (cdr header)))
     590    `(define (,name)
     591       (when (verbose?)
     592         (print "\nIn " ',name ":")
     593         (print* "==="
     594                 (make-string (string-length
     595                                (symbol->string ',name)) #\=)
     596                 "=\n")
     597         )
     598         ((check* ,(chop var-vals 2) ,@xpr-yprs) (verbose?))))))))
     599
     600(define (test-all-proc name . test-name-pairs)
     601  ; used internally in test-all, must be exported within test-all
    587602  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
    588603    (cond
    … …  
    604619        (loop (cdr pairs) (cons (cadar pairs) failures))))))
    605620
    606 ;;; (check-all Name check-xpr ....)
    607 ;;; -------------------------------
    608 ;;; checks all check-expressions defined with define-checks
    609 ;;; producing a list of failures and exiting with 0 or 1
     621#|[
     622(test-all Name tester ....)
     623--- macro test-all-proc ---
     624invokes all testers defined with define-tester
     625producing a list of failures and exiting with 0 or 1
     626]|#
     627(define-syntax test-all
     628  (er-macro-transformer
     629    (lambda (form rename compare?)
     630      (let ((name (cadr form))
     631            (tests (cddr form))
     632            (%test-all-proc (rename 'test-all-proc))
     633            (%list (rename 'list))
     634            )
     635        `(,%test-all-proc ',name
     636                          ,@(apply append
     637                                   (map (lambda (t) `((,t) '(,t)))
     638                                        tests)))))))
     639
     640#|[
     641(check-all Name check-xpr ....)
     642--- macro test-all-proc ---
     643Deprecated!
     644checks all check-expressions defined with define-checks
     645producing a list of failures and exiting with 0 or 1
     646]|#
    610647(define-syntax check-all
    611648  (er-macro-transformer
    … …  
    613650      (let ((name (cadr form))
    614651            (checks (cddr form))
    615             (%check-all-proc (rename 'check-all-proc))
     652            (%test-all-proc (rename 'test-all-proc))
    616653            )
    617         `(,%check-all-proc ',name
     654        `(,%test-all-proc ',name
    618655                          ,@(apply append
    619656                                   (map (lambda (t) `(,t ',t))
    620657                                        checks)))))))
    621  ) ; simple-tests
    622 
    623 ;(import simple-tests)
    624 ;
    625 ;(pe '(check ((lst '(0 1 2)))
    626 ;        (car lst)
    627 ;        0
    628 ;        (cdr lst)
    629 ;        '(1 2)))
    630 ;
    631 ;(check ((lst '(0 1 2)))
    632 ;        (car lst)
    633 ;        0
    634 ;        (cdr lst)
    635 ;        '(0 1 2))
    636 ;
    637 ;(pe '(define-checks (foo verbose? lst '(0 1 2))
    638 ;        (car lst)
    639 ;        0
    640 ;        (cdr lst)
    641 ;        '(1 2)))
    642 ;(define-checks (foo verbose? lst '(0 1 2))
    643 ;        (car lst)
    644 ;        0
    645 ;        (cdr lst)
    646 ;        '(1 2 3))
    647 ;(foo #t)
    648 ;(ppp (foo #f))
     658
     659#|[
     660(simple-tests)
     661(simple-tests sym)
     662--- procedure ---
     663documentation procedure
     664]|#
     665(define simple-tests
     666  (let (
     667    (alist '(
     668      (verbose?
     669        parameter:
     670        (verbose? ..)
     671        "gets or sets the value of the parameter verbose?"
     672        )
     673      (writeln
     674        procedure:
     675        (writeln xpr ...)
     676        "write analog of print, expressions separated by whitespace"
     677        )
     678      (and?
     679        procedure:
     680        (and? . xprs)
     681        "non-short-circuited and which executes all side-effects"
     682        )
     683      (pe
     684        macro:
     685        (pe macro-code)
     686        "composes pretty-print and expand with additional information"
     687        )
     688      (xpr:val
     689        macro:
     690        (xpr:val xpr ...)
     691        "Deprecated!"
     692        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     693        "value."
     694        )
     695      (ppp
     696        macro:
     697        (ppp xpr ...)
     698        "print each xpr quoted in a headline and pretty-print xpr's computed"
     699        "value. Alias to xpr:val."
     700        )
     701      (ppp*
     702        macro:
     703        (ppp* {xpr ypr} ...)
     704        "Deprecated!"
     705        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     706        "and expected value, ypr."
     707        )
     708      (xpr:val*
     709        macro:
     710        (xpr:val* {xpr ypr} ...)
     711        "Deprecated!"
     712        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     713        "and expected value, ypr."
     714        "Alias to ppp*"
     715        )
     716      (ppp**
     717        macro:
     718        (ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     719        "Deprecated!"
     720        "ppp* wrapped into a let"
     721        )
     722      (define-test
     723        macro:
     724        (define-test (name . parameters) form . forms)
     725        "Deprecated!"
     726        "Creates a test function"
     727        )
     728      (compound-test
     729        macro:
     730        (compound-test (name) test . tests)
     731        "Deprecated!"
     732        "Invokes all tests and reports a summary"
     733        )
     734      (==
     735        procedure:
     736        (==)
     737        (== x)
     738        (== type? type-equal?)
     739        "Deprecated!"
     740        "Generic type equality as curried procedure"
     741        )
     742      (check
     743        macro:
     744        (check ((var val) ...) xpr ypr . xpr-yprs)
     745        "Compare xpr and ypr .... in sequence with equal?"
     746        "in the environment defined by var val ..."
     747        )
     748      (define-checks
     749        macro:
     750        (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     751        "Deprecated!"
     752        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     753        "and using var val ... within this checks,"
     754        "verbose? controls the reported summary."
     755        )
     756      (do-checks
     757        macro:
     758        (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     759        "Deprecated!"
     760        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     761        "and using var val ... within this checks,"
     762        "alias to define-checks"
     763        )
     764      (define-tester
     765        macro:
     766        (define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     767        "Returns a thunk predicate, name?, comparing xpr with ypr ...."
     768        "and using var val ... within this tests."
     769        "The parameter verbose? controls the reported summary, i. e."
     770        "the side effects."
     771        )
     772      (test-all
     773        macro:
     774        (test-all Name tester ....)
     775        "invokes all testers defined with define-tester"
     776        "producing a list of failures and exiting with 0 or 1"
     777        )
     778      (check-all
     779        macro:
     780        (check-all Name check-xpr ....)
     781        "Deprecated!"
     782        "checks all check-expressions defined with define-checks"
     783        "producing a list of failures and exiting with 0 or 1"
     784        )
     785      (simple-tests
     786        procedure:
     787        (simple-tests)
     788        (simple-tests sym)
     789        "with sym: documentation of exported symbol"
     790        "without sym: list of exported symbols"
     791        )
     792        ))
     793      )
     794      (case-lambda
     795        (() (map car alist))
     796        ((sym)
     797         (let ((pair (assq sym alist)))
     798           (if pair
     799             (for-each print (cdr pair))
     800             (print "Choose one of " (map car alist))))))))
     801)

  • release/5/simple-tests/tags/3.1/tests/run.scm

    r39187 r39584  
    11(import simple-tests)
    22
    3 ;;; old interface
    4 
    5 (define-test (bar n)
    6   (positive? n)
    7   (even? n))
    8 
    9 (define-test (foo x y)
    10   (< x y)
    11   "COMMENT"
    12   (bar 4)
    13   (odd? 3)
    14   (positive? 3))
    15 
    16 (define-test (++)
    17   (= (+ 1 2) 3)
    18   (= (+ 1 2 3) 6))
    19 
    20 (define-test (**)
    21   (= (* 1 2) 2)
    22   (= (* 1 2 3) 6))
    23 
    24 (define-test (arithmetic)
    25   (++)
    26   (**))
    27 
    28 (define-test (baz)
    29   (and? #t #t #t)
    30   (and?)
    31   (not (and? #t #f #t)))
    32 
    33 
    34 ;(compound-test (simple-tests)
    35 ;  (baz)
    36 ;  (arithmetic?)
    37 ;  (foo 1 2)
    38 ;  )
    39 
    40 ;;; new interface
     3(import (only (chicken base) parameterize print case-lambda))
    414
    425(newline)
    43 (print "check")
    44 (print "=====")
    45 (check ((lst '(0 1 2 3)))
    46   lst
    47   '(0 1 2 3)
    48   (car lst)
    49   0
    50   (cadr lst)
    51   1
    52   (cddr lst)
    53   '(2 3)
    54   )
    556
    56 ;;; define-checks is an alias to do-checks
    57 (do-checks (bar? verbose? n 5)
    58   (positive? n) #t
    59   (even? n) #f)
     7(define-test (bar n) (positive? n) (even? n))
    608
    61 (define-checks (+? verbose?)
    62   (+ 1 2) 3
    63   (+ 1 2 3) 6)
     9(bar 5)
    6410
    65 (define-checks (*? verbose?)
    66   (* 1 2) 2
    67   (* 1 2 3) 6)
     11(define-test (foo x y) (< x y) "COMMENT" (bar 4) (odd? 3) (positive? 3))
    6812
    69 (define-checks (arithmetic? verbose?)
    70   (+? #f) #t
    71   (*? #f) #t)
     13(foo 1 2)
    7214
    73 (do-checks (baz? verbose?)
    74   (and? #t #t #t) #t
    75   (and?) #t
    76   (and? #t #f #t) #f)
     15(define-test (++) (= (+ 1 2) 3) (= (+ 1 2 3) 6))
    7716
    78 (define-checks (qux? verbose?)
    79   ((== "x") "y") #f
    80   ((== "x") "x") #t
    81   ((== baz?) baz?) #t
    82   ((== baz?) bar) #f
    83   ((== '()) '()) #t
    84   ((== 'x) 'y) #f
    85   ((== 'x) 'x) #t
    86   ((== #(0 1 2)) #(0 1 2)) #t
    87   ((== #(0 1 2)) '(0 1 2)) #f
    88   )
     17(++)
     18
     19(define-test (**) (= (* 1 2) 2) (= (* 1 2 3) 6))
     20
     21(**)
     22
     23(define-test (arithmetic) (++) (**))
     24
     25(arithmetic)
     26
     27(define-test (baz) (and? #t #t #t) (and?) (not (and? #t #f #t)))
     28
     29(baz)
     30
     31'(compound-test (OLD) (bar 5) (foo 1 2) (++) (**) (arithmetic) (baz))
     32
     33(newline)
     34
     35(do-checks (bar? verbose? n 5) (positive? n) #t (even? n) #f)
     36
     37(bar?)
     38
     39(define-checks (+? verbose?) (+ 1 2) 3 (+ 1 2 3) 6)
     40
     41(+?)
     42
     43(define-checks (*? verbose?) (* 1 2) 2 (* 1 2 3) 6)
     44
     45(*?)
     46
     47(define-checks (arithmetic? verbose?) (+? #f) #t (*? #f) #t)
     48
     49(arithmetic?)
     50
     51(do-checks (baz? verbose?) (and? #t #t #t) #t (and?) #t (and? #t #f #t) #f)
     52
     53(baz?)
     54
     55(define-checks
     56  (qux? verbose?)
     57  ((== "x") "y")
     58  #f
     59  ((== "x") "x")
     60  #t
     61  ((== baz?) baz?)
     62  #t
     63  ((== baz?) bar?)
     64  #f
     65  ((== '()) '())
     66  #t
     67  ((== 'x) 'y)
     68  #f
     69  ((== 'x) 'x)
     70  #t
     71  ((== #(0 1 2)) #(0 1 2))
     72  #t
     73  ((== #(0 1 2)) '(0 1 2))
     74  #f)
     75
     76(qux?)
    8977
    9078(define counter
    91   (let ((n 0))
    92     (lambda ()
    93       (set! n (add1 n))
    94       n)))
     79  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
    9580
    96 (define-checks (counter? verbose?)
    97   (counter) 1
    98   (counter) 2
    99   (counter) 3
    100   (counter) 4
     81(define-checks
     82  (counter? verbose?)
     83  (counter 0)
     84  0
     85  (counter)
     86  1
     87  (counter)
     88  2
     89  (counter)
     90  3
     91  (counter)
     92  4)
     93
     94(counter?)
     95
     96'(check-all NEW (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?) (counter?))
     97
     98(define-tester (Bar? n 5) (positive? n) #t (even? n) #f)
     99
     100(define-tester (Plus?) (+ 1 2) 3 (+ 1 2 3) 6)
     101
     102(define-tester (Times?) (* 1 2) 2 (* 1 2 3) 6)
     103
     104(define-tester
     105  (Arithmetic?)
     106  (parameterize ((verbose? #f)) (Plus?))
     107  #t
     108  (parameterize ((verbose? #f)) (Times?))
     109  #t)
     110
     111(define Counter
     112  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
     113
     114(define-tester
     115  (Counter?)
     116  (Counter 0)
     117  0
     118  (Counter)
     119  1
     120  (Counter)
     121  2
     122  (Counter)
     123  3
     124  (Counter)
     125  4
     126  (Counter 0)
     127  0)
     128
     129'(test-all SIMPLE-TESTS Bar? Times? Plus? Arithmetic? Counter?)
     130
     131(test-all SIMPLE-TESTS
     132  Bar?
     133  Plus?
     134  Times?
     135  Arithmetic?
     136  Counter?
    101137  )
    102 
    103 
    104 (check-all SIMPLE (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?)
    105            (counter?))

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

    r39512 r39584  
    44 (category testing)
    55 (license "BSD")
    6  (version "2.3.2")
     6 (version "3.1")
    77 (author "Juergen Lorenz")
    8  (components (extension simple-tests
    9                         (csc-options "-O3" "-d0"))))
     8 (component-options (csc-options "-O3" "-d1"))
     9 (components (extension simple-tests)))
     10

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

    r39512 r39584  
    1 
    2 ; Author: Juergen Lorenz
    3 ; ju (at) jugilo (dot) de
    4 ;
    5 ; Copyright (c) 2011-2021, Juergen Lorenz
     1; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
    62; All rights reserved.
    73;
    … …  
    1612; notice, this list of conditions and the following disclaimer in the
    1713; documentation and/or other materials provided with the distribution.
    18 ;
    1914; Neither the name of the author nor the names of its contributors may be
    2015; used to endorse or promote products derived from this software without
    2116; specific prior written permission.
    22 ;
     17;  
    2318; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    2419; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
    … …  
    3227; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    3328; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    34 ;
     29
     30
    3531
    3632#|[
    3733This is a simple Unit Test Framework inspired by Peter Seibel's
    3834"Practical Common Lisp" together with some routines which might be
    39 useful for debugging.
    40 A second test interface is added with version 2.0
    41 ]|#
    42 
     35useful for debugging.  It underwent several changes in the maintenance
     36process, most of them are now marked deprecated but are still there in
     37favor of backwards compatibility.
     38
     39For the future, it's sufficient to use only the following six routines,
     40the parameter verbose? and the macros pe, ppp, check, make-tester and
     41test-all.
     42
     43pe, ppp and check are mostly used in the development phase, make-tester
     44and test-all are the actual test routines to go into tests/run.scm.
     45
     46A tester is a nullary predicate which produces a lot of information as
     47side-effects provided the parameter verbose? is true. These testers are
     48invoked in test-all.
     49
     50pe is a combination of pretty-print and expand enhanced with additional
     51text; ppp pretty-prints a list of expressions and its values, while
     52check does the same but accompanies these computed values with expected
     53ones, allowing for local variables in the checks.
     54]|#
    4355
    4456(module simple-tests (
    45   ; common
    46   simple-tests
     57  verbose?
     58  writeln
    4759  and?
    48   writeln
    4960  pe
     61  xpr:val
    5062  ppp
    5163  ppp*
     64  xpr:val*
    5265  ppp**
    53   xpr:val
    54   xpr:val*
     66  (define-test *failures* *locations*)
     67  (compound-test *failures* group-on-cdrs)
    5568  ==
    56   ; old interface
    57   define-test
    58   (compound-test group-on-cdrs)
    59   *locations*
    60   *failures*
    61   ; new interface
    6269  check
    6370  define-checks
    6471  do-checks
    65   (check-all check-all-proc)
     72  define-tester
     73  (test-all test-all-proc)
     74  (check-all test-all-proc)
     75  simple-tests
    6676  )
    6777
    68 (import scheme (chicken base) (chicken syntax) (chicken pretty-print))
     78(import scheme
     79        (only (chicken base)
     80              print case-lambda cut chop exit receive make-parameter)
     81        (only (chicken syntax) expand)
     82        (only (chicken module) import-for-syntax)
     83        (only (chicken pretty-print) pp)
     84        )
    6985
    7086(import-for-syntax (only (chicken base) chop))
    … …  
    7288;;;;;; Common interface ;;;;;;
    7389
    74 ;;; (simple-tests [sym])
    75 ;;; ---------------------
    76 ;;; documentation procedure
    77 (define simple-tests
    78   (let (
    79     (signatures '((simple-tests
    80                     procedure:
    81                     (simple-tests sym ..)
    82                     "documentation procedure")
    83                   (and?
    84                     procedure:
    85                     (and? xpr ...)
    86                     "Pascal like and procedure")
    87                   (writeln
    88                     procedure:
    89                     (writeln xpr ....)
    90                     "write analog of print")
    91                   (pe
    92                     procedure:
    93                     (pe macro-code)
    94                     " composes pretty-print and expand")
    95                   (ppp
    96                     macro:
    97                     (ppp xpr ...)
    98                     " print each xpr quoted in a headline"
    99                     "and pretty-print xpr's computed value")
    100                   (ppp*
    101                     macro:
    102                     (ppp* xpr ypr . xpr-yprs)
    103                     "print each xpr quoted in a headline"
    104                     "and pretty-print xpr's computed and"
    105                     "expected value, ypr")
    106                   (ppp**
    107                     macro:
    108                     (ppp** ((var val) ...) xpr ypr . xpr-yprs)
    109                     "wraps ppp* into a let")
    110                   (xpr:val
    111                     macro:
    112                     (xpr:val xpr ...)
    113                     "alias to ppp")
    114                   (xpr:val*
    115                     macro:
    116                     (xpr:val* xpr ypr . xpr-yprs)
    117                     "alias to ppp*")
    118                   (==
    119                     procedure:
    120                     (==)
    121                     (== x)
    122                     (== type? type-equal?)
    123                     "generic type equality as curried procedure:"
    124                     "the first resets the local database,"
    125                     "the second is the curried equality check"
    126                     "and the third adds a new equality procedure"
    127                     "to the local database")
    128 
    129                   (define-test
    130                     macro:
    131                     (define-test (name . parameters) form . forms)
    132                     "creates a test function")
    133                   (compound-test
    134                     macro:
    135                     (compound-test (name) test . tests)
    136                     "checks all tests created with define-test"
    137                     "and reports a summary of results")
    138 
    139                   (check
    140                     macro:
    141                     (check ((var val) ...) xpr ypr . xpr-yprs)
    142                     "compares xpr and ypr .... with == in the"
    143                     "environment defined by (var val) ...")
    144                   (define-checks
    145                     macro:
    146                     (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    147                     "returns a unary predicate, name?,"
    148                     "comparing xpr with ypr ...."
    149                     "and using var val ... within this checks."
    150                     "verbose? controls the reported results")
    151                   (do-checks
    152                     macro:
    153                     (do-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    154                     "alias to define-checks")
    155                   (check-all
    156                     macro:
    157                     (check-all name check-xpr ....)
    158                     "checks all check-expressions created by do-check"
    159                     "and reports the results")))
    160     )
    161     (case-lambda
    162       (() (map car signatures))
    163       ((sym)
    164        (let ((pair (assq sym signatures)))
    165          (if pair
    166            (for-each print (cdr pair))
    167            (print "Choose one of " (map car signatures))))))))
    168 
     90#|[
     91(verbose? ..)
     92--- parameter ---
     93gets or sets the value of the parameter verbose?
     94]|#
     95(define verbose?
     96  (make-parameter #t
     97                  (lambda (x)
     98                    (if (not x)
     99                      x
     100                      #t))))
     101
     102#|[
     103(writeln xpr ...)
     104--- procedure ---
     105write analog of print, expressions separated by whitespace
     106]|#
    169107(define (writeln . args)
    170108  (for-each (lambda (a)
    … …  
    174112  (newline))
    175113
    176 ;;; (and? . xprs)
    177 ;;; -------------
    178 ;;; non-short-circuited and which executes all side-effects
     114#|[
     115(and? . xprs)
     116--- procedure ---
     117non-short-circuited and which executes all side-effects
     118]|#
    179119(define (and? . xprs)
    180120  (let ((result #t))
    … …  
    183123    result))
    184124
    185 ;;; (pe macro-code)
    186 ;;; ---------------
    187 ;;; composes pretty-print and expand
     125#|[
     126(pe macro-code)
     127--- macro ---
     128composes pretty-print and expand with additional information
     129]|#
    188130(define (pe macro-code)
    189   (pp (expand macro-code)))
    190 
    191 #|[
    192 The following macro, xpr:val, pretty-prints the literal representation
    193 of each of its arguments as well as their respective values.  The call
    194 to eval-when guarantees, that the whole expression does nothing in
    195 compiled code.
    196 ]|#
    197 
    198 ;;; (xpr:val xpr ...)
    199 ;;; -----------------
    200 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    201 ;;; value.
     131  (newline)
     132  (print "Macro expansion:")
     133  (print "----------------")
     134  (pp macro-code)
     135  (print "->")
     136  (pp (expand macro-code))
     137  (print "----------------")
     138  (newline))
     139
     140;;; The following macro, xpr:val, pretty-prints the literal representation
     141;;; of each of its arguments as well as their respective values.  The call
     142;;; to eval-when guarantees, that the whole expression does nothing in
     143;;; compiled code.
     144
     145#|[
     146(xpr:val xpr ...)
     147--- macro ---
     148Deprecated!
     149Print each xpr quoted in a headline and pretty-print xpr's computed
     150value.
     151]|#
    202152(define-syntax xpr:val
    203153  (syntax-rules ()
    … …  
    212162       (else)))))
    213163
    214 ;;; (ppp xpr ...)
    215 ;;; -------------
    216 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    217 ;;; value. Alias to xpr:val.
     164#|[
     165(ppp xpr ...)
     166--- macro ---
     167print each xpr quoted in a headline and pretty-print xpr's computed
     168value. Alias to xpr:val.
     169]|#
    218170(define-syntax ppp
    219171  (syntax-rules ()
    220172    ((_ xpr ...)
    221      (xpr:val xpr ...))))
     173     (cond-expand
     174       ((not compiling)
     175        (begin (print "Computing " 'xpr " ...")
     176               (pp xpr)
     177               )
     178        ...
     179        )
     180       (else)))))
    222181
    223182(define-syntax help-ppp* ; internal
    … …  
    235194    ))
    236195;
    237 ;;;; (ppp* {xpr ypr} ...)
    238 ;;; --------------------
    239 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    240 ;;; and expected value, ypr.
     196#|[
     197(ppp* {xpr ypr} ...)
     198--- macro ---
     199Deprecated!
     200Print each xpr quoted in a headline and pretty-print xpr's computed
     201and expected value, ypr.
     202]|#
    241203(define-syntax ppp*
    242204  (syntax-rules ()
    … …  
    247209       (else)))))
    248210
    249 ;;; (xpr:val* {xpr ypr} ...)
    250 ;;; ------------------------
    251 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    252 ;;; and expected value, ypr.
    253 ;;; Alias to ppp*
    254 (define-syntax xpr:val*
     211#|[
     212(xpr:val* {xpr ypr} ...)
     213--- macro ---
     214Deprecated!
     215Print each xpr quoted in a headline and pretty-print xpr's computed
     216and expected value, ypr.
     217Alias to ppp*
     218]|#
     219(define-syntax xpr:val* ; deprecated
    255220  (syntax-rules ()
    256221    ((_ . pairs)
    257222     (ppp* . pairs))))
    258223
    259 ;;; (ppp** ((var val) ...) xpr ypr . other xpr-ypr-pairs)
    260 ;;; -----------------------------------------------------
    261 ;;; ppp* wrapped into a let
     224#|[
     225(ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     226--- macro ---
     227Deprecated!
     228ppp* wrapped into a let
     229]|#
    262230(define-syntax ppp**
    263231  (syntax-rules ()
    … …  
    268236;;;;;;;; old interface ;;;;;;;;;
    269237
    270 ;; helper macro because I don't want to export it
    271 (define-syntax disp
     238(define-syntax disp ; internal
    272239  (syntax-rules ()
    273240    ((_)
    … …  
    277244;;; ------------------------
    278245;;; reports succuss or failure of form and updates failures if necessary
    279 (define-syntax report-result
     246(define-syntax report-result ; internal
    280247  (syntax-rules ()
    281248    ((_ loc form)
    … …  
    299266         #f)))))
    300267
    301 ;;; (check-em . forms) ;; internal
     268;;; (check-em . forms)
    302269;;; ------------------
    303270;;; report result of all forms
    304 (define-syntax check-em
     271(define-syntax check-em ; internal
    305272  (syntax-rules ()
    306273    ((_ form ...)
    … …  
    309276             ...)))))
    310277
    311 ;; internal helper
    312 (define-syntax show-args
     278(define-syntax show-args ; internal
    313279 (syntax-rules ()
    314280   ((_ (name arg ...))
    … …  
    316282   ((_ arg) arg)))
    317283
    318 ;;; (define-test (name . parameters) form . forms)
    319 ;;; ----------------------------------------------
    320 ;;; creates a test function
     284#|[
     285(define-test (name . parameters) form . forms)
     286--- macro *locations* *failures* ---
     287Deprecated!
     288Creates a test function
     289]|#
    321290(define-syntax define-test
    322291  (syntax-rules ()
    … …  
    329298         ((check-em form . forms) *locations*))))))
    330299
    331 ;;; (compound-test (name) test . tests)
    332 ;;; -----------------------------------
    333 ;;; invokes all tests and reports a summary
     300#|[
     301(compound-test (name) test . tests)
     302--- macro group-on-cdrs *failures* ---
     303Deprecated!
     304Invokes all tests and reports a summary
     305]|#
    334306(define-syntax compound-test
    335307  (syntax-rules ()
    336308    ((_ (name) test0 test1 ...)
    337309     (begin
     310  (writeln "XXX" 'test0 test0 test1 ...) ;;;;;
     311  (writeln "YYY" (and? test0 test1 ...)) ;;;;;
    338312       (print "\nTesting " 'name " ...")
    339313       (print "----------------------------")
    … …  
    362336             (exit 1))))))))
    363337
    364 ;;; internal helper from bindings
     338;;; internal helper
    365339(define (filter ok? lst)
    366340  (let loop ((lst lst) (yes '()) (no '()))
    … …  
    383357        (loop no (cons yes result))))))
    384358
     359;;;*failures*
     360;;; ----------
     361;;; Deprecated!
     362;;; global variable
     363(define *failures* '())
     364
    385365;;; *locations*
    386366;;; -----------
    387 ;;; dynamic variable
     367;;; Deprecated!
     368;;; global variable
    388369(define *locations* '())
    389 
    390 ;;; *failures*
    391 ;;; ----------
    392 ;;; global variable collecting failure information
    393 (define *failures* '())
    394370
    395371;;;;;;; new interface ;;;;;;;;;;;
    … …  
    401377;  (string=? (symbol->string x) (symbol->string y)))
    402378
    403 ;;; (==)
    404 ;;; (== x)
    405 ;;; (== type? type-equal?)
    406 ;;; ----------------------
    407 ;;; generic type equality as curried procedure
     379#|[
     380(==)
     381(== x)
     382(== type? type-equal?)
     383--- procedure ---
     384Deprecated!
     385Generic type equality as curried procedure
     386]|#
    408387(define ==
    409388  (let* ((pairs (list (cons pair? (curry equal?))
    … …  
    438417;;; (check* ((var val) ...) xpr ypr . xpr-yprs) ;; internal
    439418;;; --------------------------------------------------------------
     419(define-syntax check* ; internal
     420  (ir-macro-transformer
     421    (lambda (form inject compare?)
     422      (let ((var-vals (cadr form))
     423            (xpr-yprs (cddr form))
     424            (select-failures
     425              (lambda (pairs)
     426                (let loop ((pairs pairs))
     427                  (cond
     428                    ((null? pairs) '())
     429                    ((caar pairs) (loop (cdr pairs)))
     430                    (else
     431                     (cons (car pairs) (loop (cdr pairs))))))))
     432            )
     433`(lambda (verbose?)
     434   (letrec ,var-vals
     435          (let ((tests '()))
     436            ,@(map (lambda (p)
     437                     `(begin
     438                        (let ((x ,(car p)))
     439                           ; protect against functions changing state
     440                          (when verbose?
     441                            (print "testing " ',(car p) " ...")
     442                            (print* "computed: ") (writeln x)
     443                            (print* "expected: ") (writeln ,(cadr p))
     444                            )
     445                          (set! tests
     446                                (cons (cons ((cut equal? <> x) ,(cadr p))
     447                                            ',(car p))
     448                                      tests)))
     449                                ;(cons (cons ((== x) ,(cadr p)) ',(car p))
     450                                ;            tests)))
     451                          ))
     452                   (chop xpr-yprs 2))
     453            (let ((fails (,select-failures (reverse tests))))
     454              (when verbose?
     455                (print "Failed test expressions:")
     456                (print "------------------------")
     457                (if (null? fails)
     458                  (print "none")
     459                  (for-each print (map cdr fails))))
     460              (if (null? fails) #t #f)))))
     461 ))))
    440462;(define-syntax check*
    441463;  (er-macro-transformer
    … …  
    495517;              (,%if (,%null? ,%fails) #t #f)))))
    496518; ))))
    497 (define-syntax check*
    498   (ir-macro-transformer
    499     (lambda (form inject compare?)
    500       (let ((var-vals (cadr form))
    501             (xpr-yprs (cddr form))
    502             (select-failures
    503               (lambda (pairs)
    504                 (let loop ((pairs pairs))
    505                   (cond
    506                     ((null? pairs) '())
    507                     ((caar pairs) (loop (cdr pairs)))
    508                     (else
    509                      (cons (car pairs) (loop (cdr pairs))))))))
    510             )
    511 `(lambda (verbose?)
    512    (letrec ,var-vals
    513           (let ((tests '()))
    514             ,@(map (lambda (p)
    515                      `(begin
    516                         (let ((x ,(car p)))
    517                            ; protect against functions changing state
    518                           (when verbose?
    519                             (print "testing " ',(car p) " ...")
    520                             (print* "computed: ") (writeln x)
    521                             (print* "expected: ") (writeln ,(cadr p))
    522                             )
    523                           (set! tests
    524                                   (cons (cons ((== x) ,(cadr p)) ',(car p))
    525                                           tests)))
    526                           ))
    527                    (chop xpr-yprs 2))
    528             (let ((fails (,select-failures (reverse tests))))
    529               (when verbose?
    530                 (print "Failed test expressions:")
    531                 (print "------------------------")
    532                 (if (null? fails)
    533                   (print "none")
    534                   (for-each print (map cdr fails))))
    535               (if (null? fails) #t #f)))))
    536  ))))
    537 ;;; (check ((var val) ...) xpr ypr . xpr-yprs)
    538 ;;; ------------------------------------------
    539 ;;; compare xpr and ypr .... in sequence with ==
    540 ;;; in the environment defined by var val ...
     519#|[
     520(check ((var val) ...) xpr ypr . xpr-yprs)
     521--- macro ---
     522Compare xpr and ypr .... in sequence with equal?
     523in the environment defined by var val ...
     524]|#
    541525(define-syntax check
    542526  (syntax-rules ()
    … …  
    544528     ((check* ((var val) ...) xpr ypr . xpr-yprs) #t))))
    545529
    546 ;;; (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    547 ;;; --------------------------------------------------------------
    548 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    549 ;;; and using var val ... within this checks,
    550 ;;; verbose? controls the reported summary.
     530#|[
     531(define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     532--- macro ---
     533Deprecated!
     534Returns a unary predicate, name?, comparing xpr with ypr ....
     535and using var val ... within this checks,
     536verbose? controls the reported summary.
     537]|#
    551538(define-syntax define-checks
    552539  (ir-macro-transformer
    … …  
    572559               ,@xpr-yprs) ,verbose?)))))))))
    573560
    574 ;;; (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
    575 ;;; ---------------------------------------------------------------
    576 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    577 ;;; and using var val ... within this checks,
    578 ;;; alias to define-checks
     561#|[
     562(do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     563--- macro ---
     564Deprecated!
     565Returns a unary predicate, name?, comparing xpr with ypr ....
     566and using var val ... within this checks,
     567alias to define-checks
     568]|#
    579569(define-syntax do-checks
    580570  (syntax-rules ()
    … …  
    583573       xpr ypr .  xpr-ypr-pairs))))
    584574
    585 (define (check-all-proc name . test-name-pairs) ; internal to check-all
    586   ; used internally in check-all, must be exported within check-all
     575#|[
     576(define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     577--- macro ---
     578Returns a thunk predicate, name?, comparing xpr with ypr ....
     579and using var val ... within this tests.
     580The parameter verbose? controls the reported summary, i. e.
     581the side effects.
     582]|#
     583(define-syntax define-tester
     584  (ir-macro-transformer
     585    (lambda (form inject compare?)
     586      (let ((header (cadr form))
     587            (xpr-yprs (cddr form)))
     588        (let ((name (car header))
     589              (var-vals (cdr header)))
     590    `(define (,name)
     591       (when (verbose?)
     592         (print "\nIn " ',name ":")
     593         (print* "==="
     594                 (make-string (string-length
     595                                (symbol->string ',name)) #\=)
     596                 "=\n")
     597         )
     598         ((check* ,(chop var-vals 2) ,@xpr-yprs) (verbose?))))))))
     599
     600(define (test-all-proc name . test-name-pairs)
     601  ; used internally in test-all, must be exported within test-all
    587602  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
    588603    (cond
    … …  
    604619        (loop (cdr pairs) (cons (cadar pairs) failures))))))
    605620
    606 ;;; (check-all Name check-xpr ....)
    607 ;;; -------------------------------
    608 ;;; checks all check-expressions defined with define-checks
    609 ;;; producing a list of failures and exiting with 0 or 1
     621#|[
     622(test-all Name tester ....)
     623--- macro test-all-proc ---
     624invokes all testers defined with define-tester
     625producing a list of failures and exiting with 0 or 1
     626]|#
     627(define-syntax test-all
     628  (er-macro-transformer
     629    (lambda (form rename compare?)
     630      (let ((name (cadr form))
     631            (tests (cddr form))
     632            (%test-all-proc (rename 'test-all-proc))
     633            (%list (rename 'list))
     634            )
     635        `(,%test-all-proc ',name
     636                          ,@(apply append
     637                                   (map (lambda (t) `((,t) '(,t)))
     638                                        tests)))))))
     639
     640#|[
     641(check-all Name check-xpr ....)
     642--- macro test-all-proc ---
     643Deprecated!
     644checks all check-expressions defined with define-checks
     645producing a list of failures and exiting with 0 or 1
     646]|#
    610647(define-syntax check-all
    611648  (er-macro-transformer
    … …  
    613650      (let ((name (cadr form))
    614651            (checks (cddr form))
    615             (%check-all-proc (rename 'check-all-proc))
     652            (%test-all-proc (rename 'test-all-proc))
    616653            )
    617         `(,%check-all-proc ',name
     654        `(,%test-all-proc ',name
    618655                          ,@(apply append
    619656                                   (map (lambda (t) `(,t ',t))
    620657                                        checks)))))))
    621  ) ; simple-tests
    622 
    623 ;(import simple-tests)
    624 ;
    625 ;(pe '(check ((lst '(0 1 2)))
    626 ;        (car lst)
    627 ;        0
    628 ;        (cdr lst)
    629 ;        '(1 2)))
    630 ;
    631 ;(check ((lst '(0 1 2)))
    632 ;        (car lst)
    633 ;        0
    634 ;        (cdr lst)
    635 ;        '(0 1 2))
    636 ;
    637 ;(pe '(define-checks (foo verbose? lst '(0 1 2))
    638 ;        (car lst)
    639 ;        0
    640 ;        (cdr lst)
    641 ;        '(1 2)))
    642 ;(define-checks (foo verbose? lst '(0 1 2))
    643 ;        (car lst)
    644 ;        0
    645 ;        (cdr lst)
    646 ;        '(1 2 3))
    647 ;(foo #t)
    648 ;(ppp (foo #f))
     658
     659#|[
     660(simple-tests)
     661(simple-tests sym)
     662--- procedure ---
     663documentation procedure
     664]|#
     665(define simple-tests
     666  (let (
     667    (alist '(
     668      (verbose?
     669        parameter:
     670        (verbose? ..)
     671        "gets or sets the value of the parameter verbose?"
     672        )
     673      (writeln
     674        procedure:
     675        (writeln xpr ...)
     676        "write analog of print, expressions separated by whitespace"
     677        )
     678      (and?
     679        procedure:
     680        (and? . xprs)
     681        "non-short-circuited and which executes all side-effects"
     682        )
     683      (pe
     684        macro:
     685        (pe macro-code)
     686        "composes pretty-print and expand with additional information"
     687        )
     688      (xpr:val
     689        macro:
     690        (xpr:val xpr ...)
     691        "Deprecated!"
     692        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     693        "value."
     694        )
     695      (ppp
     696        macro:
     697        (ppp xpr ...)
     698        "print each xpr quoted in a headline and pretty-print xpr's computed"
     699        "value. Alias to xpr:val."
     700        )
     701      (ppp*
     702        macro:
     703        (ppp* {xpr ypr} ...)
     704        "Deprecated!"
     705        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     706        "and expected value, ypr."
     707        )
     708      (xpr:val*
     709        macro:
     710        (xpr:val* {xpr ypr} ...)
     711        "Deprecated!"
     712        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     713        "and expected value, ypr."
     714        "Alias to ppp*"
     715        )
     716      (ppp**
     717        macro:
     718        (ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     719        "Deprecated!"
     720        "ppp* wrapped into a let"
     721        )
     722      (define-test
     723        macro:
     724        (define-test (name . parameters) form . forms)
     725        "Deprecated!"
     726        "Creates a test function"
     727        )
     728      (compound-test
     729        macro:
     730        (compound-test (name) test . tests)
     731        "Deprecated!"
     732        "Invokes all tests and reports a summary"
     733        )
     734      (==
     735        procedure:
     736        (==)
     737        (== x)
     738        (== type? type-equal?)
     739        "Deprecated!"
     740        "Generic type equality as curried procedure"
     741        )
     742      (check
     743        macro:
     744        (check ((var val) ...) xpr ypr . xpr-yprs)
     745        "Compare xpr and ypr .... in sequence with equal?"
     746        "in the environment defined by var val ..."
     747        )
     748      (define-checks
     749        macro:
     750        (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     751        "Deprecated!"
     752        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     753        "and using var val ... within this checks,"
     754        "verbose? controls the reported summary."
     755        )
     756      (do-checks
     757        macro:
     758        (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     759        "Deprecated!"
     760        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     761        "and using var val ... within this checks,"
     762        "alias to define-checks"
     763        )
     764      (define-tester
     765        macro:
     766        (define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     767        "Returns a thunk predicate, name?, comparing xpr with ypr ...."
     768        "and using var val ... within this tests."
     769        "The parameter verbose? controls the reported summary, i. e."
     770        "the side effects."
     771        )
     772      (test-all
     773        macro:
     774        (test-all Name tester ....)
     775        "invokes all testers defined with define-tester"
     776        "producing a list of failures and exiting with 0 or 1"
     777        )
     778      (check-all
     779        macro:
     780        (check-all Name check-xpr ....)
     781        "Deprecated!"
     782        "checks all check-expressions defined with define-checks"
     783        "producing a list of failures and exiting with 0 or 1"
     784        )
     785      (simple-tests
     786        procedure:
     787        (simple-tests)
     788        (simple-tests sym)
     789        "with sym: documentation of exported symbol"
     790        "without sym: list of exported symbols"
     791        )
     792        ))
     793      )
     794      (case-lambda
     795        (() (map car alist))
     796        ((sym)
     797         (let ((pair (assq sym alist)))
     798           (if pair
     799             (for-each print (cdr pair))
     800             (print "Choose one of " (map car alist))))))))
     801)

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

    r39187 r39584  
    11(import simple-tests)
    22
    3 ;;; old interface
    4 
    5 (define-test (bar n)
    6   (positive? n)
    7   (even? n))
    8 
    9 (define-test (foo x y)
    10   (< x y)
    11   "COMMENT"
    12   (bar 4)
    13   (odd? 3)
    14   (positive? 3))
    15 
    16 (define-test (++)
    17   (= (+ 1 2) 3)
    18   (= (+ 1 2 3) 6))
    19 
    20 (define-test (**)
    21   (= (* 1 2) 2)
    22   (= (* 1 2 3) 6))
    23 
    24 (define-test (arithmetic)
    25   (++)
    26   (**))
    27 
    28 (define-test (baz)
    29   (and? #t #t #t)
    30   (and?)
    31   (not (and? #t #f #t)))
    32 
    33 
    34 ;(compound-test (simple-tests)
    35 ;  (baz)
    36 ;  (arithmetic?)
    37 ;  (foo 1 2)
    38 ;  )
    39 
    40 ;;; new interface
     3(import (only (chicken base) parameterize print case-lambda))
    414
    425(newline)
    43 (print "check")
    44 (print "=====")
    45 (check ((lst '(0 1 2 3)))
    46   lst
    47   '(0 1 2 3)
    48   (car lst)
    49   0
    50   (cadr lst)
    51   1
    52   (cddr lst)
    53   '(2 3)
    54   )
    556
    56 ;;; define-checks is an alias to do-checks
    57 (do-checks (bar? verbose? n 5)
    58   (positive? n) #t
    59   (even? n) #f)
     7(define-test (bar n) (positive? n) (even? n))
    608
    61 (define-checks (+? verbose?)
    62   (+ 1 2) 3
    63   (+ 1 2 3) 6)
     9(bar 5)
    6410
    65 (define-checks (*? verbose?)
    66   (* 1 2) 2
    67   (* 1 2 3) 6)
     11(define-test (foo x y) (< x y) "COMMENT" (bar 4) (odd? 3) (positive? 3))
    6812
    69 (define-checks (arithmetic? verbose?)
    70   (+? #f) #t
    71   (*? #f) #t)
     13(foo 1 2)
    7214
    73 (do-checks (baz? verbose?)
    74   (and? #t #t #t) #t
    75   (and?) #t
    76   (and? #t #f #t) #f)
     15(define-test (++) (= (+ 1 2) 3) (= (+ 1 2 3) 6))
    7716
    78 (define-checks (qux? verbose?)
    79   ((== "x") "y") #f
    80   ((== "x") "x") #t
    81   ((== baz?) baz?) #t
    82   ((== baz?) bar) #f
    83   ((== '()) '()) #t
    84   ((== 'x) 'y) #f
    85   ((== 'x) 'x) #t
    86   ((== #(0 1 2)) #(0 1 2)) #t
    87   ((== #(0 1 2)) '(0 1 2)) #f
    88   )
     17(++)
     18
     19(define-test (**) (= (* 1 2) 2) (= (* 1 2 3) 6))
     20
     21(**)
     22
     23(define-test (arithmetic) (++) (**))
     24
     25(arithmetic)
     26
     27(define-test (baz) (and? #t #t #t) (and?) (not (and? #t #f #t)))
     28
     29(baz)
     30
     31'(compound-test (OLD) (bar 5) (foo 1 2) (++) (**) (arithmetic) (baz))
     32
     33(newline)
     34
     35(do-checks (bar? verbose? n 5) (positive? n) #t (even? n) #f)
     36
     37(bar?)
     38
     39(define-checks (+? verbose?) (+ 1 2) 3 (+ 1 2 3) 6)
     40
     41(+?)
     42
     43(define-checks (*? verbose?) (* 1 2) 2 (* 1 2 3) 6)
     44
     45(*?)
     46
     47(define-checks (arithmetic? verbose?) (+? #f) #t (*? #f) #t)
     48
     49(arithmetic?)
     50
     51(do-checks (baz? verbose?) (and? #t #t #t) #t (and?) #t (and? #t #f #t) #f)
     52
     53(baz?)
     54
     55(define-checks
     56  (qux? verbose?)
     57  ((== "x") "y")
     58  #f
     59  ((== "x") "x")
     60  #t
     61  ((== baz?) baz?)
     62  #t
     63  ((== baz?) bar?)
     64  #f
     65  ((== '()) '())
     66  #t
     67  ((== 'x) 'y)
     68  #f
     69  ((== 'x) 'x)
     70  #t
     71  ((== #(0 1 2)) #(0 1 2))
     72  #t
     73  ((== #(0 1 2)) '(0 1 2))
     74  #f)
     75
     76(qux?)
    8977
    9078(define counter
    91   (let ((n 0))
    92     (lambda ()
    93       (set! n (add1 n))
    94       n)))
     79  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
    9580
    96 (define-checks (counter? verbose?)
    97   (counter) 1
    98   (counter) 2
    99   (counter) 3
    100   (counter) 4
     81(define-checks
     82  (counter? verbose?)
     83  (counter 0)
     84  0
     85  (counter)
     86  1
     87  (counter)
     88  2
     89  (counter)
     90  3
     91  (counter)
     92  4)
     93
     94(counter?)
     95
     96'(check-all NEW (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?) (counter?))
     97
     98(define-tester (Bar? n 5) (positive? n) #t (even? n) #f)
     99
     100(define-tester (Plus?) (+ 1 2) 3 (+ 1 2 3) 6)
     101
     102(define-tester (Times?) (* 1 2) 2 (* 1 2 3) 6)
     103
     104(define-tester
     105  (Arithmetic?)
     106  (parameterize ((verbose? #f)) (Plus?))
     107  #t
     108  (parameterize ((verbose? #f)) (Times?))
     109  #t)
     110
     111(define Counter
     112  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
     113
     114(define-tester
     115  (Counter?)
     116  (Counter 0)
     117  0
     118  (Counter)
     119  1
     120  (Counter)
     121  2
     122  (Counter)
     123  3
     124  (Counter)
     125  4
     126  (Counter 0)
     127  0)
     128
     129'(test-all SIMPLE-TESTS Bar? Times? Plus? Arithmetic? Counter?)
     130
     131(test-all SIMPLE-TESTS
     132  Bar?
     133  Plus?
     134  Times?
     135  Arithmetic?
     136  Counter?
    101137  )
    102 
    103 
    104 (check-all SIMPLE (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?)
    105            (counter?))
Note: See TracChangeset for help on using the changeset viewer.