getting more words to infer

library/compiler/compiler.factor

@@ -26,7 +26,7 @@ words ;
     "compile" get [ word compile ] when ; parsing
 
 : try-compile ( word -- )
-    [ compile ] catch [ error. drop ] when* ;
+    [ compile ] [ error. drop ] recover ;
 
 : compile-all ( -- ) [ try-compile ] each-word ;
 

library/compiler/generator.factor

@@ -36,10 +36,10 @@ SYMBOL: previous-offset
     [
         compiled-offset previous-offset set
         (generate)
-    ] catch [
+    ] [
         previous-offset get set-compiled-offset
         rethrow
-    ] when* ;
+    ] recover ;
 
 ! A few VOPs have trivial generators.
 

library/errors.factor

@@ -28,14 +28,25 @@ TUPLE: no-method object generic ;
 
 : rethrow ( error -- )
     #! Use rethrow when passing an error on from a catch block.
-    catchstack empty? [ die ] [ c> continue-with ] ifte ;
+    catchstack empty? [
+        die "Can't happen" throw
+    ] [
+        c> continue-with
+    ] ifte ;
 
 : cleanup ( try cleanup -- | try: -- | cleanup: -- )
     #! Call the try quotation. If an exception is thrown in the
     #! dynamic extent of the quotation, restore the datastack
     #! and run the cleanup quotation. Then throw the error to
     #! the next outermost catch handler.
-    >r [ call ] catch r> swap slip
+    >r [ dup slip ] catch nip r>
-    [ nip rethrow ] when* ; inline
+    swap slip [ rethrow ] when* ; inline
+
+: recover ( try recovery -- | try: -- | recovery: -- )
+    #! Call the try quotation. If an exception is thrown in the
+    #! dynamic extent of the quotation, restore the datastack,
+    #! push the exception on the datastack, and call the
+    #! recovery quotation.
+    >r catch r> when* ; inline
 
 GENERIC: error. ( error -- )

library/httpd/http-common.factor

@@ -24,7 +24,7 @@ io strings ;
         ] each
     ] "" make ;
 
-: catch-hex> ( str -- n )
+: catch-hex> ( str -- n/f )
     #! Push f if string is not a valid hex literal.
     [ hex> ] catch [ drop f ] when ;
 

library/inference/known-words.factor

@@ -524,3 +524,5 @@ prettyprint ;
 \ set-c-stack [
     "set-c-stack cannot be compiled (yet)" throw
 ] "infer" set-word-prop
+
+\ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop

library/inference/words.factor

@@ -64,9 +64,9 @@ M: compound apply-word ( word -- )
         dup dup f infer-compound
         >r "terminates" set-word-prop r>
         "infer-effect" set-word-prop
-    ] catch [
+    ] [
         swap t "no-effect" set-word-prop rethrow
-    ] when* ;
+    ] recover ;
 
 : apply-default ( word -- )
     dup "no-effect" word-prop [

library/io/stdio.factor

@@ -19,11 +19,12 @@ USING: errors generic kernel lists namespaces strings styles ;
 
 : with-stream ( stream quot -- )
     #! Close the stream no matter what happens.
-    [ swap stdio set [ close ] cleanup ] with-scope ;
+    [ swap stdio set [ close ] cleanup ] with-scope ; inline
 
 : with-stream* ( stream quot -- )
     #! Close the stream if there is an error.
-    [ swap stdio set catch [ close rethrow ] when* ] with-scope ;
+    [ swap stdio set [ close rethrow ] recover ] with-scope ;
+    inline
 
 : contents ( stream -- string )
     #! Read the entire stream into a string.

library/io/string-streams.factor

@@ -12,6 +12,7 @@ M: sbuf stream-finish drop ;
 
 : string-out ( quot -- str )
     [ 512 <sbuf> stdio set call stdio get >string ] with-scope ;
+    inline
 
 ! Reversed string buffers support the stream input protocol.
 M: sbuf stream-read1 ( sbuf -- char/f )
@@ -29,4 +30,4 @@ M: sbuf stream-read ( count sbuf -- string )
     <reversed> >sbuf <line-reader> ;
 
 : string-in ( str quot -- )
-    [ swap <string-reader> stdio set call ] with-scope ;
+    [ swap <string-reader> stdio set call ] with-scope ; inline

library/syntax/parse-errors.factor

@@ -9,4 +9,4 @@ TUPLE: parse-error file line col text ;
     file get line-number get "col" get "line" get
     <parse-error> [ set-delegate ] keep throw ;
 
-: with-parser ( quot -- ) catch [ parse-error ] when* ;
+: with-parser ( quot -- ) [ parse-error ] recover ;

library/syntax/prettyprint.factor

@@ -226,9 +226,9 @@ M: string pprint* ( str -- str ) "\"" pprint-string ;
 M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
 
 M: word pprint* ( word -- )
-    dup "pprint-before-hook" word-prop call
+    dup "pprint-open" word-prop [ <block ] when
     dup pprint-word
-    "pprint-after-hook" word-prop call ;
+    "pprint-after-hook" word-prop [ block> ] when ;
 
 M: f pprint* drop "f" f text ;
 
@@ -349,12 +349,12 @@ M: wrapper pprint* ( wrapper -- )
 : define-open
     #! The word will be pretty-printed as a block opener.
     #! Examples are [ { {{ [[ << and so on.
-    [ <block ] "pprint-after-hook" set-word-prop ;
+    t "pprint-open" set-word-prop ;
 
 : define-close ( word -- )
     #! The word will be pretty-printed as a block closer.
     #! Examples are ] } }} ]] >> and so on.
-    [ block> ] "pprint-before-hook" set-word-prop ;
+    t "pprint-close" set-word-prop ;
 
 {
     { POSTPONE: [ POSTPONE: ] }

library/tools/debugger.factor

@@ -47,24 +47,22 @@ parser prettyprint sequences io strings vectors words ;
 PREDICATE: cons kernel-error ( obj -- ? )
     car kernel-error = ;
 
-M: f error. ( f -- ) drop ;
-
 M: kernel-error error. ( error -- )
     #! Kernel errors are indexed by integers.
     cdr uncons car swap {
-        expired-error.
+        [ expired-error. ]
-        io-error.
+        [ io-error. ]
-        undefined-word-error.
+        [ undefined-word-error. ]
-        type-check-error.
+        [ type-check-error. ]
-        float-format-error.
+        [ float-format-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. ]
-    } nth execute ;
+    } dispatch ;
 
 M: no-method error. ( error -- )
     "No suitable method." print
@@ -116,12 +114,12 @@ M: object error. ( error -- ) . ;
 
 : print-error ( error -- )
     #! Print the error.
-    [ error. ] catch flush-error-handler ;
+    [ dup error. ] catch nip flush-error-handler ;
 
 : try ( quot -- )
     #! Execute a quotation, and if it throws an error, print it
     #! and return to the caller.
-    catch [ print-error debug-help ] when* ;
+    [ print-error debug-help ] recover ;
 
 : save-error ( error ds rs ns cs -- )
     #! Save the stacks and parser state for post-mortem

library/tools/inspector.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inspector
-USING: arrays generic hashtables io kernel listener
+USING: arrays generic hashtables io kernel kernel-internals
-lists math memory namespaces prettyprint sequences
+listener lists math memory namespaces prettyprint sequences
 strings styles test vectors words ;
 
 GENERIC: sheet ( obj -- sheet )
 
 M: object sheet ( obj -- sheet )
     dup class "slots" word-prop
-    [ second ] map
+    dup [ second ] map -rot
-    tuck [ execute ] map-with
+    [ first slot ] map-with
     2array ;
 
 M: list sheet 1array ;
@@ -23,7 +23,7 @@ M: hashtable sheet dup hash-keys swap hash-values 2array ;
 
 : format-column ( list -- list )
     [ unparse-short ] map
-    [ 0 [ length ] reduce ] keep
+    [ 0 [ length max ] reduce ] keep
     [ swap CHAR: \s pad-right ] map-with ;
 
 : sheet-numbers ( sheet -- sheet )

library/tools/memory.factor

@@ -44,12 +44,14 @@ sequences strings unparser vectors words ;
 
 : each-object ( quot -- )
     #! Applies the quotation to each object in the image.
-    [ begin-scan (each-object) ] [ end-scan ] cleanup ; inline
+    [ begin-scan [ (each-object) ] keep ]
+    [ end-scan ] cleanup drop ; inline
 
 : instances ( quot -- list )
     #! Return a list of all object that return true when the
     #! quotation is applied to them.
     [ [ [ swap call ] 2keep rot ?, ] each-object drop ] [ ] make ;
+    inline
 
 G: each-slot ( obj quot -- )
     [ over ] standard-combination ; inline