Some code cleanups

doc/handbook/handbook.facts

@@ -51,7 +51,7 @@ ARTICLE: "article-index" "Article index"
 ARTICLE: "primitive-index" "Primitive index"
 { $outliner [ all-words [ primitive? ] subset ] } ;
 
-ARTICLE: "error-index" "Type index"
+ARTICLE: "error-index" "Error index"
 { $subsection /0                         }
 { $subsection alien-callback-error       }
 { $subsection alien-invoke-error         }

library/bootstrap/boot-stage1.factor

@@ -159,6 +159,8 @@ sequences vectors words ;
 
         "/library/cli.factor"
         "/library/modules.factor"
+
+        "/library/tools/errors.factor"
         
         "/library/bootstrap/init.factor"
         "/library/bootstrap/image.factor"

library/compiler/alien/alien-callback.factor

@@ -9,9 +9,6 @@ C: alien-callback make-node ;
 
 TUPLE: alien-callback-error ;
 
-M: alien-callback-error summary ( error -- )
-    drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
-
 : alien-callback ( return parameters quot -- address )
     <alien-callback-error> throw ;
 

library/compiler/inference/inference.factor

@@ -15,12 +15,6 @@ TUPLE: inference-error message rstate data-stack call-stack ;
     recursive-state get meta-d get meta-r get
     <inference-error> throw ;
 
-M: inference-error error. ( error -- )
-    "Inference error:" print
-    dup inference-error-message print
-    "Recursive state:" print
-    inference-error-rstate describe ;
-
 M: object value-literal ( value -- )
     "A literal value was expected where a computed value was found" inference-error ;
 

library/generic/tuple.factor

@@ -55,7 +55,7 @@ TUPLE: check-tuple class ;
 
 : define-constructor ( word class def -- )
     pick reset-generic
-    swap check-tuple-class [
+    swap check-tuple [
         dup literalize ,
         "tuple-size" word-prop ,
         \ <tuple> , %

library/test/test.factor

@@ -6,7 +6,6 @@ memory namespaces parser prettyprint sequences strings words
 vectors ;
 
 TUPLE: assert got expect ;
-M: assert summary drop "Assertion failed" ;
 : assert ( got expect -- ) <assert> throw ;
 
 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;

library/tools/debugger.factor

@@ -5,150 +5,29 @@ kernel-internals math namespaces parser prettyprint sequences
 sequences-internals strings styles vectors words ;
 IN: errors
 
+PREDICATE: array kernel-error ( obj -- ? )
+    dup first \ kernel-error eq? swap second 0 18 between? and ;
+
 GENERIC: error. ( error -- )
 GENERIC: error-help ( error -- topic )
 
+M: object error. ( error -- ) . ;
 M: object error-help ( error -- topic ) drop f ;
 
+M: tuple error. ( error -- ) describe ;
 M: tuple error-help ( error -- topic ) class ;
 
+M: string error. ( error -- ) print ;
+
 SYMBOL: error
 SYMBOL: error-continuation
 SYMBOL: restarts
 
-: expired-error. ( obj -- )
+: :s error-continuation get continuation-data stack. ;
-    "Object did not survive image save/load: " write third . ;
+: :r error-continuation get continuation-retain stack. ;
-
+: :c error-continuation get continuation-call callstack. ;
-: undefined-word-error. ( obj -- )
+: :get error-continuation get continuation-name hash-stack ;
-    "Undefined word: " write third . ;
+: :res restarts get nth first3 continue-with ;
-
-: io-error. ( error -- )
-    "I/O error: " write third print ;
-
-: type-check-error. ( list -- )
-    "Type check error" print
-    "Object: " write dup fourth short.
-    "Object type: " write dup fourth class .
-    "Expected type: " write third type>class . ;
-
-: signal-error. ( obj -- )
-    "Operating system signal " write third . ;
-
-: negative-array-size-error. ( obj -- )
-    "Cannot allocate array with negative size " write third . ;
-
-: c-string-error. ( obj -- )
-    "Cannot convert to C string: " write third . ;
-
-: ffi-error. ( obj -- )
-    "FFI: " write third print ;
-
-: 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 ;
-
-: user-interrupt. ( obj -- )
-    "User interrupt" print drop ;
-
-: stack-underflow. ( obj name -- )
-    write " stack underflow" print drop ;
-
-: stack-overflow. ( obj name -- )
-    write " stack overflow" print drop ;
-
-! Hook for library/cocoa/
-DEFER: objc-error. ( alien -- )
-
-PREDICATE: array kernel-error ( obj -- ? )
-    dup first \ kernel-error eq? swap second 0 18 between? and ;
-
-: datastack-underflow. "Data" stack-underflow. ;
-: datastack-overflow. "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
-: callstack-underflow. "Call" stack-underflow. ;
-: callstack-overflow. "Call" stack-overflow. ;
-
-: kernel-error ( error -- word )
-    #! Kernel errors are indexed by integers.
-    second {
-        expired-error.
-        io-error.
-        undefined-word-error.
-        type-check-error.
-        signal-error.
-        negative-array-size-error.
-        c-string-error.
-        ffi-error.
-        heap-scan-error.
-        undefined-symbol-error.
-        user-interrupt.
-        datastack-underflow.
-        datastack-overflow.
-        retainstack-underflow.
-        retainstack-overflow.
-        callstack-underflow.
-        callstack-overflow.
-    } nth ;
-
-M: kernel-error error. ( error -- ) dup kernel-error execute ;
-
-M: kernel-error error-help ( error -- topic ) kernel-error ;
-
-M: no-method summary
-    drop "No suitable method" ;
-
-M: no-method error. ( error -- )
-    "Generic word " write
-    dup no-method-generic pprint
-    " does not define a method for the " write
-    dup no-method-object class pprint
-    " class." print
-    "Allowed classes: " write dup no-method-generic order .
-    "Dispatching on object: " write no-method-object short. ;
-
-M: no-math-method summary
-    drop "No suitable arithmetic method" ;
-
-: parse-dump ( error -- )
-    "Parsing " write
-    dup parse-error-file [ "<interactive>" ] unless* write
-    ":" write
-    dup parse-error-line [ 1 ] unless* number>string print
-    
-    dup parse-error-text dup string? [ print ] [ drop ] if
-    
-    parse-error-col [ 0 ] unless*
-    CHAR: \s <string> write "^" print ;
-
-M: parse-error error. ( error -- )
-    dup parse-dump  delegate error. ;
-
-M: bounds-error summary drop "Sequence index out of bounds" ;
-
-M: condition error. delegate error. ;
-
-M: condition error-help drop f ;
-
-M: tuple error. ( error -- ) describe ;
-
-M: string error. ( error -- ) print ;
-
-M: object error. ( error -- ) . ;
-
-: :s ( -- ) error-continuation get continuation-data stack. ;
-
-: :r ( -- ) error-continuation get continuation-retain stack. ;
-
-: :c ( -- ) error-continuation get continuation-call callstack. ;
-
-: :get ( var -- value )
-    error-continuation get continuation-name hash-stack ;
-
-: :res ( n -- ) restarts get nth first3 continue-with ;
 
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset

library/tools/errors.factor

@@ -0,0 +1,171 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: errors
+USING: alien generic help inference inspector io kernel libc
+math math-internals parser prettyprint queues sequences
+sequences-internals strings test words ;
+
+: expired-error. ( obj -- )
+    "Object did not survive image save/load: " write third . ;
+
+: undefined-word-error. ( obj -- )
+    "Undefined word: " write third . ;
+
+: io-error. ( error -- )
+    "I/O error: " write third print ;
+
+: type-check-error. ( list -- )
+    "Type check error" print
+    "Object: " write dup fourth short.
+    "Object type: " write dup fourth class .
+    "Expected type: " write third type>class . ;
+
+: signal-error. ( obj -- )
+    "Operating system signal " write third . ;
+
+: negative-array-size-error. ( obj -- )
+    "Cannot allocate array with negative size " write third . ;
+
+: c-string-error. ( obj -- )
+    "Cannot convert to C string: " write third . ;
+
+: ffi-error. ( obj -- )
+    "FFI: " write third print ;
+
+: 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 ;
+
+: user-interrupt. ( obj -- )
+    "User interrupt" print drop ;
+
+: stack-underflow. ( obj name -- )
+    write " stack underflow" print drop ;
+
+: stack-overflow. ( obj name -- )
+    write " stack overflow" print drop ;
+
+! Hook for library/cocoa/
+DEFER: objc-error. ( alien -- )
+
+: datastack-underflow. "Data" stack-underflow. ;
+: datastack-overflow. "Data" stack-overflow. ;
+: retainstack-underflow. "Retain" stack-underflow. ;
+: retainstack-overflow. "Retain" stack-overflow. ;
+: callstack-underflow. "Call" stack-underflow. ;
+: callstack-overflow. "Call" stack-overflow. ;
+
+: kernel-error ( error -- word )
+    #! Kernel errors are indexed by integers.
+    second {
+        expired-error.
+        io-error.
+        undefined-word-error.
+        type-check-error.
+        signal-error.
+        negative-array-size-error.
+        c-string-error.
+        ffi-error.
+        heap-scan-error.
+        undefined-symbol-error.
+        user-interrupt.
+        datastack-underflow.
+        datastack-overflow.
+        retainstack-underflow.
+        retainstack-overflow.
+        callstack-underflow.
+        callstack-overflow.
+    } nth ;
+
+M: kernel-error error. ( error -- ) dup kernel-error execute ;
+
+M: kernel-error error-help ( error -- topic ) kernel-error ;
+
+M: no-method summary
+    drop "No suitable method" ;
+
+M: no-method error. ( error -- )
+    "Generic word " write
+    dup no-method-generic pprint
+    " does not define a method for the " write
+    dup no-method-object class pprint
+    " class." print
+    "Allowed classes: " write dup no-method-generic order .
+    "Dispatching on object: " write no-method-object short. ;
+
+M: no-math-method summary
+    drop "No suitable arithmetic method" ;
+
+M: /0 summary
+    drop "Division by zero" ;
+
+M: bad-escape summary
+    drop "Invalid escape code" ;
+
+M: c-stream-error summary
+    drop "C stream I/O does not support this feature" ;
+
+M: check-closed summary
+    drop "Attempt to perform I/O on closed stream" ;
+
+M: check-method summary
+    drop "Invalid parameters for define-method" ;
+
+M: check-ptr summary
+    drop "Memory allocation failed" ;
+
+M: check-tuple summary
+    drop "Invalid class for define-constructor" ;
+
+M: check-vocab summary
+    drop "Vocabulary does not exist" ;
+
+M: empty-queue summary
+    drop "Empty queue" ;
+
+M: no-article summary
+    drop "Help article does not exist" ;
+
+M: no-cond summary
+    drop "Fall-through in cond" ;
+
+M: slice-error error.
+    "Cannot create slice because " write
+    slice-error-reason append print ;
+
+: parse-dump ( error -- )
+    "Parsing " write
+    dup parse-error-file [ "<interactive>" ] unless* write
+    ":" write
+    dup parse-error-line [ 1 ] unless* number>string print
+    
+    dup parse-error-text dup string? [ print ] [ drop ] if
+    
+    parse-error-col [ 0 ] unless*
+    CHAR: \s <string> write "^" print ;
+
+M: parse-error error. ( error -- )
+    dup parse-dump  delegate error. ;
+
+M: bounds-error summary drop "Sequence index out of bounds" ;
+
+M: condition error. delegate error. ;
+
+M: condition error-help drop f ;
+
+M: alien-callback-error summary ( error -- )
+    drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
+
+M: alien-invoke-error summary ( error -- )
+    drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
+
+M: assert summary drop "Assertion failed" ;
+
+M: inference-error error. ( error -- )
+    "Inference error:" print
+    dup inference-error-message print
+    "Recursive state:" print
+    inference-error-rstate describe ;