New prettyprinter feature, some bug fixes

doc/handbook/math.facts

@@ -74,8 +74,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
 { $subsection shift }
 { $subsection log2 }
 { $subsection power-of-2? }
-{ $subsection next-power-of-2 }
+{ $subsection next-power-of-2 } ;
-{ $subsection each-bit } ;
 
 ARTICLE: "random-numbers" "Generating random integers"
 { $subsection (random-int) }

library/bootstrap/image.factor

@@ -187,7 +187,7 @@ M: f ' ( obj -- ptr )
 
 : transfer-word ( word -- word )
     #! This is a hack. See doc/bootstrap.txt.
-    dup target-word [ ] [ dup "Missing DEFER: " word-error ] ?if ;
+    dup target-word [ ] [ "Missing DEFER: " word-error ] ?if ;
 
 : pooled-object ( object -- ptr ) objects get hash ;
 

library/continuations.factor

@@ -17,7 +17,7 @@ USING: namespaces sequences ;
 TUPLE: continuation data retain call name catch ;
 
 : continuation ( -- interp )
-    datastack retainstack callstack dup pop* dup pop*
+    datastack retainstack callstack dup pop* dup pop* dup pop*
     namestack catchstack <continuation> ; inline
 
 : >continuation< ( continuation -- data retain call name catch )

library/errors.factor

@@ -3,10 +3,6 @@
 IN: errors
 USING: kernel kernel-internals sequences ;
 
-TUPLE: no-method object generic ;
-
-: no-method ( object generic -- ) <no-method> throw ;
-
 : >c ( continuation -- ) catchstack* push ;
 : c> ( -- continuation ) catchstack* pop ;
 

library/errors.facts

@@ -1,9 +1,5 @@
 USING: errors help kernel ;
 
-HELP: no-method "( object generic -- )"
-{ $values { "object" "an object" } { "generic" "a generic word" } }
-{ $description "Throws an error indicating that " { $snippet "object" } " does not respond to the " { $snippet "generic" } " word." } ;
-
 HELP: >c "( continuation -- )"
 { $values { "continuation" "a continuation" } }
 { $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;

library/generic/generic.facts

@@ -1,4 +1,4 @@
-USING: generic help kernel ;
+USING: generic help kernel kernel-internals ;
 
 HELP: typemap f
 { $description "Global variable. Hashtable mapping unions to class words." }

library/generic/standard-combination.factor

@@ -1,6 +1,8 @@
-IN: generic
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays errors hashtables kernel kernel-internals
 math namespaces sequences vectors words ;
+IN: generic
 
 : picker ( dispatch# -- quot )
     { [ dup ] [ over ] [ pick ] } nth ;
@@ -8,6 +10,10 @@ math namespaces sequences vectors words ;
 : unpicker ( dispatch# -- quot )
     { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } nth ;
 
+TUPLE: no-method object generic ;
+
+: no-method ( object generic -- ) <no-method> throw ;
+
 : error-method ( dispatch# word -- method )
     >r picker r> [ no-method ] curry append ;
 

library/generic/standard-combination.facts

@@ -1,5 +1,9 @@
 USING: generic help sequences ;
 
+HELP: no-method "( object generic -- )"
+{ $values { "object" "an object" } { "generic" "a generic word" } }
+{ $description "Throws an error indicating that " { $snippet "object" } " does not respond to the " { $snippet "generic" } " word." } ;
+
 HELP: standard-combination "( word dispatch# -- quot )"
 { $values { "word" "a generic word" } { "dispatch#" "a dispatch position" } { "quot" "a new quotation" } }
 { $description

library/math/pow.facts

@@ -17,10 +17,6 @@ HELP: ^ "( x y -- z )"
 { $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
 { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
 
-HELP: each-bit "( n quot -- )"
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect " { $snippet "( 0/1 -- )" } } }
-{ $description "Applies the quotation to each bit of the input, ranging from least significant to most significant." } ;
-
 HELP: power-of-2? "( n -- ? )"
 { $values { "n" "an integer" } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "n" } " is a power of 2." } ;

library/quotations.factor

@@ -30,5 +30,7 @@ M: wrapper literalize <wrapper> ;
 
 : curry ( obj quot -- quot ) >r literalize unit r> append ;
 
+: curry-each ( seq quot -- seq ) [ swap curry ] map-with ;
+
 : alist>quot ( default alist -- quot )
     [ [ first2 swap % , , \ if , ] [ ] make ] each ;

library/syntax/prettyprint.factor

@@ -21,6 +21,11 @@ SYMBOL: length-limit
 SYMBOL: line-limit
 SYMBOL: string-limit
 
+! Special trick to highlight a word in a quotation
+SYMBOL: hilite-quotation
+SYMBOL: hilite-index
+SYMBOL: hilite-now?
+
 global [
     4 tab-size set
     64 margin set
@@ -158,11 +163,8 @@ GENERIC: pprint* ( obj -- )
 : word-style ( word -- style )
     [
         dup presented set
-        parsing? [
+        parsing? [ bold font-style set ] when
-            bold font-style
+        hilite-now? get [ { 0.9 0.9 0.9 1 } background set ] when
-        ] [
-            { 0 0 0.3 1 } foreground
-        ] if set
     ] make-hash ;
 
 : pprint-word ( obj -- )
@@ -243,10 +245,16 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 : pprint-element ( object -- )
     dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
 
+: pprint-hilite ( object n -- )
+    hilite-index get = hilite-now? set
+    pprint-element hilite-now? off ;
+
 : pprint-elements ( seq -- )
-    length-limit? >r
+    length-limit? >r dup hilite-quotation get eq? [
-    [ pprint-element ] each
+        dup length [ pprint-hilite ] 2each
-    r> [ "..." plain-text ] when ;
+    ] [
+        [ pprint-element ] each
+    ] if r> [ "..." plain-text ] when ;
 
 : pprint-sequence ( seq start end -- )
     swap pprint* swap pprint-elements pprint* ;

library/syntax/see.factor

@@ -119,7 +119,3 @@ M: word class. drop ;
         methods.
         newline
     ] with-pprint ;
-
-: apropos ( substring -- )
-    all-words completions natural-sort
-    [ [ synopsis ] keep simple-object terpri ] each ;

library/tools/describe.factor

@@ -90,23 +90,31 @@ DEFER: describe
 
 : describe ( object -- ) dup summary print sheet sheet. ;
 
-: sequence-outliner ( seq quot -- | quot: obj -- )
+: sequence-outliner ( strings objects quot -- )
-    swap [
+    over curry-each 3array flip
-        [ unparse-short ] keep rot dupd curry
+    [ first3 simple-outliner terpri ] each ;
-        simple-outliner terpri
-    ] each-with ;
 
-: words. ( vocab -- )
+: unparse-outliner ( seq quot -- | quot: obj -- )
-    words natural-sort [ (help) ] sequence-outliner ;
+    >r [ [ unparse-short ] map ] keep r> sequence-outliner ;
 
-: vocabs. ( -- ) vocabs [ words. ] sequence-outliner ;
+: word-outliner ( seq quot -- )
+    >r natural-sort [ [ synopsis ] map ] keep
+    r> sequence-outliner ;
 
-: usage. ( word -- ) usage [ usage. ] sequence-outliner ;
+: words. ( vocab -- ) words [ (help) ] unparse-outliner ;
 
-: uses. ( word -- ) uses [ uses. ] sequence-outliner ;
+: vocabs. ( -- ) vocabs [ words. ] unparse-outliner ;
+
+: usage. ( word -- ) usage [ usage. ] word-outliner ;
+
+: uses. ( word -- ) uses [ uses. ] word-outliner ;
 
 : stack. ( seq -- seq ) <reversed> >array describe ;
 
 : .s datastack stack. ;
 : .r retainstack stack. ;
 : .c callstack stack. ;
+
+: apropos ( substring -- )
+    all-words completions natural-sort
+    [ (help) ] word-outliner ;

native/run.c

@@ -42,8 +42,6 @@ void handle_error(void)
 		else
 			fix_stacks();
 
-		callframe_scan = callframe_end = 0;
-
 		dpush(thrown_error);
 		/* Notify any 'catch' blocks */
 		call(userenv[BREAK_ENV]);