1 ! Copyright (C) 2003, 2011 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes combinators combinators.private
4 kernel kernel.private make namespaces sequences vectors ;
7 : with-datastack ( stack quot -- new-stack )
9 [ [ get-datastack ] dip swap [ { } like set-datastack ] dip ] dip
10 swap [ call get-datastack ] dip
11 swap [ set-datastack ] dip
12 ] ( stack quot -- new-stack ) call-effect-unsafe ;
14 SYMBOL: original-error
16 SYMBOL: error-continuation
20 SINGLETON: no-op-restart
24 : (get-catchstack) ( -- catchstack )
25 CONTEXT-OBJ-CATCHSTACK context-object { vector } declare ; inline
27 ! We have to defeat some optimizations to make continuations work
28 : dummy-1 ( -- obj ) f ;
29 : dummy-2 ( obj -- obj ) ;
31 : get-catchstack ( -- catchstack ) (get-catchstack) clone ; inline
33 : (set-catchstack) ( catchstack -- )
34 CONTEXT-OBJ-CATCHSTACK set-context-object ; inline
36 : set-catchstack ( catchstack -- )
37 >vector (set-catchstack) ; inline
39 : init-catchstack ( -- )
40 V{ } clone (set-catchstack) ;
44 TUPLE: continuation data call retain name catch ;
46 C: <continuation> continuation
48 : current-continuation ( -- continuation )
49 get-datastack get-callstack get-retainstack get-namestack get-catchstack
54 : >continuation< ( continuation -- data call retain name catch )
55 continuation check-instance {
56 [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ]
61 : ifcc ( capture restore -- )
62 [ dummy-1 current-continuation or* ] 2dip [ dummy-2 ] prepose if ; inline
64 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
66 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
70 : (continue) ( continuation -- * )
78 ] ( continuation -- * ) call-effect-unsafe ;
82 : continue-with ( obj continuation -- * )
84 swap OBJ-CALLCC-1 set-special-object
91 OBJ-CALLCC-1 special-object
92 f OBJ-CALLCC-1 set-special-object
96 ] ( obj continuation -- * ) call-effect-unsafe ;
98 : continue ( continuation -- * )
99 f swap continue-with ;
101 SYMBOL: return-continuation
103 : with-return ( quot -- )
104 [ return-continuation ] dip [ with-variable ] 2curry callcc0 ; inline
107 return-continuation get continue ;
109 GENERIC: compute-restarts ( error -- seq )
113 : save-error ( error -- )
115 [ compute-restarts restarts set-global ] bi ;
119 GENERIC: error-in-thread ( error thread -- * )
121 SYMBOL: thread-error-hook ! ( error thread -- * )
123 M: object error-in-thread
124 thread-error-hook get-global call( error thread -- * ) ;
126 : in-callback? ( -- ? ) CONTEXT-OBJ-IN-CALLBACK-P context-object ;
128 SYMBOL: callback-error-hook ! ( error -- * )
130 : rethrow ( error -- * )
134 [ callback-error-hook get-global call( error -- * ) ]
135 [ OBJ-CURRENT-THREAD special-object error-in-thread ]
137 ] [ pop continue-with ] if-empty ;
139 thread-error-hook [ [ die drop rethrow ] ] initialize
141 callback-error-hook [ [ die rethrow ] ] initialize
143 : recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
146 [ (get-catchstack) push ] dip
148 (get-catchstack) pop*
152 : ignore-errors ( ... quot: ( ... -- ... ) -- ... )
153 [ drop ] recover ; inline
155 : ignore-error ( ... quot: ( ... -- ... ) check: ( error -- ? ) -- ... )
156 '[ dup @ [ drop ] [ rethrow ] if ] recover ; inline
158 : ignore-error/f ( ... quot: ( ... -- ... x ) check: ( error -- ? ) -- ... x/f )
159 '[ dup @ [ drop f ] [ rethrow ] if ] recover ; inline
161 : cleanup ( try cleanup-always cleanup-error -- )
162 [ '[ [ @ @ ] dip rethrow ] recover ] [ drop ] 2bi call ; inline
164 : finally ( try cleanup-always -- )
167 ERROR: attempt-all-error ;
169 : attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
174 '[ [ @ , f ] [ , drop t ] recover ] all?
175 ] { } make last swap [ rethrow ] when
178 TUPLE: condition error restarts continuation ;
180 C: <condition> condition
182 : throw-restarts ( error restarts -- restart )
183 [ <condition> throw ] callcc1 2nip ;
185 : rethrow-restarts ( error restarts -- restart )
186 [ <condition> rethrow ] callcc1 2nip ;
188 : throw-continue ( error -- )
189 { { "Continue" t } } throw-restarts drop ;
191 TUPLE: restart name obj continuation ;
195 : continue-restart ( restart -- * )
196 [ obj>> ] [ continuation>> ] bi continue-with ;
198 M: object compute-restarts drop { } ;
200 M: condition compute-restarts
201 [ error>> compute-restarts ]
204 [ continuation>> [ <restart> ] curry ] bi
210 : init-error-handler ( -- )
213 OBJ-CURRENT-THREAD special-object error-thread set-global
214 current-continuation error-continuation set-global
215 [ original-error set-global ] [ rethrow ] bi
216 ] ERROR-HANDLER-QUOT set-special-object ;