44 lines
1.6 KiB
Scheme
44 lines
1.6 KiB
Scheme
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
||
|
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
; Continuations
|
||
|
|
|
||
|
|
(define (continuation-cont c) (continuation-ref c 0))
|
||
|
|
(define (continuation-pc c) (continuation-ref c 1))
|
||
|
|
(define (continuation-template c) (continuation-ref c 2))
|
||
|
|
(define (continuation-env c) (continuation-ref c 3))
|
||
|
|
(define continuation-overhead 4)
|
||
|
|
(define (continuation-arg c i)
|
||
|
|
(continuation-ref c (+ continuation-overhead i)))
|
||
|
|
(define (continuation-arg-count c)
|
||
|
|
(- (continuation-length c) continuation-overhead))
|
||
|
|
|
||
|
|
|
||
|
|
; If (continuation-cont A) = B, then ignore B if
|
||
|
|
; 1. (continuation-template B) = (continuation-template A)
|
||
|
|
; 2. (continuation-pc B) > (continuation-pc A)
|
||
|
|
; 3. (continuation-env B) = (continuation-env A)
|
||
|
|
; or some parent of (continuation-env A)
|
||
|
|
; I don't think this is foolproof, but I have so far been unable to
|
||
|
|
; contrive a situation in which it fails. I think a double recursion of a
|
||
|
|
; procedure of no arguments is required, at the very least.
|
||
|
|
|
||
|
|
(define (continuation-parent a)
|
||
|
|
(let ((b (continuation-cont a)))
|
||
|
|
(if (and (continuation? b)
|
||
|
|
(eq? (continuation-template b) (continuation-template a))
|
||
|
|
(> (continuation-pc b) (continuation-pc a))
|
||
|
|
(let loop ((env (continuation-env a)))
|
||
|
|
(or (eq? env (continuation-env b))
|
||
|
|
(and (vector? env)
|
||
|
|
(loop (vector-ref env 0))))))
|
||
|
|
(continuation-parent b)
|
||
|
|
b)))
|
||
|
|
|
||
|
|
(define-simple-type :continuation (:value) continuation?)
|
||
|
|
|
||
|
|
(define-method &disclose ((obj :continuation))
|
||
|
|
(list 'continuation
|
||
|
|
`(pc ,(continuation-pc obj))
|
||
|
|
(template-info (continuation-template obj))))
|