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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Continuations
(define (make-ref index)
(lambda (c)
(continuation-ref c index)))
(define continuation-cont (make-ref continuation-cont-index))
(define real-continuation-code (make-ref continuation-code-index))
(define real-continuation-pc (make-ref continuation-pc-index))
(define vm-exception-cont-pc (make-ref exception-cont-pc-index))
(define vm-exception-cont-code (make-ref exception-cont-code-index))
; This one is exported
(define vm-exception-continuation-exception
(make-ref exception-cont-exception-index))
; Exception continuations contain the state of the VM when an exception occured.
(define (vm-exception-continuation? thing)
(and (continuation? thing)
(= 13 (real-continuation-pc thing))
(let ((code (real-continuation-code thing)))
(and (= 1 ; one return value
(code-vector-ref code 14))
(= (enum op return-from-exception)
(code-vector-ref code 15))))))
(define (call-with-values-continuation? thing)
(and (continuation? thing)
(= 13 (real-continuation-pc thing))
(= call-with-values-protocol
(code-vector-ref (real-continuation-code thing)
14))))
(define (continuation-pc c)
(if (vm-exception-continuation? c)
(vm-exception-cont-pc c)
(real-continuation-pc c)))
(define (continuation-code c)
(if (vm-exception-continuation? c)
(vm-exception-cont-code c)
(real-continuation-code c)))
; This finds the template if it is in the continuation. Not all continuations
; have templates.
(define (continuation-template c)
(cond
((and (call-with-values-continuation? c)
(closure? (continuation-arg c 0)))
(closure-template (continuation-arg c 0)))
((let loop ((i 0))
(if (= i (continuation-length c))
#f
(let ((value (continuation-ref c i)))
(if (and (template? value)
(eq? (template-code value)
(continuation-code c)))
value
(loop (+ i 1)))))))
;; look among the primops for the template this continuation
;; belongs to
(else
(let ((code (continuation-code c)))
(let loop ((i (vector-length all-operators)))
(if (zero? i)
#f
(let* ((primitive-proc (vector-ref all-operators (- i 1)))
(primitive-template (closure-template primitive-proc)))
(if (eq? code (template-code primitive-template))
primitive-template
(loop (- i 1))))))))))
; Accessing the saved operand stack.
(define (continuation-arg c i)
(continuation-ref c (+ continuation-cells
(if (vm-exception-continuation? c)
exception-continuation-cells
0)
i)))
(define (continuation-arg-count c)
(- (continuation-length c)
(+ continuation-cells
(if (vm-exception-continuation? c)
exception-continuation-cells
0))))
(define-simple-type <continuation> (<value>) continuation?)
(define-method &disclose ((obj <continuation>))
(list (if (vm-exception-continuation? obj)
'vm-exception-continuation
'continuation)
`(pc ,(continuation-pc obj))
(let ((template (continuation-template obj)))
(if template
(template-info template)
'?))))
(define (continuation-preview c)
(if (continuation? c)
(cons (cons (let ((template (continuation-template c)))
(if template
(template-info template)
'?))
(continuation-pc c))
(continuation-preview (continuation-cont c)))
'()))
|
