module/slib/dwindtst.scm

   1 ;;;; "dwindtst.scm", routines for characterizing dynamic-wind.
   2 ;Copyright (C) 1992 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'dynamic-wind)
  21
  22 (define (dwtest n)
  23   (define cont #f)
  24   (display "testing escape from thunk") (display n) (newline)
  25   (display "visiting:") (newline)
  26   (call-with-current-continuation
  27    (lambda (x) (set! cont x)))
  28   (if n
  29       (dynamic-wind
  30        (lambda ()
  31          (display "thunk1") (newline)
  32          (if (eqv? n 1) (let ((ntmp n))
  33                           (set! n #f)
  34                           (cont ntmp))))
  35        (lambda ()
  36          (display "thunk2") (newline)
  37          (if (eqv? n 2) (let ((ntmp n))
  38                           (set! n #f)
  39                           (cont ntmp))))
  40        (lambda ()
  41          (display "thunk3") (newline)
  42          (if (eqv? n 3) (let ((ntmp n))
  43                           (set! n #f)
  44                           (cont ntmp)))))))
  45 (define (dwctest n)
  46   (define cont #f)
  47   (define ccont #f)
  48   (display "creating continuation thunk") (newline)
  49   (display "visiting:") (newline)
  50   (call-with-current-continuation
  51    (lambda (x) (set! cont x)))
  52   (if n (set! n (- n)))
  53   (if n
  54       (dynamic-wind
  55        (lambda ()
  56          (display "thunk1") (newline)
  57          (if (eqv? n 1) (let ((ntmp n))
  58                           (set! n #f)
  59                           (cont ntmp))))
  60        (lambda ()
  61          (call-with-current-continuation
  62           (lambda (x) (set! ccont x)))
  63          (display "thunk2") (newline)
  64          (if (eqv? n 2) (let ((ntmp n))
  65                           (set! n #f)
  66                           (cont ntmp))))
  67        (lambda ()
  68          (display "thunk3") (newline)
  69          (if (eqv? n 3) (let ((ntmp n))
  70                           (set! n #f)
  71                           (cont ntmp))))))
  72   (cond
  73    (n
  74     (set! n (- n))
  75     (display "testing escape from continuation thunk") (display n) (newline)
  76     (display "visiting:") (newline)
  77     (ccont #f))))
  78
  79 (dwtest 1) (dwtest 2) (dwtest 3)
  80 (dwctest 1) (dwctest 2) (dwctest 3)