1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: slots arrays definitions generic hashtables summary io
4 kernel math namespaces prettyprint prettyprint.config sequences
5 assocs sequences.private strings io.styles vectors words system
6 splitting math.parser classes.tuple continuations
7 continuations.private combinators generic.math classes.builtin
8 classes compiler.units generic.standard vocabs threads
9 threads.private init kernel.private libc io.encodings
10 accessors math.order destructors ;
13 GENERIC: error. ( error -- )
14 GENERIC: error-help ( error -- topic )
17 M: object error-help drop f ;
19 M: tuple error-help class ;
21 M: string error. print ;
24 error-continuation get continuation-data stack. ;
27 error-continuation get continuation-retain stack. ;
30 error-continuation get continuation-call callstack. ;
32 : :get ( variable -- value )
33 error-continuation get continuation-name assoc-stack ;
36 1- restarts get-global nth f restarts set-global restart ;
38 : :1 ( -- * ) 1 :res ;
39 : :2 ( -- * ) 2 :res ;
40 : :3 ( -- * ) 3 :res ;
42 : restart. ( restart n -- )
44 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
49 restarts get dup empty? [
53 "The following restarts are available:" print
55 dup length [ restart. ] 2each
58 : print-error ( error -- )
59 [ error. flush ] curry
60 [ global [ "Error in print-error!" print drop ] bind ]
63 : print-error-and-restarts ( error -- )
67 "Type :help for debugging help." print flush ;
70 [ print-error-and-restarts ] recover ;
72 ERROR: assert got expect ;
74 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
76 : depth ( -- n ) datastack length ;
78 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
79 2dup [ length ] bi@ min tuck tail >r tail r> ;
81 ERROR: relative-underflow stack ;
83 M: relative-underflow summary
84 drop "Too many items removed from data stack" ;
86 ERROR: relative-overflow stack ;
88 M: relative-overflow summary
89 drop "Superfluous items pushed to data stack" ;
91 : assert-depth ( quot -- )
92 >r datastack r> dip >r datastack r>
93 2dup [ length ] compare {
94 { +lt+ [ trim-datastacks nip relative-underflow ] }
96 { +gt+ [ trim-datastacks drop relative-overflow ] }
99 : expired-error. ( obj -- )
100 "Object did not survive image save/load: " write third . ;
102 : io-error. ( error -- )
103 "I/O error: " write third print ;
105 : type-check-error. ( obj -- )
106 "Type check error" print
107 "Object: " write dup fourth short.
108 "Object type: " write dup fourth class .
109 "Expected type: " write third type>class . ;
111 : divide-by-zero-error. ( obj -- )
112 "Division by zero" print drop ;
114 : signal-error. ( obj -- )
115 "Operating system signal " write third . ;
117 : array-size-error. ( obj -- )
118 "Invalid array size: " write dup third .
119 "Maximum: " write fourth 1- . ;
121 : c-string-error. ( obj -- )
122 "Cannot convert to C string: " write third . ;
124 : ffi-error. ( obj -- )
126 dup third [ write ": " write ] when*
129 : heap-scan-error. ( obj -- )
130 "Cannot do next-object outside begin/end-scan" print drop ;
132 : undefined-symbol-error. ( obj -- )
133 "The image refers to a library or symbol that was not found"
134 " at load time" append print drop ;
136 : stack-underflow. ( obj name -- )
137 write " stack underflow" print drop ;
139 : stack-overflow. ( obj name -- )
140 write " stack overflow" print drop ;
142 : datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
143 : datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
144 : retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
145 : retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
147 : memory-error. ( error -- )
148 "Memory protection fault at address " write third .h ;
150 : primitive-error. ( error -- )
151 "Unimplemented primitive" print drop ;
153 PREDICATE: kernel-error < array
155 { [ dup empty? ] [ drop f ] }
156 { [ dup first "kernel-error" = not ] [ drop f ] }
157 [ second 0 15 between? ]
160 : kernel-errors ( error -- n errors )
162 { 0 [ expired-error. ] }
164 { 2 [ primitive-error. ] }
165 { 3 [ type-check-error. ] }
166 { 4 [ divide-by-zero-error. ] }
167 { 5 [ signal-error. ] }
168 { 6 [ array-size-error. ] }
169 { 7 [ c-string-error. ] }
171 { 9 [ heap-scan-error. ] }
172 { 10 [ undefined-symbol-error. ] }
173 { 11 [ datastack-underflow. ] }
174 { 12 [ datastack-overflow. ] }
175 { 13 [ retainstack-underflow. ] }
176 { 14 [ retainstack-overflow. ] }
177 { 15 [ memory-error. ] }
180 M: kernel-error error. dup kernel-errors case ;
182 M: kernel-error error-help kernel-errors at first ;
185 drop "No suitable method" ;
188 "Generic word " write
190 " does not define a method for the " write
191 dup object>> class pprint
193 "Dispatching on object: " write object>> short. ;
195 M: bad-slot-value summary drop "Bad store to specialized slot" ;
197 M: no-math-method summary
198 drop "No suitable arithmetic method" ;
200 M: no-next-method summary
201 drop "Executing call-next-method from least-specific method" ;
203 M: inconsistent-next-method summary
204 drop "Executing call-next-method with inconsistent parameters" ;
206 M: check-method summary
207 drop "Invalid parameters for create-method" ;
209 M: not-a-tuple summary
212 M: bad-superclass summary
213 drop "Tuple classes can only inherit from other tuple classes" ;
216 drop "Fall-through in cond" ;
219 drop "Fall-through in case" ;
221 M: slice-error error.
222 "Cannot create slice because " write
223 slice-error-reason print ;
225 M: bounds-error summary drop "Sequence index out of bounds" ;
227 M: condition error. error>> error. ;
229 M: condition summary error>> summary ;
231 M: condition error-help error>> error-help ;
233 M: assert summary drop "Assertion failed" ;
236 "Assertion failed" print
237 standard-table-style [
240 [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
241 [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
244 M: immutable summary drop "Sequence is immutable" ;
246 M: redefine-error error.
247 "Re-definition of " write
248 redefine-error-def . ;
251 drop "Calling a deferred word before it has been defined" ;
253 M: no-compilation-unit error.
254 "Attempting to define " write
255 no-compilation-unit-definition pprint
256 " outside of a compilation unit" print ;
259 drop "Vocabulary does not exist" ;
262 drop "Memory allocation failed" ;
264 M: double-free summary
265 drop "Free failed since memory is not allocated" ;
267 M: realloc-error summary
268 drop "Memory reallocation failed" ;
270 : error-in-thread. ( thread -- )
271 "Error in thread " write
274 " (" % dup thread-name %
275 ", " % dup thread-quot unparse-short % ")" %
276 ] "" make swap write-object ":" print nl ;
279 M: thread error-in-thread ( error thread -- )
280 initial-thread get-global eq? [
284 error-thread get-global error-in-thread. print-error flush
288 M: encode-error summary drop "Character encoding error" ;
290 M: decode-error summary drop "Character decoding error" ;
292 M: bad-create summary drop "Bad parameters to create" ;
294 M: attempt-all-error summary drop "Nothing to attempt" ;
296 M: already-disposed summary drop "Attempting to operate on disposed object" ;
300 : init-debugger ( -- )
301 V{ } clone set-catchstack
304 self error-thread set-global
305 continuation error-continuation set-global
308 ! VM adds this to kernel errors, so that user-space
310 "kernel-error" 6 setenv ;
314 [ init-debugger ] "debugger" add-init-hook