Changeset 3 in project
- Timestamp:
- 11/01/05 14:38:28 (15 years ago)
- Files:
-
- 7 added
- 8 edited
-
bb/bb.html (modified) (1 diff)
-
futures (added)
-
futures/doc.scm (added)
-
futures/futures-base.scm (added)
-
futures/futures.html (added)
-
futures/futures.meta (added)
-
futures/futures.scm (added)
-
futures/futures.setup (added)
-
test-infrastructure/test-infrastructure-base.scm (modified) (17 diffs)
-
test-infrastructure/test-infrastructure.html (modified) (1 diff)
-
test-infrastructure/test-infrastructure.meta (modified) (1 diff)
-
test-infrastructure/test-infrastructure.scm (modified) (22 diffs)
-
test-infrastructure/test-infrastructure.setup (modified) (1 diff)
-
udp/udp.html (modified) (1 diff)
-
udp/udp.scm (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
bb/bb.html
r1 r3 339 339 340 340 </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. 342 342 When set, the value should be a pair containing start and end position of the selection in the buffer. 343 343 -
test-infrastructure/test-infrastructure-base.scm
r1 r3 8 8 ;;;; or anyone else liable for any use of this source code. Please try to keep 9 9 ;;;; this source code as close to R5RS(or later) scheme as possible. Thank you. 10 11 ;;;; Modifications Kon Lovett, Oct 15 2005 10 12 11 13 (include "test-infrastructure.scm") … … 317 319 (list-ref res 5) 318 320 '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 319 364 320 365 ;;;;;;;;;;;;;;;;;; … … 1181 1226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1182 1227 ;; 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))) 1186 1233 1187 1234 … … 1189 1236 ;; expect-exception: Expect an exception. 1190 1237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1191 (define (test:_expect-exception msg exn val )1192 val)1238 (define (test:_expect-exception msg exn val caught) 1239 (and caught val)) 1193 1240 1194 1241 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 1666 1713 (apply printnl args))) 1667 1714 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 1668 1721 ;; print something at an indention level 1669 1722 (define printime … … 1732 1785 (expect-result-warning-ref resnode)))) 1733 1786 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)) 1738 1791 (printinl indent "Result: " (expect-result-result-ref resnode)) 1739 1792 (printinl indent … … 1754 1807 (expect-tolerance-result-warning-ref resnode)))) 1755 1808 1756 (printinl (+ indent 2)"Expected Value: ")1757 (printinl (+ indent 2)1809 (printinl/+2 indent "Expected Value: ") 1810 (printinl/+2 indent 1758 1811 (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 1761 1814 (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 1764 1817 (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 1767 1820 (expect-tolerance-result-rhs-evaled-ref resnode)) 1768 1821 (printinl indent "Result: " … … 1787 1840 (expect-equivalence-result-warning-ref resnode)))) 1788 1841 1789 (printinl (+ indent 2)"Expected Value: ")1790 (printinl (+ indent 2)1842 (printinl/+2 indent "Expected Value: ") 1843 (printinl/+2 indent 1791 1844 (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 1794 1847 (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 1797 1850 (expect-equivalence-result-rhs-evaled-ref resnode)) 1798 1851 (printinl indent "Result: " … … 1807 1860 ((terminate-result? resnode) 1808 1861 (printinl indent "Begin TERMINATION") 1809 (printinl (+ indent 2)1862 (printinl/+2 indent 1810 1863 "Message: " (terminate-result-message-ref resnode)) 1811 (printinl (+ indent 2)1864 (printinl/+2 indent 1812 1865 "Container: " (terminate-result-container-ref resnode)) 1813 (printinl (+ indent 2)1866 (printinl/+2 indent 1814 1867 "Scope: " (terminate-result-scope-ref resnode)) 1815 1868 (printinl indent … … 2496 2549 ;; dump out any warnings... 2497 2550 (cond ((test-package-result-warning? resnode) 2498 (printinl (+ indent 2)"WARNING: '"2551 (printinl/+2 indent "WARNING: '" 2499 2552 (test-package-result-warning-ref resnode) "'"))) 2500 2553 … … 2512 2565 " - Passed") 2513 2566 (cond ((test-case-result-warning? resnode) 2514 (printinl (+ indent 2)"WARNING: '"2567 (printinl/+2 indent "WARNING: '" 2515 2568 (test-case-result-warning-ref resnode) "'")))) 2516 2569 (begin … … 2518 2571 (test-case-result-message-ref resnode) "' - Failed") 2519 2572 (cond ((test-case-result-warning? resnode) 2520 (printinl (+ indent 2)"WARNING: '"2573 (printinl/+2 indent "WARNING: '" 2521 2574 (test-case-result-warning-ref resnode) "'"))) 2522 2575 … … 2529 2582 ((expect-result? resnode) 2530 2583 (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)) 2546 2610 2547 2611 ;; print out an expect-tolerance-result … … 2553 2617 (expect-tolerance-result-specific-ref resnode)) 2554 2618 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"))) 2574 2643 2575 2644 (printinl indent … … 2586 2655 (expect-equivalence-result-specific-ref resnode)) 2587 2656 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"))) 2604 2678 2605 2679 (printinl indent … … 2611 2685 ((terminate-result? resnode) 2612 2686 (printinl indent "Begin TERMINATION") 2613 (printinl (+ indent 2)2687 (printinl/+2 indent 2614 2688 "Message: '" (terminate-result-message-ref resnode) "'") 2615 (printinl (+ indent 2)2689 (printinl/+2 indent 2616 2690 "Container: " (terminate-result-container-ref resnode)) 2617 (printinl (+ indent 2)2691 (printinl/+2 indent 2618 2692 "Scope: " (terminate-result-scope-ref resnode)) 2619 2693 (printinl indent … … 2623 2697 ;; print out any gloss message the user might have inserted somewhere. 2624 2698 ((gloss-result? resnode) 2625 (printinl (+ indent 2)"Gloss: '" (gloss-result-message-ref2699 (printinl/+2 indent "Gloss: '" (gloss-result-message-ref 2626 2700 resnode) "'") 2627 2701 ;; dump out any warnings... 2628 2702 (cond ((gloss-result-warning? resnode) 2629 (printinl (+ indent 2)"WARNING: "2703 (printinl/+2 indent "WARNING: " 2630 2704 (gloss-result-warning-ref resnode))))) 2631 2705 -
test-infrastructure/test-infrastructure.html
r1 r3 13 13 <h3>Author:</h3> 14 14 Peter Keller 15 16 <h3>Version</h3> 17 <ul> 18 <lI>1.1 19 Added several enhancements [by Kon Lovett] 20 <li>1.0 21 </ul> 15 22 16 23 <h3>Usage:</h3> -
test-infrastructure/test-infrastructure.meta
r1 r3 9 9 "test-infrastructure-base.scm" 10 10 "test-infrastructure.scm" 11 "test-infrastructure.html" 11 12 "test-test-infrastructure.scm")) -
test-infrastructure/test-infrastructure.scm
r1 r3 9 9 ;;;; this source code as close to R5RS(or later) scheme as possible. Thank you. 10 10 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 11 30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 31 ;; perform a left to right evaluation of a list of expectations stopping at … … 15 34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 35 (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 ...))))))) 61 52 62 53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 66 57 (define-syntax test:eval-lr 67 58 (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 ...)))))) 74 70 75 71 ;; this is the definition of the macro test-case: … … 105 101 (tname testname) 106 102 (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 ...)) 111 106 ;; call the destructor to get rid of anything the user didn't want 112 107 (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)))) 114 109 ;; If the user exited via the terminate mechanism, then record this 115 110 ;; fact with a real terminate node in the tree. 116 111 (cond ((terminate? stripped-test-result) 117 (set! test-result112 (set! stripped-test-result 118 113 (list (test:make-terminate-result #f tname 'test-case stripped-test-result))))) 119 114 ;; 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 ...)) 121 117 122 118 ;; support the optional let bindings … … 124 120 ((lambda (name ...) 125 121 (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 ...)) 130 125 ;; call the destructor to get rid of anything the user didn't want 131 126 (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)))) 133 128 ;; If the user exited via the terminate mechanism, then record this 134 129 ;; fact with a real terminate node in the tree. … … 138 133 ;; return the typed list for this kind of test result 139 134 (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 ...)) 141 137 142 138 … … 146 142 (tname testname) 147 143 (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 ...)) 152 147 ;; call the destructor to get rid of anything the user didn't want 153 148 (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)))) 155 150 ;; If the user exited via the terminate mechanism, then record this 156 151 ;; fact with a real terminate node in the tree. … … 160 155 ;; return the typed list for this kind of test result 161 156 (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))))) 163 159 164 160 ;; no let bindings … … 166 162 (let ((tname testname) 167 163 (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 ...)) 172 167 ;; call the destructor to get rid of anything the user didn't want 173 168 (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)))) 175 170 ;; If the user exited via the terminate mechanism, then record this 176 171 ;; fact with a real terminate node in the tree. … … 180 175 ;; return the typed list for this kind of test result 181 176 (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))))))) 183 179 184 180 ;; this is the definition of the macro test-package: … … 214 210 (let ((warnobj warning) 215 211 (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 ...)) 220 215 ;; call the destructor to get rid of anything the user didn't want 221 216 (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)))) 223 218 ;; If the user exited via the terminate mechanism, then record this 224 219 ;; fact with a real terminate node in the tree. … … 227 222 (list (test:make-terminate-result #f pname 'test-package stripped-test-result))))) 228 223 ;; 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 ...)) 230 226 231 227 ;; support the optional let bindings … … 233 229 ((lambda (name ...) 234 230 (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 ...)) 239 234 ;; call the destructor to get rid of anything the user didn't want 240 235 (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)))) 242 237 ;; If the user exited via the terminate mechanism, then record this 243 238 ;; fact with a real terminate node in the tree. … … 246 241 (list (test:make-terminate-result #f pname 'test-package stripped-test-result))))) 247 242 ;; 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 ...)) 249 245 250 246 ;; no let bindings with warning syntax … … 252 248 (let ( (warnobj warning) 253 249 (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 ...)) 258 253 ;; call the destructor to get rid of anything the user didn't want 259 254 (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)))) 261 256 ;; If the user exited via the terminate mechanism, then record this 262 257 ;; fact with a real terminate node in the tree. … … 265 260 (list (test:make-terminate-result #f pname 'test-package stripped-test-result))))) 266 261 ;; 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))))) 268 264 269 265 ;; no let bindings 270 266 ((_ packagename destname escape clauses ...) 271 267 (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 ...)) 276 271 ;; call the destructor to get rid of anything the user didn't want 277 272 (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)))) 279 274 ;; If the user exited via the terminate mechanism, then record this 280 275 ;; fact with a real terminate node in the tree. … … 283 278 (list (test:make-terminate-result #f pname 'test-package stripped-test-result))))) 284 279 ;; 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))))))) 286 282 287 283 ;;;;;;;;;;;;;;;;;; … … 608 604 609 605 ;; with optional warning syntax 610 ((_ msg (warn warning) val arg name test)606 ((_ msg (warn warning) val arg test name) 611 607 (let ((warnobj warning) (message msg) (value val) (argument (receive arg))) 612 608 (let ((result (test message value argument))) … … 615 611 616 612 ;; without optional warning syntax 617 ((_ msg val arg test )613 ((_ msg val arg test name) 618 614 (let ((message msg) (value val) (argument (receive arg))) 619 615 (let ((result (test message value argument))) … … 639 635 640 636 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 641 ;; expect-values-eq ?: Expect a multi-valued result.637 ;; expect-values-eqv: Expect a multi-valued result. 642 638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 643 639 … … 700 696 (test:gen-exception-property-test EXP KIND-KEY (PROP-KEYS ...)))) 701 697 698 ; use of #f as an undefined property value is problematic 702 699 ((_ 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)))) 705 703 706 704 (define-syntax test:gen-exception-test … … 740 738 ;; with optional warning syntax 741 739 ((_ 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))))) 749 752 750 753 ;; without optional warning syntax 751 754 ((_ 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))))))) 759 767 760 768 -
test-infrastructure/test-infrastructure.setup
r1 r3 1 (run (csc -R syntax-case -s -O2 -d 0test-infrastructure-base.scm))1 (run (csc -R syntax-case -s -O2 -d1 test-infrastructure-base.scm)) 2 2 3 3 (install-extension 4 4 'test-infrastructure 5 '("test-infrastructure.scm" "test-infrastructure-base.so" )5 '("test-infrastructure.scm" "test-infrastructure-base.so" "test-infrastructure.html") 6 6 '((syntax) 7 7 (require-at-runtime test-infrastructure-base))) 8 8 9 #| 9 10 (print "testing test-infrastructure ...") 10 11 11 12 (run (csc test-test-infrastructure.scm -R syntax-case)) 12 13 (run (./test-test-infrastructure)) 14 |# -
udp/udp.html
r1 r3 14 14 15 15 <h3>Author:</h3> 16 <p> Category 5 16 <p> Category 5, with several enhancements by Daishi Kato 17 17 18 18 <h3>Version:</h3> 19 19 <ul> 20 <li>1.7 21 Fixed cygwin problem [thanks to Daishi Kato] 20 22 <li>1.6 21 23 #includes ws2tcpip.h instead of winsock2.h [Thanks to Graham Fawcett] -
udp/udp.scm
r1 r3 459 459 (buf (make-string len)) 460 460 (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)))))) ) 467 468 468 469 ;;; udp-close-socket : udp-socket -> bool
Note: See TracChangeset
for help on using the changeset viewer.
