Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / debugger / debugger.factor

diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 49ec534e8fa59c9bc0f27219235a8e9934394628..ce9496291c6ff94a4bfeb9b188087b8a48ec1006 100644 (file)
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -1,14 +1,13 @@
 ! 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
@@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
 GENERIC: error-help ( error -- topic )
 
 M: object error. . ;
+
 M: object error-help drop f ;
 
 M: tuple error-help class ;
@@ -36,7 +36,7 @@ M: string error. print ;
     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 ;
@@ -44,7 +44,7 @@ M: string error. print ;
 
 : restart. ( restart n -- )
     [
-        1+ dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
+        1 + dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
         name>> %
     ] "" make print ;
 
@@ -77,7 +77,7 @@ M: string error. 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
@@ -88,27 +88,24 @@ M: string 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 ;
@@ -127,14 +124,14 @@ M: string error. print ;
 : 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.               ] }
@@ -154,9 +151,11 @@ PREDICATE: kernel-error < array
         { 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" ;
@@ -252,8 +251,24 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ;
 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
@@ -306,4 +321,9 @@ M: check-mixin-class summary drop "Not a mixin class" ;
 
 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