Changeset 39679 in project


Ignore:
Timestamp:
03/12/21 22:52:40 (6 weeks ago)
Author:
Kon Lovett
Message:

use test, use test syntax for string output, collect texts, larger limits for compiled, fix test(s) so strict-types

Location:
release/5/srfi-45/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed

  • release/5/srfi-45/trunk/srfi-45.egg

    r39677 r39679  
    66 (author "André van Tonder, for Chicken 4 by Kon Lovett, for Chicken 5 by [[Sergey Goldgaber]]")
    77 (maintainer "Kon Lovett")
     8 (license "BSD")
    89 (dependencies check-errors)
    9  (license "BSD")
     10 (test-dependencies test)
    1011 (components
    1112  (extension srfi-45

  • release/5/srfi-45/trunk/tests/run-ident.scm

    r39678 r39679  
    22
    33(define EGG-NAME "srfi-45")
    4 ;rebinding by tests
    5 (define *csc-remv-options* '(-strict-types))
     4(define *csc-remv-options* '())

  • release/5/srfi-45/trunk/tests/srfi-45-test.scm

    r39677 r39679  
    11;;;; srfi-45 test
    22
    3 ;NOTE -strict-types will not work due to re-binding
    4 
    5 (import
     3(import scheme
    64  (rename scheme (force r5rs:force) (delay r5rs:delay))
    7   (rename chicken.base (promise? r5rs:promise?)))
    8 
    9 (import srfi-45)
     5  (rename chicken.base (promise? r5rs:promise?))
     6  (only (chicken base) print) ;whence `time'?
     7  (only (chicken port) with-output-to-string)
     8  test
     9  srfi-45)
     10
     11(test-begin "SRFI 45")
    1012
    1113;; Perform, or not, a bounded space test.
    … …  
    1618    ((_ (force ?expr))
    1719      (begin
     20        (newline)
    1821        (print "+++ Bounded Space Test: (force " '?expr ") +++")
    1922        (time (force ?expr)) ) ) ) )
    … …  
    2225  (syntax-rules (force)
    2326    ((_ (force ?expr))
    24       (print "+++ Skipping Bounded Space Test: (force " '?expr ") +++") ) ) )
    25 
    26 ;=========================================================================
    27 ; TESTS AND BENCHMARKS:
    28 ;=========================================================================
    29 
    30 ;=========================================================================
    31 ; R5RS & SRFI-45 test 1:
    32 
    33 (print "+++ Should print 'hi 1 +++")
    34 
    35 (time
    36 (define r (r5rs:delay (begin (display 'hi) (display #\space) 1)))
    37 (define s (lazy r))
    38 (define t (lazy s))
    39 (print (force t))
    40 )
    41 
    42 ;=========================================================================
    43 ; Multiple values test 1:
    44 
    45 (print "+++ Should print '(1 2 3) +++")
    46 
    47 (time
    48 (define r (delay (values 1 2 3)))
    49 (define s (lazy r))
    50 (define t (lazy s))
    51 (print (receive (force t)))
    52 )
    53 
    54 ;=========================================================================
    55 ; Memoization test 1:
    56 
    57 (print "+++ Should print 'hello once +++")
    58 
    59 (define s (delay (begin (print 'hello) 1)))
    60 
    61 (time
    62 (force s)
    63 (force s)
    64 )
    65 
    66 ;=========================================================================
    67 ; Memoization test 2:
    68 
    69 (print "+++ Should print 'bonjour once +++")
    70 
    71 (time
    72 (let ((s (delay (begin (print 'bonjour) 2))))
    73   (+ (force s) (force s)))
    74 )
    75 
    76 ;=========================================================================
    77 ; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
    78 
    79 (print "+++ Should print 'hi once +++")
    80 
    81 (define r (delay (begin (print 'hi) 1)))
    82 (define s (lazy r))
    83 (define t (lazy s))
    84 
    85 (time
    86 (force t)
    87 (force r)
    88 )
    89 
    90 ;=========================================================================
    91 ; Memoization test 4: Stream memoization
    92 
    93 (print "+++ Should print 'ho five times +++")
     27      (begin
     28        (newline)
     29        (print "+++ Skipping (Infinite) Bounded Space Test: (force " '?expr ") +++") ) ) ) )
     30
     31(define-syntax test/string
     32  (syntax-rules ()
     33    ((test/string ?msg ?trg ?bdy0 ...)
     34      (test ?msg ?trg (with-output-to-string (lambda () ?bdy0 ...))) ) ) )
     35
     36;=========================================================================
     37; Utilities from TESTS AND BENCHMARKS:
     38;=========================================================================
     39
     40(define (infinite-loop) (lazy (infinite-loop)))
    9441
    9542(define (stream-drop s index)
    … …  
    9744            (stream-drop (cdr (force s)) (- index 1)))))
    9845
    99 (define (ones)
    100   (delay (begin
    101            (print 'ho)
    102            (cons 1 (ones)))))
    103 
    104 (define s (ones))
    105 
    106 (time
    107 (car (force (stream-drop s 4)))
    108 (car (force (stream-drop s 4)))
    109 )
    110 
    111 ;=========================================================================
    112 ; Reentrancy test 1: from R5RS
    113 
    114 (print "+++ Should print 6 twice +++")
    115 
    116 (define count 0)
    117 (define p
    118   (delay (begin
    119            (set! count (+ count 1))
    120            (if (> count x) count
    121                (force p)))))
    122 (define x 5)
    123 
    124 (time
    125 (print (force p))
    126 (set! x 10)
    127 (print (force p))
    128 )
    129 
    130 ;=========================================================================
    131 ; Reentrancy test 2: from SRFI 40
    132 
    133 (print "+++ Should print 'second once +++")
    134 
    135 (define f
    136   (let ((first? #t))
    137     (delay (if (not first?) 'second
    138                (begin
    139                  (set! first? #f)
    140                  (force f))))))
    141 
    142 (time
    143 (print (force f))
    144 )
    145 
    146 ;=========================================================================
    147 ; Reentrancy test 3: due to John Shutt
    148 
    149 (print "+++ Should print 5 0 10 +++")
    150 
    151 (define q
    152   (let ((count 5))
    153     (define (get-count) count)
    154     (define p (delay (if (<= count 0) count
    155                          (begin
    156                            (set! count (- count 1))
    157                            (force p)
    158                            (set! count (+ count 2))
    159                            count))))
    160     (list get-count p)))
    161 
    162 (define get-count (car q))
    163 (define p (cadr q))
    164 
    165 (time
    166 (print (get-count))
    167 (print (force p))
    168 (print (get-count))
    169 )
    170 
    171 ;=========================================================================
    172 ; Test leaks:  All the leak tests should run in bounded space.
    173 
    174 ;=========================================================================
    175 ; Leak test 1: Infinite loop in bounded space.
    176 
    177 (define (loop) (lazy (loop)))
    178 
    179 (-bounded-space (force (loop)))
    180 
    181 ;=========================================================================
    182 ; Leak test 2: Pending memos should not accumulate
    183 ;              in shared structures.
    184 
    185 (define s (loop))
    186 
    187 (-bounded-space (force s))
    188 
    189 ;=========================================================================
    190 ; Leak test 3: Safely traversing infinite stream.
    191 
    19246(define (from n)
    19347  (delay (cons n (from (+ n 1)))))
    … …  
    19650  (lazy (traverse (cdr (force s)))))
    19751
    198 (-bounded-space (force (traverse (from 0))))
    199 
    200 ;=========================================================================
    201 ; Leak test 4: Safely traversing infinite stream
    202 ;              while pointer to head of result exists.
    203 
    204 (define s (traverse (from 0)))
    205 
    206 (-bounded-space (force s))
    207 
    208 ;=========================================================================
    20952; Convenient list deconstructor used below.
    21053
    … …  
    22467              'test:match-error))))))
    22568
    226 ;========================================================================
    227 ; Leak test 5: Naive stream-filter should run in bounded space.
    228 ;              Simplest case.
    229 
    23069(define (stream-filter p? s)
    23170  (lazy (test:match (force s)
    … …  
    23675               (stream-filter p? t))))))
    23776
    238 (+bounded-space (force (stream-filter (lambda (n) (= n 100000 #;10000000000)) (from 0))))
    239 
    240 ;========================================================================
    241 ; Leak test 6: Another long traversal should run in bounded space.
    242 
    24377; The stream-ref procedure below does not strictly need to be lazy.
    24478; It is defined lazy for the purpose of testing safe compostion of
    … …  
    25488               (stream-ref t (- index 1)))))))
    25589
    256 ; Check that evenness is correctly implemented - should terminate:
    257 
    258 (print "+++ Should print 0 +++")
    259 
    260 (print (force (stream-ref (stream-filter zero? (from 0)) 0)))
    261 
    262 (define s (stream-ref (from 0) 100000 #;10000000000))
    263 
    264 (+bounded-space (force s))
    265 
    266 ;======================================================================
    267 ; Leak test 7: Infamous example from SRFI 40.
    268 
    26990(define (times3 n)
    27091  (stream-ref (stream-filter (lambda (x) (zero? (modulo x n))) (from 0)) 3))
    27192
    272 (print "+++ Should print 21 +++")
    273 
    274 (print (force (times3 7)))
    275 
    276 (+bounded-space (force (times3 100000 #;10000000000)))
     93;=========================================================================
     94; TESTS AND BENCHMARKS:
     95;=========================================================================
     96
     97(test-group "Output Tests"
     98
     99  (let ()
     100    (define r (r5rs:delay (begin (display 'hi) (display #\space) 1)))
     101    (define s (lazy r))
     102    (define t (lazy s))
     103
     104    (test/string "R5RS & SRFI-45 test 1" "hi 1\n"
     105      (print (force t)) ) )
     106
     107  (let ()
     108    (define r (delay (values 1 2 3)))
     109    (define s (lazy r))
     110    (define t (lazy s))
     111
     112    (test/string "Multiple values test 1" "(1 2 3)\n"
     113      (print (receive (force t))) ) )
     114
     115  (let ()
     116    (define s (delay (begin (print 'hello) 1)))
     117
     118    (test/string "Memoization test 1" "hello\n"
     119      (force s)
     120      (force s) ) )
     121
     122  (let ((s (delay (begin (print 'bonjour) 2))))
     123    (test/string "Memoization test 2" "bonjour\n"
     124      (+ (force s) (force s))) )
     125
     126  ; : (pointed out by Alejandro Forero Cuervo)
     127  (let ()
     128    (define r (delay (begin (print 'hi) 1)))
     129    (define s (lazy r))
     130    (define t (lazy s))
     131
     132    (test/string "Memoization test 3" "hi\n"
     133      (force t)
     134      (force r) ) )
     135
     136  ; : Stream memoization
     137  (let ()
     138    (define (ones)
     139      (delay (begin
     140               (print 'ho)
     141               (cons 1 (ones)))))
     142    (define s (ones))
     143
     144    (test/string "Memoization test 4" "ho\nho\nho\nho\nho\n"
     145      (car (force (stream-drop s 4)))
     146      (car (force (stream-drop s 4))) ) )
     147
     148  ; : from R5RS
     149  (let ()
     150    (define count 0)
     151    (define p
     152      (delay (begin
     153               (set! count (+ count 1))
     154               (if (> count x) count
     155                   (force p)))))
     156    (define x 5)
     157
     158    (test/string "Reentrancy test 1" "6\n6\n"
     159      (print (force p))
     160      (set! x 10)
     161      (print (force p)) ) )
     162
     163  ; : from SRFI 40
     164  (let ()
     165    (define f
     166      (let ((first? (the boolean #t)))
     167        (delay (if (not first?) 'second
     168                   (begin
     169                     (set! first? #f)
     170                     (force f))))))
     171
     172    (test/string "Reentrancy test 2" "second\n"
     173      (print (force f)) ) )
     174
     175  ; : due to John Shutt
     176  (let ()
     177    (define q
     178      (let ((count 5))
     179        (define (get-count) count)
     180        (define p (delay (if (<= count 0) count
     181                             (begin
     182                               (set! count (- count 1))
     183                               (force p)
     184                               (set! count (+ count 2))
     185                               count))))
     186        (list get-count p)))
     187    (define get-count (car q))
     188    (define p (cadr q))
     189
     190    (test/string "Reentrancy test 3" "5\n0\n10\n"
     191      (print (get-count))
     192      (print (force p))
     193      (print (get-count)) ) )
     194
     195  (test/string "Leak test 6" "0\n"
     196    (print (force (stream-ref (stream-filter zero? (from 0)) 0))) )
     197
     198  (test/string "Leak test 7" "21\n"
     199    (print (force (times3 7))) ) )
     200
     201;=========================================================================
     202; Test leaks:  All the leak tests should run in bounded space.
     203;=========================================================================
     204
     205;======================================================================
     206; Leak test 1: Infinite loop in bounded space.
     207(-bounded-space (force (infinite-loop)))
     208
     209;======================================================================
     210; Leak test 2: Pending memos should not accumulate
     211;              in shared structures.
     212(let ()
     213  (define s (infinite-loop))
     214  (-bounded-space (force s)) )
     215
     216;======================================================================
     217; Leak test 3: Safely traversing infinite stream.
     218
     219(-bounded-space (force (traverse (from 0))))
     220
     221;======================================================================
     222; Leak test 4: Safely traversing infinite stream
     223;              while pointer to head of result exists.
     224(let ()
     225  (define s (traverse (from 0)))
     226  (-bounded-space (force s)) )
     227
     228;========================================================================
     229; Leak test 5: Naive stream-filter should run in bounded space.
     230;              Simplest case.
     231
     232(cond-expand
     233  (compiling
     234    (+bounded-space (force (stream-filter (lambda (n) (= n 10000000 #;10000000000)) (from 0)))) )
     235  (else
     236    (+bounded-space (force (stream-filter (lambda (n) (= n 100000)) (from 0)))) ) )
     237
     238;========================================================================
     239; Leak test 6: Another long traversal should run in bounded space.
     240
     241; Check that evenness is correctly implemented - should terminate:
     242
     243(let ()
     244  (cond-expand
     245    (compiling
     246      (define s (stream-ref (from 0) 10000000 #;10000000000)) )
     247    (else
     248      (define s (stream-ref (from 0) 100000)) ) )
     249  (+bounded-space (force s)) )
     250
     251;======================================================================
     252; Leak test 7: Infamous example from SRFI 40.
     253
     254(cond-expand
     255  (compiling
     256    (+bounded-space (force (times3 10000000 #;10000000000))) )
     257  (else
     258    (+bounded-space (force (times3 100000))) ) )
     259
     260;======================================================================
     261
     262(test-end "SRFI 45")
     263
     264(test-exit)
Note: See TracChangeset for help on using the changeset viewer.