Start implementing :help

library/bootstrap/boot-stage1.factor

@@ -96,9 +96,6 @@ sequences vectors words ;
 
         "/library/tools/summary.factor"
         "/library/tools/describe.factor"
-        "/library/tools/debugger.factor"
-        
-        "/library/threads.factor"
 
         "/library/help/stylesheet.factor"
         "/library/help/topics.factor"
@@ -108,6 +105,10 @@ sequences vectors words ;
         "/library/help/search.factor"
         "/library/help/syntax.factor"
 
+        "/library/tools/debugger.factor"
+        
+        "/library/threads.factor"
+
         "/library/syntax/parse-stream.factor"
 
         "/library/tools/memory.factor"

library/collections/queues.factor

@@ -33,9 +33,12 @@ C: queue ( -- queue ) ;
         dup queue-head entry-next swap set-queue-head
     ] if ;
 
+TUPLE: empty-queue ;
+: empty-queue <empty-queue> throw ;
+
 : deque ( queue -- obj )
     dup queue-empty? [
-        "Empty queue" throw
+        empty-queue
     ] [
         dup queue-head entry-obj >r (deque) r>
     ] if ;

library/collections/sequences-epilogue.factor

@@ -149,7 +149,8 @@ M: object <=>
 
 : depth ( -- n ) datastack length ;
 
-: no-cond "cond fall-through" throw ;
+TUPLE: no-cond ;
+: no-cond <no-cond> throw ;
 
 : cond ( conditions -- )
     [ first call ] find nip dup [ second call ] [ no-cond ] if ;

library/collections/virtual-sequences.factor

@@ -31,10 +31,13 @@ TUPLE: slice seq from to ;
 : collapse-slice ( from to slice -- from to seq )
     dup slice-from swap slice-seq >r tuck + >r + r> r> ;
 
+TUPLE: slice-error reason ;
+: slice-error ( str -- ) <slice-error> throw ;
+
 : check-slice ( from to seq -- )
-    pick 0 < [ "Slice begins before 0" throw ] when
+    pick 0 < [ "start < 0" slice-error ] when
-    length over < [ "Slice longer than sequence" throw ] when
+    length over < [ "end > sequence" slice-error ] when
-    > [ "Slice start is after slice end" throw ] when ;
+    > [ "start > end" slice-error ] when ;
 
 C: slice ( from to seq -- seq )
     #! A slice of a slice collapses.

library/compiler/alien/malloc.factor

@@ -10,7 +10,8 @@ FUNCTION: void free ( void* ptr ) ;
 FUNCTION: void* realloc ( void* ptr, ulong size ) ;
 FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
 
-: check-ptr [ "Out of memory" throw ] unless* ;
+TUPLE: check-ptr ;
+: check-ptr [ <check-ptr> throw ] unless* ;
 
 : with-malloc ( size quot -- | quot: alien -- )
     swap 1 calloc check-ptr [ swap call ] keep free ; inline

library/errors.factor

@@ -48,5 +48,3 @@ M: condition compute-restarts
     [ delegate compute-restarts ] keep
     [ condition-cc ] keep
     condition-restarts [ swap add ] map-with append ;
-
-GENERIC: error. ( error -- )

library/generic/early-generic.factor

@@ -10,9 +10,5 @@ DEFER: math-combination
 : delegate ( object -- delegate )
     dup tuple? [ 3 slot ] [ drop f ] if ;
 
-: set-delegate ( delegate tuple -- )
+GENERIC: set-delegate ( delegate obj -- )
-    dup tuple? [
+M: tuple set-delegate 3 set-slot ;
-        3 set-slot
-    ] [
-        "Only tuples can have delegates" throw
-    ] if ;

library/generic/tuple.factor

@@ -49,12 +49,15 @@ IN: generic
 
 PREDICATE: word tuple-class "tuple-size" word-prop ;
 
-: check-tuple-class ( class -- )
+TUPLE: tuple-class-error class ;
-    tuple-class? [ "Not a tuple class" throw ] unless ;
+: tuple-class-error ( class -- ) <tuple-class-error> throw ;
+
+: check-tuple-class ( class -- class )
+    dup tuple-class? [ tuple-class-error ] unless ;
 
 : define-constructor ( word class def -- )
     pick reset-generic
-    swap dup check-tuple-class [
+    swap check-tuple-class [
         dup literalize ,
         "tuple-size" word-prop ,
         \ <tuple> , %
@@ -85,13 +88,14 @@ M: tuple = ( obj tuple -- ? )
     2dup eq?
     [ 2drop t ] [ over tuple? [ tuple= ] [ 2drop f ] if ] if ;
 
+: (delegates) ( obj -- )
+    [ dup , delegate (delegates) ] when* ;
+
+: delegates ( obj -- seq )
+    [ (delegates) ] { } make ;
+
 : is? ( obj pred -- ? | pred: obj -- ? )
-    over [
+    >r delegates r> contains? ; inline
-        2dup >r >r call
-        [ r> r> 2drop t ] [ r> delegate r> is? ] if
-    ] [
-        2drop f 
-    ] if ; inline
 
 : >tuple ( seq -- tuple )
     >vector dup first "tuple-size" word-prop over set-length

library/io/c-streams.factor

@@ -46,8 +46,8 @@ IN: io
 
 TUPLE: client-stream host port ;
 
-: c-stream-error
+TUPLE: c-stream-error ;
-    "C-streams I/O does not support this feature" throw ;
+: c-stream-error <c-stream-error> throw ;
 
 : <client> c-stream-error ;
 : <server> c-stream-error ;

library/io/duplex-stream.factor

@@ -12,9 +12,9 @@ C: duplex-stream ( in out -- stream )
     [ set-duplex-stream-out ] keep
     [ set-duplex-stream-in ] keep ;
 
+TUPLE: check-closed ;
 : check-closed ( duplex -- )
-    duplex-stream-closed?
+    duplex-stream-closed? [ <check-closed> throw ] when ;
-    [ "Duplex stream closed" throw ] when ;
 
 : duplex-stream-in+ ( duplex -- stream )
     dup check-closed duplex-stream-in ;

library/math/integer.factor

@@ -33,11 +33,12 @@ IN: math-internals
 : fraction> ( a b -- a/b )
     dup 1 number= [ drop ] [ (fraction>) ] if ; inline
 
-: division-by-zero ( x y -- ) "Division by zero" throw ;
+TUPLE: /0 ;
+: /0 ( x y -- ) </0> throw ;
 
 M: integer / ( x y -- x/y )
     dup zero? [
-        division-by-zero
+        /0
     ] [
         dup 0 < [ [ neg ] 2apply ] when
         2dup gcd nip tuck /i >r /i r> fraction>

library/math/pow.factor

@@ -49,7 +49,7 @@ M: integer (^) ( z w -- z^w )
 
 : log2 ( n -- b )
     {
-        { [ dup 0 <= ] [ "Input must be positive" throw ] }
+        { [ dup 0 <= ] [ "log2 expects positive inputs" throw ] }
         { [ dup 1 = ] [ drop 0 ] }
         { [ t ] [ -1 shift log2 1+ ] }
     } cond ; foldable

library/syntax/parser.factor

@@ -57,6 +57,9 @@ SYMBOL: string-mode
 
 : (parse) ( str -- ) line-text set 0 column set parse-loop ;
 
+TUPLE: bad-escape ;
+: bad-escape ( -- ) <bad-escape> throw ;
+
 ! Parsing word utilities
 : escape ( ch -- esc )
     H{
@@ -69,7 +72,7 @@ SYMBOL: string-mode
         { CHAR: 0  CHAR: \0 }
         { CHAR: \\ CHAR: \\ }
         { CHAR: \" CHAR: \" }
-    } hash [ "Bad escape" throw ] unless* ;
+    } hash [ bad-escape ] unless* ;
 
 : next-escape ( n str -- n ch )
     2dup nth CHAR: u =

library/test/math/complex.factor

@@ -59,8 +59,3 @@ USE: test
 [ 1 0 ] [ 1 >polar ] unit-test
 [ 1 ] [ -1 >polar drop ] unit-test
 [ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
-
-[ 0 ] [ C{ 1 1 } quadrant ] unit-test
-[ 1 ] [ C{ -1 1 } quadrant ] unit-test
-[ 2 ] [ C{ -1 -1 } quadrant ] unit-test
-[ 3 ] [ C{ 1 -1 } quadrant ] unit-test

library/tools/debugger.factor

@@ -1,10 +1,17 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables inspector io kernel
+USING: arrays generic hashtables help inspector io kernel
 kernel-internals math namespaces parser prettyprint sequences
 sequences-internals strings styles vectors words ;
 IN: errors
 
+GENERIC: error. ( error -- )
+GENERIC: error-help ( error -- topic )
+
+M: object error-help ( error -- topic ) drop f ;
+
+M: tuple error-help ( error -- topic ) class ;
+
 SYMBOL: error
 SYMBOL: error-continuation
 SYMBOL: restarts
@@ -56,30 +63,40 @@ SYMBOL: restarts
 DEFER: objc-error. ( alien -- )
 
 PREDICATE: array kernel-error ( obj -- ? )
-    dup first kernel-error eq? swap second 0 18 between? and ;
+    dup first \ kernel-error eq? swap second 0 18 between? and ;
 
-M: kernel-error error. ( error -- )
+: 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.
-    dup second {
+    second {
-        [ expired-error. ]
+        expired-error.
-        [ io-error. ]
+        io-error.
-        [ undefined-word-error. ]
+        undefined-word-error.
-        [ type-check-error. ]
+        type-check-error.
-        [ signal-error. ]
+        signal-error.
-        [ negative-array-size-error. ]
+        negative-array-size-error.
-        [ c-string-error. ]
+        c-string-error.
-        [ ffi-error. ]
+        ffi-error.
-        [ heap-scan-error. ]
+        heap-scan-error.
-        [ undefined-symbol-error. ]
+        undefined-symbol-error.
-        [ user-interrupt. ]
+        user-interrupt.
-        [ "Data" stack-underflow. ]
+        datastack-underflow.
-        [ "Data" stack-overflow. ]
+        datastack-overflow.
-        [ "Retain" stack-underflow. ]
+        retainstack-underflow.
-        [ "Retain" stack-overflow. ]
+        retainstack-overflow.
-        [ "Call" stack-underflow. ]
+        callstack-underflow.
-        [ "Call" stack-overflow. ]
+        callstack-overflow.
-        [ objc-error. ]
+    } nth ;
-    } dispatch ;
+
+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" ;
@@ -131,6 +148,14 @@ M: object error. ( error -- ) . ;
 
 : :res ( n -- ) restarts get nth first3 continue-with ;
 
+: :help ( -- )
+    error get delegates [ error-help ] map [ ] subset
+    dup empty? [
+        "No help for this error. " print
+    ] [
+        [ help ] each
+    ] if ;
+
 : (debug-help) ( string quot -- )
     <input> write-object terpri ;
 
@@ -152,10 +177,11 @@ M: object error. ( error -- ) . ;
     terpri
     "Debugger commands:" print
     terpri
-    ":s  data stack at exception time" [ :s ] (debug-help)
+    ":help - documentation for this error" [ :help ] (debug-help)
-    ":r  retain stack at exception time" [ :r ] (debug-help)
+    ":s    - data stack at exception time" [ :s ] (debug-help)
-    ":c  call stack at exception time" [ :c ] (debug-help)
+    ":r    - retain stack at exception time" [ :r ] (debug-help)
-    ":get ( var -- value ) accesses variables at time of error" print
+    ":c    - call stack at exception time" [ :c ] (debug-help)
+    ":get  ( var -- value ) accesses variables at time of error" print
     flush ;
 
 : print-error ( error -- )
@@ -181,4 +207,4 @@ M: object error. ( error -- ) . ;
     V{ } clone set-catchstack
     ( kernel calls on error )
     [ error-handler ] 5 setenv
-    kernel-error 12 setenv ;
+    \ kernel-error 12 setenv ;

library/tools/summary.factor

@@ -1,6 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inspector
+USING: generic kernel namespaces prettyprint sequences strings
+styles words ;
 
 GENERIC: summary ( object -- string )
 

library/ui/gestures.factor

@@ -4,13 +4,8 @@ IN: gadgets
 USING: generic hashtables kernel math models namespaces queues
 sequences words ;
 
-: (gestures) ( gadget -- )
+: gestures ( gadget -- seq )
-    [
+    delegates [ "gestures" word-prop ] map [ ] subset ;
-        dup delegate (gestures)
-        class "gestures" word-prop [ , ] when*
-    ] when* ;
-
-: gestures ( gadget -- seq ) [ (gestures) ] { } make ;
 
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
 

library/words.factor

@@ -139,12 +139,13 @@ SYMBOL: bootstrapping?
         dup word-name over word-vocabulary nest set-hash
     ] bind ;
 
-: check-create ( name vocab -- )
+TUPLE: check-create name vocab ;
-    string? [ "Vocabulary name is not a string" throw ] unless
+: check-create ( name vocab -- name vocab )
-    string? [ "Word name is not a string" throw ] unless ;
+    dup string? [ <check-create> throw ] unless
+    over string? [ <check-create> throw ] unless ;
 
 : create ( name vocab -- word )
-    2dup check-create 2dup lookup dup
+    check-create 2dup lookup dup
     [ 2nip ] [ drop <word> dup reveal ] if ;
 
 : constructor-word ( string vocab -- word )