1 ! Copyright (C) 2003, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators combinators.private kernel
4 kernel.private make namespaces sequences vectors ;
7 : with-datastack ( stack quot -- new-stack )
9 [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip
10 swap [ call datastack ] dip
11 swap [ set-datastack ] dip
12 ] ( stack quot -- new-stack ) call-effect-unsafe ;
14 SYMBOL: original-error
16 SYMBOL: error-continuation
22 : catchstack* ( -- catchstack )
23 CONTEXT-OBJ-CATCHSTACK context-object { vector } declare ; inline
25 ! We have to defeat some optimizations to make continuations work
26 : dummy-1 ( -- obj ) f ;
27 : dummy-2 ( obj -- obj ) ;
29 : catchstack ( -- catchstack ) catchstack* clone ; inline
31 : set-catchstack ( catchstack -- )
32 >vector CONTEXT-OBJ-CATCHSTACK set-context-object ; inline
34 : init-catchstack ( -- ) f set-catchstack ;
38 TUPLE: continuation data call retain name catch ;
40 C: <continuation> continuation
42 : continuation ( -- continuation )
43 datastack callstack retainstack namestack catchstack
48 : >continuation< ( continuation -- data call retain name catch )
49 { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ;
53 : ifcc ( capture restore -- )
54 [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
56 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
58 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
62 : (continue) ( continuation -- * )
70 ] ( continuation -- * ) call-effect-unsafe ;
74 : continue-with ( obj continuation -- * )
76 swap OBJ-CALLCC-1 set-special-object
83 OBJ-CALLCC-1 special-object
84 f OBJ-CALLCC-1 set-special-object
88 ] ( obj continuation -- * ) call-effect-unsafe ;
90 : continue ( continuation -- * )
91 f swap continue-with ;
93 SYMBOL: return-continuation
95 : with-return ( quot -- )
96 [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
99 return-continuation get continue ;
101 GENERIC: compute-restarts ( error -- seq )
105 : save-error ( error -- )
107 [ compute-restarts restarts set-global ] bi ;
111 GENERIC: error-in-thread ( error thread -- * )
113 SYMBOL: thread-error-hook ! ( error thread -- )
115 thread-error-hook [ [ die ] ] initialize
117 M: object error-in-thread ( error thread -- * )
118 thread-error-hook get-global call( error thread -- * ) ;
120 : in-callback? ( -- ? ) CONTEXT-OBJ-IN-CALLBACK-P context-object ;
122 SYMBOL: callback-error-hook ! ( error -- * )
124 callback-error-hook [ [ die ] ] initialize
126 : rethrow ( error -- * )
130 [ callback-error-hook get-global call( error -- * ) ]
131 [ OBJ-CURRENT-THREAD special-object error-in-thread ]
133 ] [ pop continue-with ] if-empty ;
135 : recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
138 [ catchstack* push ] dip
144 : ignore-errors ( quot -- )
145 [ drop ] recover ; inline
147 : cleanup ( try cleanup-always cleanup-error -- )
148 [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
150 ERROR: attempt-all-error ;
152 : attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
157 [ [ , f ] compose [ , drop t ] recover ] curry all?
158 ] { } make last swap [ rethrow ] when
161 TUPLE: condition error restarts continuation ;
163 C: <condition> condition ( error restarts cc -- condition )
165 : throw-restarts ( error restarts -- restart )
166 [ <condition> throw ] callcc1 2nip ;
168 : rethrow-restarts ( error restarts -- restart )
169 [ <condition> rethrow ] callcc1 2nip ;
171 : throw-continue ( error -- )
172 { { "Continue" t } } throw-restarts drop ;
174 TUPLE: restart name obj continuation ;
178 : restart ( restart -- * )
179 [ obj>> ] [ continuation>> ] bi continue-with ;
181 M: object compute-restarts drop { } ;
183 M: condition compute-restarts
184 [ error>> compute-restarts ]
187 [ continuation>> [ <restart> ] curry ] bi
193 : init-error-handler ( -- )
198 OBJ-CURRENT-THREAD special-object error-thread set-global
199 continuation error-continuation set-global
200 [ original-error set-global ] [ rethrow ] bi
201 ] ERROR-HANDLER-QUOT set-special-object
202 ! VM adds this to kernel errors, so that user-space
204 "kernel-error" OBJ-ERROR set-special-object ;