1 ! Copyright (C) 2003, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays vectors kernel kernel.private sequences
4 namespaces make math splitting sorting quotations assocs
5 combinators combinators.private accessors ;
9 SYMBOL: error-continuation
15 : catchstack* ( -- catchstack )
16 1 getenv { vector } declare ; inline
18 : >c ( continuation -- ) catchstack* push ;
20 : c> ( -- continuation ) catchstack* pop ;
22 ! We have to defeat some optimizations to make continuations work
23 : dummy-1 ( -- obj ) f ;
24 : dummy-2 ( obj -- obj ) dup drop ;
26 : init-catchstack ( -- ) V{ } clone 1 setenv ;
30 : catchstack ( -- catchstack ) catchstack* clone ; inline
32 : set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
34 TUPLE: continuation data call retain name catch ;
36 C: <continuation> continuation
38 : continuation ( -- continuation )
39 datastack callstack retainstack namestack catchstack
42 : >continuation< ( continuation -- data call retain name catch )
51 : ifcc ( capture restore -- )
52 #! After continuation is being captured, the stacks looks
54 #! ( f continuation r:capture r:restore )
55 #! so the 'capture' branch is taken.
57 #! Note that the continuation itself is not captured as part
62 #! After the continuation is resumed, (continue-with) pushes
63 #! the given value together with f,
64 #! so now, the stacks looks like:
65 #! ( value f r:capture r:restore )
66 #! Execution begins right after the call to 'continuation'.
67 #! The 'restore' branch is taken.
68 [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
70 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
72 : callcc1 ( quot -- obj ) [ ] ifcc ; inline
76 : (continue) ( continuation -- * )
86 : continue-with ( obj continuation -- * )
93 [ set-datastack drop 4 getenv f 4 setenv f ] dip
95 ] (( obj continuation -- * )) call-effect-unsafe ;
97 : continue ( continuation -- * )
98 f swap continue-with ;
100 SYMBOL: return-continuation
102 : with-return ( quot -- )
103 [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
106 return-continuation get continue ;
108 : with-datastack ( stack quot -- newstack )
111 [ [ { } like set-datastack ] dip call datastack ] dip
113 ] (( stack quot continuation -- * )) call-effect-unsafe
116 GENERIC: compute-restarts ( error -- seq )
120 : save-error ( error -- )
122 compute-restarts restarts set-global ;
126 SYMBOL: thread-error-hook
128 : rethrow ( error -- * )
131 thread-error-hook get-global
132 [ (( error -- * )) call-effect-unsafe ] [ die ] if*
136 : recover ( try recovery -- )
137 [ [ swap >c call c> drop ] curry ] dip ifcc ; inline
139 : ignore-errors ( quot -- )
140 [ drop ] recover ; inline
142 : cleanup ( try cleanup-always cleanup-error -- )
143 [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
145 ERROR: attempt-all-error ;
147 : attempt-all ( seq quot -- obj )
152 [ [ , f ] compose [ , drop t ] recover ] curry all?
153 ] { } make peek swap [ rethrow ] when
156 : retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
158 TUPLE: condition error restarts continuation ;
160 C: <condition> condition ( error restarts cc -- condition )
162 : throw-restarts ( error restarts -- restart )
163 [ <condition> throw ] callcc1 2nip ;
165 : rethrow-restarts ( error restarts -- restart )
166 [ <condition> rethrow ] callcc1 2nip ;
168 TUPLE: restart name obj continuation ;
172 : restart ( restart -- * )
173 [ obj>> ] [ continuation>> ] bi continue-with ;
175 M: object compute-restarts drop { } ;
177 M: condition compute-restarts
178 [ error>> compute-restarts ]
181 [ continuation>> [ <restart> ] curry ] bi
187 : init-error-handler ( -- )
188 V{ } clone set-catchstack
192 63 getenv error-thread set-global
193 continuation error-continuation set-global
196 ! VM adds this to kernel errors, so that user-space
198 "kernel-error" 6 setenv ;