1: ;;
    2: ;; Test dynamic-wind, call/cc and related stuff
    3: ;;
    4: 
    5: ;; $Id: dynwind.scm,v 1.21 2006/01/10 10:33:57 shirok Exp $
    6: 
    7: (use gauche.test)
    8: 
    9: (test-start "dynamic-wind and call/cc")
   10: 
   11: (define c #f)
   12: 
   13: ;;-----------------------------------------------------------------------
   14: ;; Test for continuation
   15: 
   16: (define (callcc-test1)
   17:   (let ((r '()))
   18:     (let ((w (let ((v 1))
   19:                (set! v (+ (call-with-current-continuation
   20:                            (lambda (c0) (set! c c0) v))
   21:                           v))
   22:                (set! r (cons v r))
   23:                v)))
   24:       (if (<= w 1024) (c w) r))))
   25: 
   26: (test "call/cc (env)" '(2048 1024 512 256 128 64 32 16 8 4 2)
   27:       callcc-test1)
   28: 
   29: ;; continuation with multiple values
   30: 
   31: (test* "call/cc (values)" '(1 2 3)
   32:        (receive x (call-with-current-continuation
   33:                    (lambda (c) (c 1 2 3)))
   34:          x))
   35: 
   36: (test* "call/cc (values2)" '(1 2 3)
   37:        (receive (x y z) (call-with-current-continuation
   38:                          (lambda (c) (c 1 2 3)))
   39:          (list x y z)))
   40: 
   41: (test* "call/cc (values3)" '(1 2 (3))
   42:        (receive (x y . z)
   43:            (call-with-current-continuation
   44:             (lambda (c) (c 1 2 3)))
   45:          (list x y z)))
   46: 
   47: (test* "call/cc (values4)" *test-error*
   48:        (receive (x y)
   49:            (call-with-current-continuation
   50:             (lambda (c) (c 1 2 3)))
   51:          (list x y)))
   52: 
   53: ;; continuation invoked while inline procedure is prepared.
   54: ;; a test to see call/cc won't mess up the VM stack.
   55: 
   56: (define (callcc-test2)
   57:   (let ((cc #f)
   58:         (r '()))
   59:     (let ((s (list 1 2 3 4 (call/cc (lambda (c) (set! cc c) 5)) 6 7 8)))
   60:       (if (null? r)
   61:           (begin (set! r s) (cc -1))
   62:           (list r s)))))
   63:     
   64: (test "call/cc (inline)" '((1 2 3 4 5 6 7 8) (1 2 3 4 -1 6 7 8))
   65:       callcc-test2)
   66: 
   67: ;; continuation created during do frame preparation.
   68: ;; the TAILBIND instruction failed this test.
   69: 
   70: (test "call/cc (do)" 6
   71:       (lambda ()
   72:         (do ((x 0 (+ x 1))
   73:              (y 0 (call/cc (lambda (c) c))))
   74:             ((> x 5) x)
   75:           #f)))
   76: 
   77: ;;------------------------------------------------------------------------
   78: ;; Test for continuation thrown over C stack boundary
   79: ;;
   80: 
   81: ;; NB: these test doesn't really test the continuation and
   82: ;; C stack boundary anymore, since 'sort' function with compare
   83: ;; function is now implemented in Scheme.
   84: 
   85: (define (callcc-over-cstack)
   86:   (call-with-current-continuation
   87:    (lambda (c)
   88:      (sort '(1 2 3 4 5 6) (lambda (a b) (c 10))))))
   89: 
   90: (test "call/cc (cstack)" 10 callcc-over-cstack)
   91: 
   92: (test "call/cc (cstack2)" '(10 . 11)
   93:       (lambda () (cons (callcc-over-cstack) 11)))
   94: 
   95: (test "call/cc (cstack, values)" '(10 11)
   96:       (lambda ()
   97:         (receive x
   98:             (call-with-current-continuation
   99:              (lambda (c)
  100:                (sort '(1 2 3 4 5 6)
  101:                      (lambda (a b) (c 10 11)))))
  102:           x)))
  103: 
  104: (test "call/cc (cstack, two level)" '(10 . 11)
  105:       (lambda ()
  106:         (cons (call-with-current-continuation
  107:                (lambda (c)
  108:                  (sort '(1 2 3 4 5 6)
  109:                        (lambda (a b)
  110:                          (sort '(1 2 3 4 5 6)
  111:                                (lambda (a b) (c 10)))))))
  112:               11)))
  113: 
  114: (test "call/cc (cstack, two level, two hop)" '(11 . 11)
  115:       (lambda ()
  116:         (cons (call-with-current-continuation
  117:                (lambda (c)
  118:                  (sort '(1 2 3 4 5 6)
  119:                        (lambda (a b)
  120:                          (c (+ (call-with-current-continuation
  121:                                 (lambda (d)
  122:                                   (sort '(1 2 3 4 5 6)
  123:                                         (lambda (a b) (d 10)))))
  124:                                1))))))
  125:               11)))
  126: 
  127: ;; Paranoia
  128: 
  129: (test "call/cc & dynwind (cstack)" '(a b c)
  130:       (lambda ()
  131:         (let ((x '()))
  132:           (call-with-current-continuation
  133:            (lambda (c)
  134:              (dynamic-wind
  135:               (lambda () (set! x (cons 'c x)))
  136:               (lambda ()
  137:                 (sort '(1 2 3 4 5 6)
  138:                       (lambda (a b)
  139:                         (set! x (cons 'b x))
  140:                         (c 0)))
  141:                 (set! x (cons 'z x))
  142:                 )
  143:               (lambda () (set! x (cons 'a x))))))
  144:           x)))
  145: 
  146: ;;------------------------------------------------------------------------
  147: ;; Test for dynamic-wind
  148: 
  149: ;; An example in R5RS
  150: (define (dynwind-test1)
  151:   (let ((path '()))
  152:     (let ((add (lambda (s) (set! path (cons s path)))))
  153:       (dynamic-wind
  154:        (lambda () (add 'connect))
  155:        (lambda ()
  156:          (add (call-with-current-continuation
  157:                (lambda (c0) (set! c c0) 'talk1))))
  158:        (lambda () (add 'disconnect)))
  159:       (if (< (length path) 4)
  160:           (c 'talk2)
  161:           (reverse path)))))
  162: 
  163: (test "dynamic-wind"
  164:       '(connect talk1 disconnect connect talk2 disconnect)
  165:       dynwind-test1)
  166: 
  167: ;; Test for handler stack.
  168: (define (dynwind-test2)
  169:   (let ((path '()))
  170:     (dynamic-wind
  171:      (lambda () (set! path (cons 1 path)))
  172:      (lambda () (set! path (append (dynwind-test1) path)))
  173:      (lambda () (set! path (cons 3 path))))
  174:     path))
  175: 
  176: (test "dynamic-wind"
  177:       '(3 connect talk1 disconnect connect talk2 disconnect 1)
  178:       dynwind-test2)
  179: 
  180: (test "dynamic-wind" '(a b c d e f g b c d e f g h)
  181:       (lambda ()
  182:         (let ((x '())
  183:               (c #f))
  184:           (dynamic-wind
  185:            (lambda () (push! x 'a))
  186:            (lambda ()
  187:              (dynamic-wind
  188:               (lambda () (push! x 'b))
  189:               (lambda ()
  190:                 (dynamic-wind
  191:                  (lambda () (push! x 'c))
  192:                  (lambda () (set! c (call/cc identity)))
  193:                  (lambda () (push! x 'd))))
  194:               (lambda () (push! x 'e)))
  195:              (dynamic-wind
  196:               (lambda () (push! x 'f))
  197:               (lambda () (when c (c #f)))
  198:               (lambda () (push! x 'g))))
  199:            (lambda () (push! x 'h)))
  200:           (reverse x))))
  201: 
  202: ;; Test for multiple values
  203: (test "dynamic-wind (multival)" '(a b c)
  204:       (lambda ()
  205:         (receive x
  206:             (dynamic-wind (lambda () #f)
  207:                           (lambda () (values 'a 'b 'c))
  208:                           (lambda () #f))
  209:           x)))
  210: 
  211: (test "dynamic-wind (multival)" '()
  212:       (lambda ()
  213:         (receive x
  214:             (dynamic-wind (lambda () #f)
  215:                           (lambda () (values))
  216:                           (lambda () #f))
  217:           x)))
  218: 
  219: ;; Test for error handling with dynamic-wind
  220: (test "dynamic-wind - error in before thunk"
  221:       '(a b c d h)
  222:       (lambda ()
  223:         (let ((k '()))
  224:           (with-error-handler (lambda (e) #f)
  225:             (lambda ()
  226:               (push! k 'a)
  227:               (dynamic-wind
  228:                   (lambda () (push! k 'b))
  229:                   (lambda ()
  230:                     (push! k 'c)
  231:                     (dynamic-wind
  232:                         (lambda () (push! k 'd) (error "ho"))
  233:                         (lambda () (push! k 'e))
  234:                         (lambda () (push! k 'f)))
  235:                     (push! k 'g))
  236:                   (lambda () (push! k 'h)))
  237:               (push! k 'i)))
  238:           (reverse k))))
  239:             
  240: (test "dynamic-wind - error in after thunk"
  241:       '(a b c d e f h)
  242:       (lambda ()
  243:         (let ((k '()))
  244:           (with-error-handler (lambda (e) #f)
  245:             (lambda ()
  246:               (push! k 'a)
  247:               (dynamic-wind
  248:                   (lambda () (push! k 'b))
  249:                   (lambda ()
  250:                     (push! k 'c)
  251:                     (dynamic-wind
  252:                         (lambda () (push! k 'd))
  253:                         (lambda () (push! k 'e))
  254:                         (lambda () (push! k 'f) (error "ho")))
  255:                     (push! k 'g))
  256:                   (lambda () (push! k 'h)))
  257:               (push! k 'i)))
  258:           (reverse k))))
  259: 
  260: ;; test for error during dynamic handler reinstallation by call/cc.
  261: ;; (problem found and fixed by Kazuki Tsujimoto)
  262: 
  263: (define (test-thunk body)
  264:   (let ((x '()))
  265:     (with-error-handler
  266:         (lambda (e) (push! x 'x))
  267:       (lambda ()
  268:         (call/cc
  269:          (lambda (c)
  270:            (dynamic-wind
  271:                (lambda () (push! x 'a))
  272:                (lambda ()
  273:                  (dynamic-wind
  274:                      (lambda () (push! x 'b))
  275:                      (lambda () (body c))
  276:                      (lambda () (push! x 'c) (car 3))))
  277:                (lambda () (push! x 'd)))))))
  278:     (reverse x)))
  279: 
  280: (test* "restart & dynamic-wind with error(1)" '(a b c x d)
  281:        (test-thunk (lambda (cont) (cont #t))))
  282: 
  283: (test* "restart & dynamic-wind with error(2)" '(a b c x d)
  284:        (test-thunk (lambda (cont)
  285:                      (with-error-handler
  286:                          (lambda (e) (cont #t))
  287:                        (lambda () (car 3))))))
  288: 
  289: ;;-----------------------------------------------------------------------
  290: ;; Test for stack overflow handling
  291: 
  292: ;; Single call of fact-rec consumes
  293: ;;  5 (continuation) + 1 (n) + 4 (argframe) = 10
  294: ;; words.  With the default stack size 10000, n=1000 is enough to generate
  295: ;; the stack overflow.  There's no way to obtain compiled-in stack size
  296: ;; right now, so you need to adjust the parameters if you change the stack
  297: ;; size.
  298: 
  299: (define (sum-rec n)
  300:   (if (> n 0)
  301:       (+ n (sum-rec (- n 1)))
  302:       0))
  303: 
  304: (test "stack overflow" (/ (* 1000 1001) 2)
  305:       (lambda () (sum-rec 1000)))
  306: 
  307: (test "stack overflow" (/ (* 4000 4001) 2)
  308:       (lambda () (sum-rec 4000)))
  309: 
  310: (define (sum-rec-apply n)
  311:   (if (> n 0)
  312:       (apply + n (apply sum-rec (- n 1) '()) '())
  313:       0))
  314: 
  315: (test "stack overflow (apply)" (/ (* 2000 2001) 2)
  316:       (lambda () (sum-rec-apply 2000)))
  317:       
  318: (test "stack overflow (apply)" (/ (* 3000 3001) 2)
  319:       (lambda () (sum-rec-apply 3000)))
  320: 
  321: ;;-----------------------------------------------------------------------
  322: ;; See if port stuff is cleaned up properly
  323: 
  324: (test "call-with-output-file -> port-closed?"
  325:       #t
  326:       (lambda ()
  327:         (let ((p #f))
  328:           (call-with-output-file
  329:               "tmp1.o"
  330:               (lambda (port)
  331:                 (write '(a b c d e) port)
  332:                 (set! p port)))
  333:           (port-closed? p))))
  334: 
  335: (test "call-with-input-file -> port-closed?"
  336:       '(#t a b c d e)
  337:       (lambda ()
  338:         (let* ((p #f)
  339:                (r (call-with-input-file "tmp1.o"
  340:                     (lambda (port)
  341:                       (set! p port)
  342:                       (read port)))))
  343:           (cons (port-closed? p) r))))
  344: 
  345: (test "with-output-to-file -> port-closed?"
  346:       '(#t #f)
  347:       (lambda ()
  348:         (let ((p #f))
  349:           (with-output-to-file "tmp1.o"
  350:             (lambda ()
  351:               (set! p (current-output-port))
  352:               (write '(a b c d e))))
  353:           (list (port-closed? p)
  354:                 (eq? p (current-output-port))))))
  355: 
  356: (test "with-input-from-file -> port-closed?"
  357:       '(#t #f)
  358:       (lambda ()
  359:         (let* ((p #f)
  360:                (r (with-input-from-file "tmp1.o"
  361:                     (lambda ()
  362:                       (set! p (current-input-port))
  363:                       (read)))))
  364:           (list (port-closed? p)
  365:                 (eq? p (current-input-port))))))
  366: 
  367: ;;-----------------------------------------------------------------------
  368: ;; Al Petrofsky's finding
  369: ;; http://groups.google.com/groups?dq=&hl=ja&selm=87g00y4b6l.fsf%40radish.petrofsky.org
  370: 
  371: (test "Al's call/cc test" 1
  372:       (lambda () (call/cc (lambda (c) (0 (c 1))))))
  373: 
  374: (test-end)