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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
;; -*-theme-d-*-
;; Copyright (C) 2020, 2021 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.
;; This module is imported by the core interface so we can't import it here.
(define-interface (standard-library platform-specific-impl)
(import (standard-library core-forms))
(declare raise (:simple-proc (<object>) <none> (pure never-returns)))
(declare make-prompt-tag (:simple-proc () <object> pure))
(declare abort-to-prompt2
(:simple-proc (<object> (:procedure (<object>) <none> pure) <object>)
<none> (never-returns pure)))
(declare call-with-prompt
(:param-proc (%result %handler)
(<object>
(:simple-proc () %result pure)
(:simple-proc
(<object>
(:simple-proc (<object>) %handler pure)
<object>)
%handler
pure))
(:union %result %handler)
pure))
(declare abort-to-prompt2-nonpure
(:simple-proc (<object>
(:procedure (<object>) <none> nonpure)
<object>)
<none> (never-returns nonpure)))
(declare call-with-prompt-nonpure
(:param-proc (%result %handler)
(<object>
(:simple-proc () %result nonpure)
(:simple-proc
(<object>
(:simple-proc (<object>) %handler nonpure)
<object>)
%handler
nonpure))
(:union %result %handler)
nonpure))
(declare call-with-prompt-no-result
(:param-proc (%result %handler)
(<object>
(:simple-proc () %result nonpure)
(:simple-proc
(<object>
(:simple-proc (<object>) %handler nonpure)
<object>)
%handler
nonpure))
<none>
nonpure))
(define-syntax guard-general
($lambda (stx)
(syntax-case stx ()
((guard-general exn handler body body* ...)
($identifier? #'exn)
#`(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda-automatic (() pure)
(with-exception-handler
(lambda (((exn <object>)) <none> (never-returns pure))
(abort-to-prompt2
tag
(lambda-automatic (((res <object>)) pure)
handler)
#t))
(lambda-automatic (() pure) body body* ...)))
(lambda-automatic
(((_ <object>)
(h (:procedure (<object>)
(static-type-of
(let ((exn (cast <object> null)))
handler))
pure))
(v <object>))
pure)
(h v))))))))
(define-syntax guard-general-nonpure
($lambda (stx)
(syntax-case stx ()
((guard-general-nonpure exn handler body body* ...)
($identifier? #'exn)
#`(let ((tag (make-prompt-tag)))
(call-with-prompt-nonpure
tag
(lambda-automatic (() nonpure)
(with-exception-handler-nonpure
(lambda (((exn <object>)) <none> (never-returns nonpure))
(abort-to-prompt2-nonpure
tag
(lambda-automatic (((res <object>)) nonpure)
handler)
#t))
(lambda-automatic (() nonpure) body body* ...)))
(lambda-automatic
(((_ <object>)
(h (:procedure (<object>)
(static-type-of
(let ((exn (cast <object> null)))
handler))
nonpure))
(v <object>))
nonpure)
(h v))))))))
(define-syntax guard-general-without-result
($lambda (stx)
(syntax-case stx ()
((guard-general-without-result exn handler body body* ...)
($identifier? #'exn)
#`(let ((tag (make-prompt-tag)))
(call-with-prompt-no-result
tag
(lambda-automatic (() nonpure)
(with-exception-handler-nonpure
(lambda (((exn <object>)) <none> (never-returns nonpure))
(abort-to-prompt2-nonpure
tag
(lambda-automatic (((res <object>)) nonpure)
handler)
#t))
(lambda-automatic (() nonpure) body body* ...)))
(lambda-automatic
(((_ <object>)
(h (:procedure (<object>)
(static-type-of
(let ((exn (cast <object> null)))
handler))
nonpure))
(v <object>))
nonpure)
(h v)))))))))
|
