From a552e6d30d72a0701c53e5e9eac2097d6d1a126a Mon Sep 17 00:00:00 2001 From: slava Date: Tue, 1 Aug 2006 08:45:05 +0000 Subject: [PATCH] Start implementing :help --- library/bootstrap/boot-stage1.factor | 7 +- library/collections/queues.factor | 5 +- library/collections/sequences-epilogue.factor | 3 +- library/collections/virtual-sequences.factor | 9 +- library/compiler/alien/malloc.factor | 3 +- library/errors.factor | 2 - library/generic/early-generic.factor | 8 +- library/generic/tuple.factor | 22 +++-- library/io/c-streams.factor | 4 +- library/io/duplex-stream.factor | 4 +- library/math/integer.factor | 5 +- library/math/pow.factor | 2 +- library/syntax/parser.factor | 5 +- library/test/math/complex.factor | 5 -- library/tools/debugger.factor | 82 ++++++++++++------- library/tools/summary.factor | 2 + library/ui/gestures.factor | 9 +- library/words.factor | 9 +- 18 files changed, 108 insertions(+), 78 deletions(-) diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 0de09bf355..61e2130bc8 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/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" diff --git a/library/collections/queues.factor b/library/collections/queues.factor index 12b6f2d7a5..3f8daee367 100644 --- a/library/collections/queues.factor +++ b/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 throw ; + : deque ( queue -- obj ) dup queue-empty? [ - "Empty queue" throw + empty-queue ] [ dup queue-head entry-obj >r (deque) r> ] if ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 833b17b209..a8af00e366 100644 --- a/library/collections/sequences-epilogue.factor +++ b/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 throw ; : cond ( conditions -- ) [ first call ] find nip dup [ second call ] [ no-cond ] if ; diff --git a/library/collections/virtual-sequences.factor b/library/collections/virtual-sequences.factor index 6562d7597c..5e70727da4 100644 --- a/library/collections/virtual-sequences.factor +++ b/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 -- ) throw ; + : check-slice ( from to seq -- ) - pick 0 < [ "Slice begins before 0" throw ] when - length over < [ "Slice longer than sequence" throw ] when - > [ "Slice start is after slice end" throw ] when ; + pick 0 < [ "start < 0" slice-error ] when + length over < [ "end > sequence" slice-error ] when + > [ "start > end" slice-error ] when ; C: slice ( from to seq -- seq ) #! A slice of a slice collapses. diff --git a/library/compiler/alien/malloc.factor b/library/compiler/alien/malloc.factor index d63dc6fa27..0afca8c89d 100644 --- a/library/compiler/alien/malloc.factor +++ b/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 [ throw ] unless* ; : with-malloc ( size quot -- | quot: alien -- ) swap 1 calloc check-ptr [ swap call ] keep free ; inline diff --git a/library/errors.factor b/library/errors.factor index b7f4ed8f6b..be7da35dc1 100644 --- a/library/errors.factor +++ b/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 -- ) diff --git a/library/generic/early-generic.factor b/library/generic/early-generic.factor index dd1c9ec09b..fbb49fe7c1 100644 --- a/library/generic/early-generic.factor +++ b/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 -- ) - dup tuple? [ - 3 set-slot - ] [ - "Only tuples can have delegates" throw - ] if ; +GENERIC: set-delegate ( delegate obj -- ) +M: tuple set-delegate 3 set-slot ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index de30eb497e..5f34daff79 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -49,12 +49,15 @@ IN: generic PREDICATE: word tuple-class "tuple-size" word-prop ; -: check-tuple-class ( class -- ) - tuple-class? [ "Not a tuple class" throw ] unless ; +TUPLE: tuple-class-error class ; +: tuple-class-error ( class -- ) 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 , \ , % @@ -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 [ - 2dup >r >r call - [ r> r> 2drop t ] [ r> delegate r> is? ] if - ] [ - 2drop f - ] if ; inline + >r delegates r> contains? ; inline : >tuple ( seq -- tuple ) >vector dup first "tuple-size" word-prop over set-length diff --git a/library/io/c-streams.factor b/library/io/c-streams.factor index 99fd4a59bd..66a94c385c 100644 --- a/library/io/c-streams.factor +++ b/library/io/c-streams.factor @@ -46,8 +46,8 @@ IN: io TUPLE: client-stream host port ; -: c-stream-error - "C-streams I/O does not support this feature" throw ; +TUPLE: c-stream-error ; +: c-stream-error throw ; : c-stream-error ; : c-stream-error ; diff --git a/library/io/duplex-stream.factor b/library/io/duplex-stream.factor index b7a55d3b12..80fbd07c77 100644 --- a/library/io/duplex-stream.factor +++ b/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" throw ] when ; + duplex-stream-closed? [ throw ] when ; : duplex-stream-in+ ( duplex -- stream ) dup check-closed duplex-stream-in ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 118f276e73..487b85b197 100644 --- a/library/math/integer.factor +++ b/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 -- ) 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> diff --git a/library/math/pow.factor b/library/math/pow.factor index d70e7d1615..f19d576181 100644 --- a/library/math/pow.factor +++ b/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 diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 0757148d31..fa21f21695 100644 --- a/library/syntax/parser.factor +++ b/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 ( -- ) 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 = diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 00700bb9cc..b891c92113 100644 --- a/library/test/math/complex.factor +++ b/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 diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index b49599b9aa..583a9eabd1 100644 --- a/library/tools/debugger.factor +++ b/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 { - [ 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. ] - [ "Data" stack-underflow. ] - [ "Data" stack-overflow. ] - [ "Retain" stack-underflow. ] - [ "Retain" stack-overflow. ] - [ "Call" stack-underflow. ] - [ "Call" stack-overflow. ] - [ objc-error. ] - } dispatch ; + 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" ; @@ -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 -- ) 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) - ":r retain stack at exception time" [ :r ] (debug-help) - ":c call stack at exception time" [ :c ] (debug-help) - ":get ( var -- value ) accesses variables at time of error" print + ":help - documentation for this error" [ :help ] (debug-help) + ":s - data stack at exception time" [ :s ] (debug-help) + ":r - retain stack at exception time" [ :r ] (debug-help) + ":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 ; diff --git a/library/tools/summary.factor b/library/tools/summary.factor index 717fd9a429..1909a39200 100644 --- a/library/tools/summary.factor +++ b/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 ) diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index b50a93eb00..6059881990 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -4,13 +4,8 @@ IN: gadgets USING: generic hashtables kernel math models namespaces queues sequences words ; -: (gestures) ( gadget -- ) - [ - dup delegate (gestures) - class "gestures" word-prop [ , ] when* - ] when* ; - -: gestures ( gadget -- seq ) [ (gestures) ] { } make ; +: gestures ( gadget -- seq ) + delegates [ "gestures" word-prop ] map [ ] subset ; : set-gestures ( class hash -- ) "gestures" set-word-prop ; diff --git a/library/words.factor b/library/words.factor index 6a266cd848..d4b317dd99 100644 --- a/library/words.factor +++ b/library/words.factor @@ -139,12 +139,13 @@ SYMBOL: bootstrapping? dup word-name over word-vocabulary nest set-hash ] bind ; -: check-create ( name vocab -- ) - string? [ "Vocabulary name is not a string" throw ] unless - string? [ "Word name is not a string" throw ] unless ; +TUPLE: check-create name vocab ; +: check-create ( name vocab -- name vocab ) + dup string? [ throw ] unless + over string? [ throw ] unless ; : create ( name vocab -- word ) - 2dup check-create 2dup lookup dup + check-create 2dup lookup dup [ 2nip ] [ drop dup reveal ] if ; : constructor-word ( string vocab -- word )