File: continuation.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (43 lines) | stat: -rw-r--r-- 1,671 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
; -*- 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))))