Changeset 3 in project


Ignore:
Timestamp:
11/01/05 14:38:28 (14 years ago)
Author:
felix
Message:

udp/test-infrastructure changes; added futures

Files:
7 added
8 edited

Legend:

Unmodified
Added
Removed

  • bb/bb.html

    r1 r3  
    339339
    340340</dd><dt><pre>selection</pre>
    341 </dt><dd>The currently selected text an <code>entry</code>, <code>edit</code> or <code>text-editor</code> widget.
     341</dt><dd>The currently selected text in an <code>entry</code>, <code>edit</code> or <code>text-editor</code> widget.
    342342When set, the value should be a pair containing start and end position of the selection in the buffer.
    343343

  • test-infrastructure/test-infrastructure-base.scm

    r1 r3  
    88;;;; or anyone else liable for any use of this source code. Please try to keep
    99;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.
     10
     11;;;; Modifications Kon Lovett, Oct 15 2005
    1012
    1113(include "test-infrastructure.scm")
    … …  
    317319                        (list-ref res 5)
    318320                        'not-a-package-case-result))) ;; XXX Hmm....
     321
     322;;;;;;;;;;;;;;;;;;
     323;; test-case-clause-result?
     324;; Is the value any kind of result, except test-package or test-case?
     325;;;;;;;;;;;;;;;;;;
     326(define (test:test-case-clause-result? v)
     327        (or
     328                ;; XXX There might be a better way to do this check for
     329                ;; truth. I don't like this use of type checking functions
     330                ;; here... It causes you to modify this when you add a new
     331                ;; expectation type.
     332                (and    (expect-result? v)
     333                                (equal? #t
     334                                        (expect-result-result-ref v)))
     335                (and    (expect-equivalence-result? v)
     336                                (equal? #t
     337                                        (expect-equivalence-result-result-ref v)))
     338                (and    (expect-tolerance-result? v)
     339                                (equal? #t
     340                                        (expect-tolerance-result-result-ref v)))
     341
     342                ;; assume ignored results are true for this macro so you
     343                ;; can keep evaluating.
     344                (ignore-result? v)
     345
     346                ;; assume skipped results are true for this macro so you
     347                ;; can keep evaluating.
     348                (skip-result? v)
     349
     350                ;; assume todo results are true for this macro so you
     351                ;; can keep evaluating.
     352                (todo-result? v)
     353
     354                ;; assume gloss results are true for this macro so you
     355                ;; can keep evaluating.
     356                (gloss-result? v)))
     357
     358;;;;;;;;;;;;;;;;;;
     359;;make-unexpected-exception-result
     360;;;;;;;;;;;;;;;;;;
     361(define (test:make-unexpected-exception-result curr-clause the-exception)
     362        (test:make-expect-result #f "UNKNOWN" "Unexpected Exception" curr-clause the-exception))
     363
    319364
    320365;;;;;;;;;;;;;;;;;;
    … …  
    11811226;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    11821227;; expect-exception support.
    1183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1184 (define (test:has-condition-property pred exp)
    1185         (and (condition-case (pred exp) [var () #f]) (pred exp)))
     1228;; (see test:gen-exception-property-test)
     1229;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1230#;(define (test:has-condition-property pred exp)
     1231        ; assumes the only exception will be from a missing property
     1232        (and (condition-case (pred exp) [() #f]) (pred exp)))
    11861233
    11871234
    … …  
    11891236;; expect-exception: Expect an exception.
    11901237;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1191 (define (test:_expect-exception msg exn val)
    1192         val)
     1238(define (test:_expect-exception msg exn val caught)
     1239        (and caught val))
    11931240
    11941241;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    16661713                (apply printnl args)))
    16671714
     1715;; print something at an indention level + 2
     1716(define printinl/+2
     1717        (lambda (indent . args)
     1718                (test:indent (+ indent 2))
     1719                (apply printnl args)))
     1720
    16681721;; print something at an indention level
    16691722(define printime
    … …  
    17321785                                        (expect-result-warning-ref resnode))))
    17331786
    1734                         (printinl (+ indent 2) "Unevaluated: ")
    1735                         (printinl (+ indent 2) (expect-result-unevaled-ref resnode))
    1736                         (printinl (+ indent 2) "Evaluated: ")
    1737                         (printinl (+ indent 2) (expect-result-evaled-ref resnode))
     1787                        (printinl/+2 indent "Unevaluated: ")
     1788                        (printinl/+2 indent (expect-result-unevaled-ref resnode))
     1789                        (printinl/+2 indent "Evaluated: ")
     1790                        (printinl/+2 indent (expect-result-evaled-ref resnode))
    17381791                        (printinl indent "Result: " (expect-result-result-ref resnode))
    17391792                        (printinl indent
    … …  
    17541807                                        (expect-tolerance-result-warning-ref resnode))))
    17551808
    1756                         (printinl (+ indent 2) "Expected Value: ")
    1757                         (printinl (+ indent 2)
     1809                        (printinl/+2 indent "Expected Value: ")
     1810                        (printinl/+2 indent
    17581811                                (expect-tolerance-result-lhs-evaled-ref resnode))
    1759                         (printinl (+ indent 2) "Expected Tolerance: ")
    1760                         (printinl (+ indent 2)
     1812                        (printinl/+2 indent "Expected Tolerance: ")
     1813                        (printinl/+2 indent
    17611814                                (expect-tolerance-result-lhs-tol-evaled-ref resnode))
    1762                         (printinl (+ indent 2) "Unevaluated: ")
    1763                         (printinl (+ indent 2)
     1815                        (printinl/+2 indent "Unevaluated: ")
     1816                        (printinl/+2 indent
    17641817                                (expect-tolerance-result-rhs-unevaled-ref resnode))
    1765                         (printinl (+ indent 2) "Evaluated: ")
    1766                         (printinl (+ indent 2)
     1818                        (printinl/+2 indent "Evaluated: ")
     1819                        (printinl/+2 indent
    17671820                                (expect-tolerance-result-rhs-evaled-ref resnode))
    17681821                        (printinl indent "Result: "
    … …  
    17871840                                        (expect-equivalence-result-warning-ref resnode))))
    17881841
    1789                         (printinl (+ indent 2) "Expected Value: ")
    1790                         (printinl (+ indent 2)
     1842                        (printinl/+2 indent "Expected Value: ")
     1843                        (printinl/+2 indent
    17911844                                (expect-equivalence-result-lhs-evaled-ref resnode))
    1792                         (printinl (+ indent 2) "Unevaluated: ")
    1793                         (printinl (+ indent 2)
     1845                        (printinl/+2 indent "Unevaluated: ")
     1846                        (printinl/+2 indent
    17941847                                (expect-equivalence-result-rhs-unevaled-ref resnode))
    1795                         (printinl (+ indent 2) "Evaluated: ")
    1796                         (printinl (+ indent 2)
     1848                        (printinl/+2 indent "Evaluated: ")
     1849                        (printinl/+2 indent
    17971850                                (expect-equivalence-result-rhs-evaled-ref resnode))
    17981851                        (printinl indent "Result: "
    … …  
    18071860                ((terminate-result? resnode)
    18081861                        (printinl indent "Begin TERMINATION")
    1809                         (printinl (+ indent 2)
     1862                        (printinl/+2 indent
    18101863                                "Message: " (terminate-result-message-ref resnode))
    1811                         (printinl (+ indent 2)
     1864                        (printinl/+2 indent
    18121865                                "Container: " (terminate-result-container-ref resnode))
    1813                         (printinl (+ indent 2)
     1866                        (printinl/+2 indent
    18141867                                "Scope: " (terminate-result-scope-ref resnode))
    18151868                        (printinl indent
    … …  
    24962549                        ;; dump out any warnings...
    24972550                        (cond ((test-package-result-warning? resnode)
    2498                                 (printinl (+ indent 2) "WARNING: '"
     2551                                (printinl/+2 indent "WARNING: '"
    24992552                                        (test-package-result-warning-ref resnode) "'")))
    25002553
    … …  
    25122565                                                " - Passed")
    25132566                                        (cond ((test-case-result-warning? resnode)
    2514                                                         (printinl (+ indent 2) "WARNING: '"
     2567                                                        (printinl/+2 indent "WARNING: '"
    25152568                                                                (test-case-result-warning-ref resnode) "'"))))
    25162569                                (begin
    … …  
    25182571                                                (test-case-result-message-ref resnode) "' - Failed")
    25192572                                        (cond ((test-case-result-warning? resnode)
    2520                                                         (printinl (+ indent 2) "WARNING: '"
     2573                                                        (printinl/+2 indent "WARNING: '"
    25212574                                                                (test-case-result-warning-ref resnode) "'")))
    25222575
    … …  
    25292582                ((expect-result? resnode)
    25302583                        (printinl indent
    2531                                 "Expectation '" (expect-result-message-ref resnode) "'"
    2532                                 (if (expect-result-result-ref resnode)
    2533                                         ": Passed"
    2534                                         ": Failed"))
    2535                         (cond ((eq? (expect-result-result-ref resnode) #f)
    2536                                 (printinl (+ indent 2) "Expect Type: 'Expect "
    2537                                         (expect-result-specific-ref resnode) "'")
    2538                                 (cond ((expect-result-warning? resnode)
    2539                                                 (printinl (+ indent 4) "WARNING: "
    2540                                                         (expect-result-warning-ref resnode))))
    2541 
    2542                                         (printinl (+ indent 4) "Unevaluated: ")
    2543                                         (printinl (+ indent 6) (expect-result-unevaled-ref resnode))
    2544                                         (printinl (+ indent 4) "Evaluated: ")
    2545                                         (printinl (+ indent 6) (expect-result-evaled-ref resnode)))))
     2584                                "Begin Expectation: "
     2585                                        (expect-result-message-ref resnode) " ")
     2586                        (printinl indent "Expect "
     2587                                (expect-result-specific-ref resnode))
     2588
     2589                        (cond
     2590                                ((not (expect-result-result-ref resnode))
     2591
     2592                                        ;; dump out any warnings...
     2593                                        (cond ((expect-result-warning? resnode)
     2594                                                        (printinl indent "WARNING: "
     2595                                                                (expect-result-warning-ref resnode))))
     2596
     2597                                        (printinl/+2 indent "Unevaluated: ")
     2598                                        (printinl/+2 indent (expect-result-unevaled-ref resnode))
     2599                                        (printinl/+2 indent "Evaluated: ")
     2600                                        (printinl/+2 indent (expect-result-evaled-ref resnode))
     2601                                        (printinl indent "Result: Failed"))
     2602
     2603                                (else
     2604                                        (printinl indent "Result: Passed")))
     2605
     2606                        (printinl indent
     2607                                "End Expectation: "
     2608                                        (expect-result-message-ref resnode))
     2609                        (newline))
    25462610
    25472611                ;; print out an expect-tolerance-result
    … …  
    25532617                                (expect-tolerance-result-specific-ref resnode))
    25542618
    2555                         ;; dump out any warnings...
    2556                         (cond ((expect-tolerance-result-warning? resnode)
    2557                                 (printinl indent "WARNING: "
    2558                                         (expect-tolerance-result-warning-ref resnode))))
    2559 
    2560                         (printinl (+ indent 2) "Expected Value: ")
    2561                         (printinl (+ indent 2)
    2562                                 (expect-tolerance-result-lhs-evaled-ref resnode))
    2563                         (printinl (+ indent 2) "Expected Tolerance: ")
    2564                         (printinl (+ indent 2)
    2565                                 (expect-tolerance-result-lhs-tol-evaled-ref resnode))
    2566                         (printinl (+ indent 2) "Unevaluated: ")
    2567                         (printinl (+ indent 2)
    2568                                 (expect-tolerance-result-rhs-unevaled-ref resnode))
    2569                         (printinl (+ indent 2) "Evaluated: ")
    2570                         (printinl (+ indent 2)
    2571                                 (expect-tolerance-result-rhs-evaled-ref resnode))
    2572                         (printinl indent "Result: "
    2573                                 (expect-tolerance-result-result-ref resnode))
     2619                        (cond
     2620                                ((not (expect-tolerance-result-result-ref resnode))
     2621
     2622                                        ;; dump out any warnings...
     2623                                        (cond ((expect-tolerance-result-warning? resnode)
     2624                                                (printinl indent "WARNING: "
     2625                                                        (expect-tolerance-result-warning-ref resnode))))
     2626
     2627                                        (printinl/+2 indent "Expected Value: ")
     2628                                        (printinl/+2 indent
     2629                                                (expect-tolerance-result-lhs-evaled-ref resnode))
     2630                                        (printinl/+2 indent "Expected Tolerance: ")
     2631                                        (printinl/+2 indent
     2632                                                (expect-tolerance-result-lhs-tol-evaled-ref resnode))
     2633                                        (printinl/+2 indent "Unevaluated: ")
     2634                                        (printinl/+2 indent
     2635                                                (expect-tolerance-result-rhs-unevaled-ref resnode))
     2636                                        (printinl/+2 indent "Evaluated: ")
     2637                                        (printinl/+2 indent
     2638                                                (expect-tolerance-result-rhs-evaled-ref resnode))
     2639                                                (printinl indent "Result: Failed"))
     2640
     2641                                (else
     2642                                        (printinl indent "Result: Passed")))
    25742643
    25752644                        (printinl indent
    … …  
    25862655                                (expect-equivalence-result-specific-ref resnode))
    25872656
    2588                         ;; dump out any warnings...
    2589                         (cond ((expect-equivalence-result-warning? resnode)
    2590                                 (printinl indent "WARNING: '"
    2591                                         (expect-equivalence-result-warning-ref resnode) "'")))
    2592 
    2593                         (printinl (+ indent 2) "Expected Value: ")
    2594                         (printinl (+ indent 2)
    2595                                 (expect-equivalence-result-lhs-evaled-ref resnode))
    2596                         (printinl (+ indent 2) "Unevaluated: ")
    2597                         (printinl (+ indent 2)
    2598                                 (expect-equivalence-result-rhs-unevaled-ref resnode))
    2599                         (printinl (+ indent 2) "Evaluated: ")
    2600                         (printinl (+ indent 2)
    2601                                 (expect-equivalence-result-rhs-evaled-ref resnode))
    2602                         (printinl indent "Result: "
    2603                                 (expect-equivalence-result-result-ref resnode))
     2657                        (cond
     2658                                ((not (expect-equivalence-result-result-ref resnode))
     2659
     2660                                        ;; dump out any warnings...
     2661                                        (cond ((expect-equivalence-result-warning? resnode)
     2662                                                (printinl indent "WARNING: '"
     2663                                                        (expect-equivalence-result-warning-ref resnode) "'")))
     2664
     2665                                        (printinl/+2 indent "Expected Value: ")
     2666                                        (printinl/+2 indent
     2667                                                (expect-equivalence-result-lhs-evaled-ref resnode))
     2668                                        (printinl/+2 indent "Unevaluated: ")
     2669                                        (printinl/+2 indent
     2670                                                (expect-equivalence-result-rhs-unevaled-ref resnode))
     2671                                        (printinl/+2 indent "Evaluated: ")
     2672                                        (printinl/+2 indent
     2673                                                (expect-equivalence-result-rhs-evaled-ref resnode))
     2674                                        (printinl indent "Result: Failed"))
     2675
     2676                                (else
     2677                                        (printinl indent "Result: Passed")))
    26042678
    26052679                        (printinl indent
    … …  
    26112685                ((terminate-result? resnode)
    26122686                        (printinl indent "Begin TERMINATION")
    2613                         (printinl (+ indent 2)
     2687                        (printinl/+2 indent
    26142688                                "Message: '" (terminate-result-message-ref resnode) "'")
    2615                         (printinl (+ indent 2)
     2689                        (printinl/+2 indent
    26162690                                "Container: " (terminate-result-container-ref resnode))
    2617                         (printinl (+ indent 2)
     2691                        (printinl/+2 indent
    26182692                                "Scope: " (terminate-result-scope-ref resnode))
    26192693                        (printinl indent
    … …  
    26232697                ;; print out any gloss message the user might have inserted somewhere.
    26242698                ((gloss-result? resnode)
    2625                         (printinl (+ indent 2) "Gloss: '" (gloss-result-message-ref
     2699                        (printinl/+2 indent "Gloss: '" (gloss-result-message-ref
    26262700                                        resnode) "'")
    26272701                        ;; dump out any warnings...
    26282702                        (cond ((gloss-result-warning? resnode)
    2629                                 (printinl (+ indent 2) "WARNING: "
     2703                                (printinl/+2 indent "WARNING: "
    26302704                                        (gloss-result-warning-ref resnode)))))
    26312705

  • test-infrastructure/test-infrastructure.html

    r1 r3  
    1313<h3>Author:</h3>
    1414Peter Keller
     15
     16<h3>Version</h3>
     17<ul>
     18<lI>1.1
     19Added several enhancements [by Kon Lovett]
     20<li>1.0
     21</ul>
    1522
    1623<h3>Usage:</h3>

  • test-infrastructure/test-infrastructure.meta

    r1 r3  
    99        "test-infrastructure-base.scm"
    1010        "test-infrastructure.scm"
     11        "test-infrastructure.html"
    1112        "test-test-infrastructure.scm"))

  • test-infrastructure/test-infrastructure.scm

    r1 r3  
    99;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.
    1010
     11;;;; Modifications Kon Lovett, Oct 15 2005
     12
     13;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     14;; Wrap clause evaluation in an exception handler
     15;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     16(define-syntax test:eval-clause-wrap
     17        (syntax-rules ()
     18                ((_ CURR-CLAUSE RESULTS EVAL-FORM)
     19                        (call/cc
     20                                (lambda (escape)
     21                                        #;EVAL-FORM
     22                                        (with-exception-handler
     23                                                (lambda (the-exception)
     24                                                        (escape
     25                                                                (set! RESULTS
     26                                                                        (cons (test:make-unexpected-exception-result
     27                                                                                CURR-CLAUSE the-exception) RESULTS))))
     28                                                (lambda () EVAL-FORM)))))))
     29
    1130;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1231;; perform a left to right evaluation of a list of expectations stopping at
    … …  
    1534;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1635(define-syntax test:eval-expectations
    17 (syntax-rules ()
    18         ((_ exp)
    19                 (list exp))
    20 
    21         ((_ exp-head exp-tail ...)
    22                 (let ((head exp-head)) ;; evaluate exp-head right here!
    23                         (cond
    24                         ((or
    25                                 ;; XXX There might be a better way to do this check for
    26                                 ;; truth. I don't like this use of type checking functions
    27                                 ;; here... It causes you to modify this when you add a new
    28                                 ;; expectation type.
    29                                 (and    (expect-result? head)
    30                                                 (equal? #t
    31                                                         (expect-result-result-ref head)))
    32                                 (and    (expect-equivalence-result? head)
    33                                                 (equal? #t
    34                                                         (expect-equivalence-result-result-ref head)))
    35                                 (and    (expect-tolerance-result? head)
    36                                                 (equal? #t
    37                                                         (expect-tolerance-result-result-ref head)))
    38 
    39                                 ;; assume ignored results are true for this macro so you
    40                                 ;; can keep evaluating.
    41                                 (ignore-result? head)
    42 
    43                                 ;; assume skipped results are true for this macro so you
    44                                 ;; can keep evaluating.
    45                                 (skip-result? head)
    46 
    47                                 ;; assume todo results are true for this macro so you
    48                                 ;; can keep evaluating.
    49                                 (todo-result? head)
    50 
    51                                 ;; assume gloss results are true for this macro so you
    52                                 ;; can keep evaluating.
    53                                 (gloss-result? head))
    54 
    55                                 ;; only continue evaluating down the list if the expectation
    56                                 ;; turned out to be true
    57                                 (cons head (test:eval-expectations exp-tail ...)))
    58 
    59                         (else ;; save the first false one in the master list
    60                                 (list head)))))))
     36  (syntax-rules ()
     37        ((_ CURR-CLAUSE RESULTS EXP)
     38                (begin
     39                        (set! CURR-CLAUSE 'EXP)
     40                        (set! RESULTS (cons EXP RESULTS))))
     41
     42        ((_ CURR-CLAUSE RESULTS EXP-HEAD EXP-TAIL ...)
     43                (begin
     44                        (set! CURR-CLAUSE 'EXP-HEAD)
     45                        (let ((head EXP-HEAD)) ;; evaluate EXP-HEAD right here!
     46                                        ;; save the result, true or false, in the master list
     47                                (set! RESULTS (cons head RESULTS))
     48                                (if (test:test-case-clause-result? head)
     49                                                ;; only continue evaluating down the list if the expectation
     50                                                ;; turned out to be true
     51                                        (test:eval-expectations CURR-CLAUSE RESULTS EXP-TAIL ...)))))))
    6152
    6253;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    6657(define-syntax test:eval-lr
    6758        (syntax-rules ()
    68                 ((_ exp)
    69                         (list exp))
    70 
    71                 ((_ exp-head exp-tail ...)
    72                         (let ((head exp-head)) ;; evaluate exp-head right here!
    73                                 (cons head (test:eval-lr exp-tail ...))))))
     59                ((_ CURR-CLAUSE RESULTS EXP)
     60                        (begin
     61                                (set! CURR-CLAUSE 'EXP)
     62                                (set! RESULTS (cons EXP RESULTS))))
     63
     64                ((_ CURR-CLAUSE RESULTS EXP-HEAD EXP-TAIL ...)
     65                        (begin
     66                                (set! CURR-CLAUSE 'EXP-HEAD)
     67                                (let ((head EXP-HEAD)) ;; evaluate EXP-HEAD right here!
     68                                        (set! RESULTS (cons head RESULTS))
     69                                        (test:eval-lr CURR-CLAUSE RESULTS EXP-TAIL ...))))))
    7470
    7571;; this is the definition of the macro test-case:
    … …  
    105101                        (tname testname)
    106102                        (destname (test:make-destructor)))
    107           (let ((test-result
    108                  (call-with-current-continuation
    109                   (lambda (escape)
    110                     (test:eval-expectations clauses ...)))))
     103          (let ([curr-clause '()] [test-result '()])
     104                (test:eval-clause-wrap curr-clause test-result
     105                        (test:eval-expectations curr-clause test-result clauses ...))
    111106                ;; call the destructor to get rid of anything the user didn't want
    112107                (destructor-activate! destname)
    113                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     108                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    114109                        ;; If the user exited via the terminate mechanism, then record this
    115110                        ;; fact with a real terminate node in the tree.
    116111                (cond ((terminate? stripped-test-result)
    117                                 (set! test-result
     112                                (set! stripped-test-result
    118113                                        (list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
    119114                        ;; return the typed list for this kind of test result
    120                 (test:make-test-case-result (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj))))) value ...))
     115                (test:make-test-case-result (all-testcase-expectations-true? stripped-test-result)
     116                        tname stripped-test-result warnobj))))) value ...))
    121117
    122118    ;; support the optional let bindings
    … …  
    124120     ((lambda (name ...)
    125121        (let ((tname testname) (destname (test:make-destructor)))
    126           (let ((test-result
    127                  (call-with-current-continuation
    128                   (lambda (escape)
    129                     (test:eval-expectations clauses ...)))))
     122          (let ([curr-clause '()] [test-result '()])
     123                (test:eval-clause-wrap curr-clause test-result
     124                        (test:eval-expectations curr-clause test-result clauses ...))
    130125                ;; call the destructor to get rid of anything the user didn't want
    131126                (destructor-activate! destname)
    132                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     127                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    133128                        ;; If the user exited via the terminate mechanism, then record this
    134129                        ;; fact with a real terminate node in the tree.
    … …  
    138133                        ;; return the typed list for this kind of test result
    139134                (test:make-test-case-result
    140                                 (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result))))) value ...))
     135                                (all-testcase-expectations-true? stripped-test-result)
     136                                        tname stripped-test-result))))) value ...))
    141137
    142138
    … …  
    146142                        (tname testname)
    147143                        (destname (test:make-destructor)))
    148        (let ((test-result
    149               (call-with-current-continuation
    150                (lambda (escape)
    151                         (test:eval-expectations clauses ...)))))
     144          (let ([curr-clause '()] [test-result '()])
     145                (test:eval-clause-wrap curr-clause test-result
     146                        (test:eval-expectations curr-clause test-result clauses ...))
    152147                ;; call the destructor to get rid of anything the user didn't want
    153148                (destructor-activate! destname)
    154                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     149                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    155150                        ;; If the user exited via the terminate mechanism, then record this
    156151                        ;; fact with a real terminate node in the tree.
    … …  
    160155                        ;; return the typed list for this kind of test result
    161156                        (test:make-test-case-result
    162                                 (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj)))))
     157                                (all-testcase-expectations-true? stripped-test-result)
     158                                        tname stripped-test-result warnobj)))))
    163159
    164160    ;; no let bindings
    … …  
    166162     (let ((tname testname)
    167163                        (destname (test:make-destructor)))
    168        (let ((test-result ;; invoke the expectations...
    169               (call-with-current-continuation
    170                (lambda (escape)
    171                         (test:eval-expectations clauses ...)))))
     164          (let ([curr-clause '()] [test-result '()])
     165                (test:eval-clause-wrap curr-clause test-result
     166                        (test:eval-expectations curr-clause test-result clauses ...))
    172167                ;; call the destructor to get rid of anything the user didn't want
    173168                (destructor-activate! destname)
    174                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     169                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    175170                        ;; If the user exited via the terminate mechanism, then record this
    176171                        ;; fact with a real terminate node in the tree.
    … …  
    180175                        ;; return the typed list for this kind of test result
    181176                        (test:make-test-case-result
    182                                 (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result)))))))
     177                                (all-testcase-expectations-true? stripped-test-result)
     178                                        tname stripped-test-result)))))))
    183179
    184180;; this is the definition of the macro test-package:
    … …  
    214210        (let ((warnobj warning)
    215211                        (pname packagename) (destname (test:make-destructor)))
    216           (let ((test-result
    217                  (call-with-current-continuation
    218                   (lambda (escape)
    219                     (test:eval-lr clauses ...)))))
     212          (let ([curr-clause '()] [test-result '()])
     213                (test:eval-clause-wrap curr-clause test-result
     214                        (test:eval-lr curr-clause test-result clauses ...))
    220215                ;; call the destructor to get rid of anything the user didn't want
    221216                (destructor-activate! destname)
    222                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     217                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    223218                        ;; If the user exited via the terminate mechanism, then record this
    224219                        ;; fact with a real terminate node in the tree.
    … …  
    227222                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
    228223                        ;; return the typed list for this kind of test result
    229                 (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj))))) value ...))
     224                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
     225                        pname stripped-test-result warnobj))))) value ...))
    230226
    231227    ;; support the optional let bindings
    … …  
    233229     ((lambda (name ...)
    234230        (let ((pname packagename) (destname (test:make-destructor)))
    235           (let ((test-result
    236                  (call-with-current-continuation
    237                   (lambda (escape)
    238                     (test:eval-lr clauses ...)))))
     231          (let ([curr-clause '()] [test-result '()])
     232                (test:eval-clause-wrap curr-clause test-result
     233                        (test:eval-lr curr-clause test-result clauses ...))
    239234                ;; call the destructor to get rid of anything the user didn't want
    240235                (destructor-activate! destname)
    241                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     236                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    242237                        ;; If the user exited via the terminate mechanism, then record this
    243238                        ;; fact with a real terminate node in the tree.
    … …  
    246241                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
    247242                        ;;      return the typed list for this kind of test result
    248                 (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result))))) value ...))
     243                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
     244                        pname stripped-test-result))))) value ...))
    249245
    250246    ;; no let bindings with warning syntax
    … …  
    252248     (let (     (warnobj warning)
    253249                        (pname packagename) (destname (test:make-destructor)))
    254        (let ((test-result
    255               (call-with-current-continuation
    256                (lambda (escape)
    257                         (test:eval-lr clauses ...)))))
     250          (let ([curr-clause '()] [test-result '()])
     251                (test:eval-clause-wrap curr-clause test-result
     252                        (test:eval-lr curr-clause test-result clauses ...))
    258253                ;; call the destructor to get rid of anything the user didn't want
    259254                (destructor-activate! destname)
    260                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     255                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    261256                        ;; If the user exited via the terminate mechanism, then record this
    262257                        ;; fact with a real terminate node in the tree.
    … …  
    265260                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
    266261                        ;; return the typed list for this kind of test result
    267                         (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj)))))
     262                        (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
     263                                pname stripped-test-result warnobj)))))
    268264
    269265    ;; no let bindings
    270266    ((_ packagename destname escape clauses ...)
    271267     (let ((pname packagename) (destname (test:make-destructor)))
    272        (let ((test-result
    273               (call-with-current-continuation
    274                (lambda (escape)
    275                         (test:eval-lr clauses ...)))))
     268          (let ([curr-clause '()] [test-result '()])
     269                (test:eval-clause-wrap curr-clause test-result
     270                        (test:eval-lr curr-clause test-result clauses ...))
    276271                ;; call the destructor to get rid of anything the user didn't want
    277272                (destructor-activate! destname)
    278                 (let ((stripped-test-result (test:strip-ignored-results test-result)))
     273                (let ((stripped-test-result (test:strip-ignored-results (reverse test-result))))
    279274                        ;; If the user exited via the terminate mechanism, then record this
    280275                        ;; fact with a real terminate node in the tree.
    … …  
    283278                                        (list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
    284279                        ;; return the typed list for this kind of test result
    285                 (test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result)))))))
     280                (test:make-test-package-result (all-testpackage-results-true? stripped-test-result)
     281                        pname stripped-test-result)))))))
    286282
    287283;;;;;;;;;;;;;;;;;;
    … …  
    608604
    609605        ;; with optional warning syntax
    610     ((_ msg (warn warning) val arg name test)
     606    ((_ msg (warn warning) val arg test name)
    611607     (let ((warnobj warning) (message msg) (value val) (argument (receive arg)))
    612608       (let ((result (test message value argument)))
    … …  
    615611
    616612        ;; without optional warning syntax
    617     ((_ msg val arg test)
     613    ((_ msg val arg test name)
    618614     (let ((message msg) (value val) (argument (receive arg)))
    619615       (let ((result (test message value argument)))
    … …  
    639635
    640636;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    641 ;; expect-values-eq?: Expect a multi-valued result.
     637;; expect-values-eqv: Expect a multi-valued result.
    642638;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    643639
    … …  
    700696                                (test:gen-exception-property-test EXP KIND-KEY (PROP-KEYS ...))))
    701697
     698                        ; use of #f as an undefined property value is problematic
    702699                ((_ EXP KIND-KEY PROP-KEY)
    703                         (test:has-condition-property
    704                                 (condition-property-accessor 'KIND-KEY 'PROP-KEY) EXP))))
     700                        #;(test:has-condition-property
     701                                (condition-property-accessor 'KIND-KEY 'PROP-KEY) EXP)
     702                        ((condition-property-accessor 'KIND-KEY 'PROP-KEY #f) EXP))))
    705703
    706704(define-syntax test:gen-exception-test
    … …  
    740738                ;; with optional warning syntax
    741739                ((_ msg (warn warning) exn arg)
    742                          (let ([warnobj warning] [message msg] [argument
    743                                 (call/cc (lambda (k)
    744                                         (with-exception-handler
    745                                                 (lambda (the-exception) (k (test:gen-exception-test the-exception exn)))
    746                                                 (lambda () (k arg)))))])
    747                                 (let ((result (test:_expect-exception message 'exn argument)))
    748                                         (test:make-expect-equivalence-result result "exception" message 'exn 'arg argument warnobj))))
     740                         (let ([warnobj warning] [message msg])
     741                                 (letrec ([caught #f] [argument
     742                                        (call/cc (lambda (k)
     743                                                (with-exception-handler
     744                                                        (lambda (the-exception)
     745                                                                (let ([r (test:gen-exception-test the-exception exn)])
     746                                                                        (set! caught #t)
     747                                                                        (k r)))
     748                                                        (lambda () (k arg)))))])
     749                                        (let ((result (test:_expect-exception message 'exn argument caught)))
     750                                                (test:make-expect-equivalence-result result "exception"
     751                                                        message 'exn 'arg argument warnobj)))))
    749752
    750753                ;; without optional warning syntax
    751754                ((_ msg exn arg)
    752                          (let ([message msg] [argument
    753                                 (call/cc (lambda (k)
    754                                         (with-exception-handler
    755                                                 (lambda (the-exception) (k (test:gen-exception-test the-exception exn)))
    756                                                 (lambda () (k arg)))))])
    757                                 (let ((result (test:_expect-exception message 'exn argument)))
    758                                         (test:make-expect-equivalence-result result "exception" message 'exn 'arg argument))))))
     755                         (let ([message msg])
     756                                 (letrec ([message msg] [caught #f] [argument
     757                                        (call/cc (lambda (k)
     758                                                (with-exception-handler
     759                                                        (lambda (the-exception)
     760                                                                (let ([r (test:gen-exception-test the-exception exn)])
     761                                                                        (set! caught #t)
     762                                                                        (k r)))
     763                                                        (lambda () (k arg)))))])
     764                                        (let ((result (test:_expect-exception message 'exn argument caught)))
     765                                                (test:make-expect-equivalence-result result "exception"
     766                                                        message 'exn 'arg argument)))))))
    759767
    760768

  • test-infrastructure/test-infrastructure.setup

    r1 r3  
    1 (run (csc -R syntax-case -s -O2 -d0 test-infrastructure-base.scm))
     1(run (csc -R syntax-case -s -O2 -d1 test-infrastructure-base.scm))
    22
    33(install-extension
    44 'test-infrastructure
    5  '("test-infrastructure.scm" "test-infrastructure-base.so")
     5 '("test-infrastructure.scm" "test-infrastructure-base.so" "test-infrastructure.html")
    66 '((syntax)
    77   (require-at-runtime test-infrastructure-base)))
    88
     9#|
    910(print "testing test-infrastructure ...")
    1011
    1112(run (csc test-test-infrastructure.scm -R syntax-case))
    1213(run (./test-test-infrastructure))
     14|#

  • udp/udp.html

    r1 r3  
    1414
    1515<h3>Author:</h3>
    16 <p> Category 5
     16<p> Category 5, with several enhancements by Daishi Kato
    1717
    1818<h3>Version:</h3>
    1919<ul>
     20<li>1.7
     21Fixed cygwin problem [thanks to Daishi Kato]
    2022<li>1.6
    2123#includes ws2tcpip.h instead of winsock2.h [Thanks to Graham Fawcett]

  • udp/udp.scm

    r1 r3  
    459459          (buf (make-string len))
    460460          (from (make-string _sockaddr_in_size)))
    461       (let ((result
    462              (restart-nonblocking "recvfrom" fd #t
    463                (lambda () (##net#recvfrom fd buf len
    464                                           0 from (make-string 4))))))
    465         (values result (substring buf 0 result)
    466                 (##net#inaddr->string from) (##net#inaddr-port from))))))
     461      (let-location ((fromlen int _sockaddr_in_size))
     462        (let ((result
     463               (restart-nonblocking "recvfrom" fd #t
     464                                    (lambda () (##net#recvfrom fd buf len
     465                                                               0 from #$fromlen)))))
     466          (values result (substring buf 0 result)
     467                  (##net#inaddr->string from) (##net#inaddr-port from)))))) )
    467468
    468469;;; udp-close-socket : udp-socket -> bool
Note: See TracChangeset for help on using the changeset viewer.