mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
80 lines
2.2 KiB
Scheme
80 lines
2.2 KiB
Scheme
;;;; "dwindtst.scm", routines for characterizing dynamic-wind.
|
|
;Copyright (C) 1992 Aubrey Jaffer
|
|
;
|
|
;Permission to copy this software, to redistribute it, and to use it
|
|
;for any purpose is granted, subject to the following restrictions and
|
|
;understandings.
|
|
;
|
|
;1. Any copy made of this software must include this copyright notice
|
|
;in full.
|
|
;
|
|
;2. I have made no warrantee or representation that the operation of
|
|
;this software will be error-free, and I am under no obligation to
|
|
;provide any services, by way of maintenance, update, or otherwise.
|
|
;
|
|
;3. In conjunction with products arising from the use of this
|
|
;material, there shall be no use of my name in any advertising,
|
|
;promotional, or sales literature without prior written consent in
|
|
;each case.
|
|
|
|
(require 'dynamic-wind)
|
|
|
|
(define (dwtest n)
|
|
(define cont #f)
|
|
(display "testing escape from thunk") (display n) (newline)
|
|
(display "visiting:") (newline)
|
|
(call-with-current-continuation
|
|
(lambda (x) (set! cont x)))
|
|
(if n
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(display "thunk1") (newline)
|
|
(if (eqv? n 1) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp))))
|
|
(lambda ()
|
|
(display "thunk2") (newline)
|
|
(if (eqv? n 2) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp))))
|
|
(lambda ()
|
|
(display "thunk3") (newline)
|
|
(if (eqv? n 3) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp)))))))
|
|
(define (dwctest n)
|
|
(define cont #f)
|
|
(define ccont #f)
|
|
(display "creating continuation thunk") (newline)
|
|
(display "visiting:") (newline)
|
|
(call-with-current-continuation
|
|
(lambda (x) (set! cont x)))
|
|
(if n (set! n (- n)))
|
|
(if n
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(display "thunk1") (newline)
|
|
(if (eqv? n 1) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp))))
|
|
(lambda ()
|
|
(call-with-current-continuation
|
|
(lambda (x) (set! ccont x)))
|
|
(display "thunk2") (newline)
|
|
(if (eqv? n 2) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp))))
|
|
(lambda ()
|
|
(display "thunk3") (newline)
|
|
(if (eqv? n 3) (let ((ntmp n))
|
|
(set! n #f)
|
|
(cont ntmp))))))
|
|
(cond
|
|
(n
|
|
(set! n (- n))
|
|
(display "testing escape from continuation thunk") (display n) (newline)
|
|
(display "visiting:") (newline)
|
|
(ccont #f))))
|
|
|
|
(dwtest 1) (dwtest 2) (dwtest 3)
|
|
(dwctest 1) (dwctest 2) (dwctest 3)
|