! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slots arrays definitions generic hashtables summary io
-kernel math namespaces make prettyprint prettyprint.config
-sequences assocs sequences.private strings io.styles
-io.pathnames vectors words system splitting math.parser
-classes.mixin classes.tuple continuations continuations.private
-combinators generic.math classes.builtin classes compiler.units
-generic.standard vocabs init kernel.private io.encodings
-accessors math.order destructors source-files parser
-classes.tuple.parser effects.parser lexer
+USING: slots arrays definitions generic hashtables summary io kernel
+math namespaces make prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles io.pathnames vectors words system
+splitting math.parser classes.mixin classes.tuple continuations
+continuations.private combinators generic.math classes.builtin classes
+compiler.units generic.standard generic.single vocabs init
+kernel.private io.encodings accessors math.order destructors
+source-files parser classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger
GENERIC: error-help ( error -- topic )
M: object error. . ;
+
M: object error-help drop f ;
M: tuple error-help class ;
error-continuation get name>> assoc-stack ;
: :res ( n -- * )
- 1- restarts get-global nth f restarts set-global restart ;
+ 1 - restarts get-global nth f restarts set-global restart ;
: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: restart. ( restart n -- )
[
- 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
+ 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;
"Object did not survive image save/load: " write third . ;
: io-error. ( error -- )
- "I/O error: " write third print ;
+ "I/O error #" write third . ;
: type-check-error. ( obj -- )
"Type check error" print
: divide-by-zero-error. ( obj -- )
"Division by zero" print drop ;
-: signal-error. ( obj -- )
- "Operating system signal " write third . ;
+HOOK: signal-error. os ( obj -- )
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
- "Maximum: " write fourth 1- . ;
+ "Maximum: " write fourth 1 - . ;
: c-string-error. ( obj -- )
"Cannot convert to C string: " write third . ;
: ffi-error. ( obj -- )
- "FFI: " write
- dup third [ write ": " write ] when*
- fourth print ;
+ "FFI error" print drop ;
: heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ;
: undefined-symbol-error. ( obj -- )
- "The image refers to a library or symbol that was not found"
- " at load time" append print drop ;
+ "The image refers to a library or symbol that was not found at load time"
+ print drop ;
: stack-underflow. ( obj name -- )
write " stack underflow" print drop ;
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
-PREDICATE: kernel-error < array
+PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
[ second 0 15 between? ]
} cond ;
-: kernel-errors ( error -- n errors )
+: vm-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
{ 15 [ memory-error. ] }
} ; inline
-M: kernel-error error. dup kernel-errors case ;
+M: vm-error summary drop "VM error" ;
+
+M: vm-error error. dup vm-errors case ;
-M: kernel-error error-help kernel-errors at first ;
+M: vm-error error-help vm-errors at first ;
M: no-method summary
drop "No suitable method" ;
M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ;
-M: no-word-error error.
- "No word named ``" write name>> write "'' found in current vocabulary search path" print ;
+M: no-word-error summary
+ name>>
+ "No word named ``"
+ "'' found in current vocabulary search path" surround ;
+
+M: no-word-error error. summary print ;
+
+M: no-word-in-vocab summary
+ [ vocab>> ] [ word>> ] bi
+ [ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
+
+M: no-word-in-vocab error. summary print ;
+
+M: ambiguous-use-error summary
+ words>> first name>>
+ "More than one vocabulary defines a word named ``" "''" surround ;
+
+M: ambiguous-use-error error. summary print ;
M: staging-violation summary
drop
M: invalid-slot-name summary
drop "Invalid slot name" ;
-M: source-file-error summary
- error>> summary ;
-
-M: source-file-error compute-restarts
- error>> compute-restarts ;
-
-M: source-file-error error-help
- error>> error-help ;
-
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
M: lexer-error error-help
error>> error-help ;
-M: source-file-error error.
- [
- [
- [
- [ file>> [ % ": " % ] when* ]
- [ line#>> [ # ": " % ] when* ] bi
- ] "" make
- ] [
- [
- presented set
- bold font-style set
- ] H{ } make-assoc
- ] bi format
- ] [ error>> error. ] bi ;
-
M: bad-effect summary
drop "Bad stack effect declaration" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
\ No newline at end of file
+M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+
+{
+ { [ os windows? ] [ "debugger.windows" require ] }
+ { [ os unix? ] [ "debugger.unix" require ] }
+} cond