various cleanups, code primitive now shows code space usage, :get and &get, working on inferencer

examples/dejong.factor

@@ -5,7 +5,7 @@
 !
 ! Then, enter this at the interpreter prompt:
 !
-! "contrib/dejong.factor" run-file
+! "examples/dejong.factor" run-file
 
 ! For details on DeJong attractors, see
 ! http://www.complexification.net/gallery/machines/peterdejong/

examples/mandel.factor

@@ -5,7 +5,7 @@
 !
 ! Then, enter this at the interpreter prompt:
 !
-! "contrib/mandel.factor" run-file
+! "examples/mandel.factor" run-file
 
 IN: mandel
 

factor/FactorArray.java

@@ -33,7 +33,7 @@ package factor;
  * A growable array.
  * @author Slava Pestov
  */
-public class FactorArray implements FactorExternalizable, PublicCloneable
+public class FactorArray implements FactorExternalizable
 {
 	public Object[] array;
 	public int top;

factor/jedit/FactorPlugin.props

@@ -47,7 +47,7 @@ factor.completion.colon=: <b>{0}</b>
 factor.completion.defer=DEFER: <b>{0}</b>
 factor.completion.parsing=PARSING: <b>{0}</b>
 factor.completion.symbol=SYMBOL: <b>{0}</b>
-factor.completion.stack={0} ({1})
+factor.completion.stack={0} ( {1})
 
 # Dialog boxes
 factor.status.inserted-use=Inserted {0}

factor/jedit/FactorShell.java

@@ -220,10 +220,16 @@ public class FactorShell extends Shell
 
 			openStream(output);
 
-			FactorStream.Packet p;
+			for(;;)
-			while((p = stream.nextPacket()) != null)
 			{
-				if(p instanceof FactorStream.ReadLinePacket)
+				FactorStream.Packet p = stream.nextPacket();
+				if(p == null)
+				{
+					/* EOF */
+					closeStream();
+					break;
+				}
+				else if(p instanceof FactorStream.ReadLinePacket)
 				{
 					waitingForInput = true;
 					break;

factor/jedit/FactorSideKickParser.java

@@ -110,7 +110,14 @@ public class FactorSideKickParser extends SideKickParser
 			buffer.readLock();
 
 			text = buffer.getText(0,buffer.getLength());
+		}
+		finally
+		{
+			buffer.readUnlock();
+		}
 
+		try
+		{
 			/* of course wrapping a string reader in a buffered
 			reader is dumb, but the FactorReader uses readLine() */
 			FactorScanner scanner = new RestartableFactorScanner(
@@ -119,12 +126,12 @@ public class FactorSideKickParser extends SideKickParser
 				errorSource);
 			FactorReader r = new FactorReader(scanner,
 				false,FactorPlugin.getExternalInstance());
-
+	
 			Cons parsed = r.parse();
-
+	
 			d.in = r.getIn();
 			d.use = r.getUse();
-
+	
 			addWordDefNodes(d,parsed,buffer);
 		}
 		catch(FactorParseException pe)
@@ -140,10 +147,6 @@ public class FactorSideKickParser extends SideKickParser
 				0,0,0,e.toString());
 			Log.log(Log.DEBUG,this,e);
 		}
-		finally
-		{
-			buffer.readUnlock();
-		}
 
 		return d;
 	} //}}}

factor/jedit/FactorWordRenderer.java

@@ -81,7 +81,7 @@ public class FactorWordRenderer extends DefaultListCellRenderer
 			new Object[] { MiscUtilities.charsToEntities(word.name) });
 		if(word.stackEffect != null)
 		{
-			html += jEdit.getProperty("factor.completion.stack",
+			html = jEdit.getProperty("factor.completion.stack",
 				new String[] { html, word.stackEffect });
 		}
 

factor/jedit/WordPreview.java

@@ -74,63 +74,72 @@ public class WordPreview implements ActionListener, CaretListener
 	//{{{ public void actionPerformed() method
 	public void actionPerformed(ActionEvent evt)
 	{
-		showPreview();
+		try
+		{
+			showPreview();
+		}
+		catch(IOException e)
+		{
+			throw new RuntimeException(e);
+		}
 	} //}}}
 	
+	//{{{ getWordAtCaret() method
+	private FactorWord getWordAtCaret(FactorParsedData fdata)
+		throws IOException
+	{
+		int line = textArea.getCaretLine();
+		int caret = textArea.getCaretPosition();
+
+		DefaultTokenHandler h = new DefaultTokenHandler();
+		textArea.getBuffer().markTokens(line,h);
+		Token tokens = h.getTokens();
+
+		int offset = caret - textArea.getLineStartOffset(line);
+
+		int len = textArea.getLineLength(line);
+		if(len == 0)
+			return null;
+
+		if(offset == len)
+			offset--;
+
+		Token token = TextUtilities.getTokenAtOffset(tokens,offset);
+
+		String name = token.rules.getName();
+
+		for(int i = 0; i < IGNORED_RULESETS.length; i++)
+		{
+			if(name.equals(IGNORED_RULESETS[i]))
+				return null;
+		}
+
+		String word = FactorPlugin.getWordAtCaret(textArea);
+		if(word == null)
+			return null;
+
+		return FactorPlugin.getExternalInstance()
+			.searchVocabulary(fdata.use,word);
+	} //}}}
+
 	//{{{ showPreview() method
 	private void showPreview()
+		throws IOException
 	{
 		View view = textArea.getView();
 
+		if(SideKickPlugin.isParsingBuffer(view.getBuffer()))
+			return;
+
 		SideKickParsedData data = SideKickParsedData.getParsedData(view);
 		if(data instanceof FactorParsedData)
 		{
-			int line = textArea.getCaretLine();
+			FactorWord w = getWordAtCaret((FactorParsedData)data);
-			int caret = textArea.getCaretPosition();
+			if(w != null)
-
-			DefaultTokenHandler h = new DefaultTokenHandler();
-			textArea.getBuffer().markTokens(line,h);
-			Token tokens = h.getTokens();
-
-			int offset = caret - textArea.getLineStartOffset(line);
-
-			int len = textArea.getLineLength(line);
-			if(len == 0)
-				return;
-
-			if(offset == len)
-				offset--;
-
-			Token token = TextUtilities.getTokenAtOffset(tokens,offset);
-
-			String name = token.rules.getName();
-
-			for(int i = 0; i < IGNORED_RULESETS.length; i++)
 			{
-				if(name.equals(IGNORED_RULESETS[i]))
+				view.getStatus().setMessageAndClear(
-					return;
+					FactorWordRenderer.getWordHTMLString(
-			}
+					w,true));
-
-			String word = FactorPlugin.getWordAtCaret(textArea);
-			if(word == null)
-				return;
-
-			FactorParsedData fdata = (FactorParsedData)data;
-
-			try
-			{
-				FactorWord w = FactorPlugin.getExternalInstance()
-					.searchVocabulary(fdata.use,word);
-				if(w != null)
-				{
-					view.getStatus().setMessageAndClear(
-						FactorWordRenderer.getWordHTMLString(
-						w,true));
-				}
-			}
-			catch(IOException e)
-			{
-				throw new RuntimeException(e);
 			}
 		}
 	} //}}}

library/compiler/alien-types.factor

@@ -101,7 +101,7 @@ USE: words
     #! Define inline and pointer type for the struct. Pointer
     #! type is exactly like void*.
     [ "width" set ] "struct-name" get define-c-type
-    "void*" c-type "struct-name" get "*" cat2 c-types set* ;
+    "void*" c-type "struct-name" get "*" cat2 c-types set-hash ;
 
 : BEGIN-STRUCT: ( -- offset )
     scan "struct-name" set  0 ; parsing

library/files.factor

@@ -27,6 +27,7 @@
 
 IN: files
 USE: combinators
+USE: hashtables
 USE: lists
 USE: logic
 USE: namespaces
@@ -44,10 +45,10 @@ USE: strings
     ] ;
 
 : set-mime-types ( assoc -- )
-    "mime-types" global set* ;
+    "mime-types" global set-hash ;
 
 : mime-types ( -- assoc )
-    "mime-types" global get* ;
+    "mime-types" global hash ;
 
 : file-extension ( filename -- extension )
     "." split cdr dup [ last ] when ;

library/httpd/resource-responder.factor

@@ -51,7 +51,7 @@ USE: strings
     ] ifte ;
 
 : resource-responder ( filename -- )
-    java? "resource-path" get or [
+    "resource-path" get [
         serve-resource
     ] [
         drop "404 resource-path not set" httpd-error

library/httpd/responder.factor

@@ -28,6 +28,7 @@
 IN: httpd-responder
 
 USE: combinators
+USE: hashtables
 USE: httpd
 USE: kernel
 USE: lists
@@ -72,15 +73,15 @@ USE: strings
     ] extend ;
 
 : get-responder ( name -- responder )
-    "httpd-responders" get get* [
+    "httpd-responders" get hash [
-        "404" "httpd-responders" get get*
+        "404" "httpd-responders" get hash
     ] unless* ;
 
 : default-responder ( -- responder )
     "default" get-responder ;
 
 : set-default-responder ( name -- )
-    get-responder "default" "httpd-responders" get set* ;
+    get-responder "default" "httpd-responders" get set-hash ;
 
 : responder-argument ( argument -- argument )
     dup f-or-"" [ drop "default-argument" get ] when ;
@@ -121,4 +122,4 @@ USE: strings
 
 : add-responder ( responder -- )
     #! Add a responder object to the list.
-    "responder" over get*  "httpd-responders" get set* ;
+    "responder" over hash  "httpd-responders" get set-hash ;

library/logging.factor

@@ -27,8 +27,9 @@
 
 IN: logging
 
-USE: namespaces
 USE: combinators
+USE: hashtables
+USE: namespaces
 USE: stack
 USE: streams
 USE: strings
@@ -43,7 +44,7 @@ USE: unparser
 : log-client ( -- )
     "client" get [
         "Accepted connection from " swap
-        "client" swap get* cat2 log
+        "client" swap hash cat2 log
     ] when* ;
 
 : with-logging ( quot -- )

library/math/arithmetic.factor

@@ -57,7 +57,7 @@ USE: stack
     #! by swapping them.
     2dup > [ swap ] when  >r dupd max r> min = ;
 
-: sq dup * ; inline
+: sq dup * ; inline recursive-infer
 
 : pred 1 - ; inline
 : succ 1 + ; inline

library/namespaces.factor

@@ -27,6 +27,7 @@
 
 IN: namespaces
 USE: combinators
+USE: hashtables
 USE: kernel
 USE: lists
 USE: logic
@@ -55,7 +56,7 @@ USE: vectors
 
 : namespace ( -- namespace )
     #! Push the current namespace.
-    namestack* vector-peek ; inline
+    namestack car ; inline
 
 : with-scope ( quot -- )
     #! Execute a quotation with a new namespace on the
@@ -76,7 +77,7 @@ USE: vectors
     over get [ drop get ] [ swap >r call dup r> set ] ifte ;
 
 : traverse-path ( name object -- object )
-    dup has-namespace? [ get* ] [ 2drop f ] ifte ;
+    dup hashtable? [ hash ] [ 2drop f ] ifte ;
 
 : (object-path) ( object list -- object )
     [ uncons >r swap traverse-path r> (object-path) ] when* ;
@@ -88,7 +89,7 @@ USE: vectors
     namespace swap (object-path) ;
 
 : (set-object-path) ( name -- namespace )
-    dup namespace get* dup [
+    dup namespace hash dup [
         nip
     ] [
         drop <namespace> tuck put

library/platform/native/boot.factor

@@ -35,7 +35,6 @@ primitives,
     "/library/platform/native/stack.factor"
     "/library/platform/native/types.factor"
     "/library/math/math.factor"
-    "/library/platform/native/math.factor"
     "/library/cons.factor"
     "/library/combinators.factor"
     "/library/logic.factor"
@@ -70,6 +69,7 @@ primitives,
     "/library/platform/native/parser.factor"
     "/library/platform/native/parse-syntax.factor"
     "/library/platform/native/parse-stream.factor"
+    "/library/platform/native/math.factor"
     "/library/platform/native/init.factor"
 ] [
     cross-compile-resource

library/platform/native/kernel.factor

@@ -109,9 +109,3 @@ IN: kernel
 : set-boot ( quot -- )
     #! Set the boot quotation.
     8 setenv ;
-
-: java? f ;
-: native? t ;
-
-! No compiler...
-: inline ;

library/platform/native/namespaces.factor

@@ -37,26 +37,22 @@ USE: vectors
 
 DEFER: namespace
 
-: namestack* ( -- ns ) 3 getenv ;
+: namestack ( -- ns ) 3 getenv ;
-: set-namestack* ( ns -- ) 3 setenv ;
+: set-namestack ( ns -- ) 3 setenv ;
 
 : >n ( namespace -- n:namespace )
     #! Push a namespace on the namespace stack.
-    namestack* vector-push ; inline
+    namestack cons set-namestack ; inline
 
 : n> ( n:namespace -- namespace )
     #! Pop the top of the namespace stack.
-    namestack* vector-pop ; inline
+    namestack uncons set-namestack ; inline
-
-: namestack ( -- stack ) namestack* vector-clone ;
-: set-namestack ( stack -- ) vector-clone set-namestack* ;
 
 : global ( -- g ) 4 getenv ;
 : set-global ( g -- ) 4 setenv ;
 
 : init-namespaces ( -- )
-    64 <vector> set-namestack* global >n
+    global >n  global "global" set ;
-    global "global" set ;
 
 : namespace-buckets 23 ;
 
@@ -64,25 +60,22 @@ DEFER: namespace
     #! Create a new namespace.
     namespace-buckets <hashtable> ;
 
-: get* ( var namespace -- value ) hash ;
+: (get) ( var ns -- value )
-: set* ( value variable namespace -- ) set-hash ;
-
-: namestack-search ( var n -- )
     #! Internal word for searching the namestack.
-    dup 0 eq? [
+    dup [
-        2drop f ( not found )
+        2dup car hash* dup [
-    ] [
+            nip nip cdr ( found )
-        pred 2dup >r >r namestack* vector-nth hash* dup [
-            r> drop r> drop ( [ key | value ] -- ) cdr ( found )
         ] [
-            drop r> r> namestack-search ( check next entry )
+            drop cdr (get) ( keep looking )
         ] ifte
+    ] [
+        2drop f
     ] ifte ;
 
 : get ( variable -- value )
     #! Push the value of a variable by searching the namestack
     #! from the top down.
-    namestack* vector-length namestack-search ;
+    namestack (get) ;
 
 : set ( value variable -- ) namespace set-hash ;
 : put ( variable value -- ) swap set ;
@@ -90,10 +83,3 @@ DEFER: namespace
 : bind ( namespace quot -- )
     #! Execute a quotation with a namespace on the namestack.
     swap >n call n> drop ; inline
-
-: vars-values ( -- list ) namespace hash>alist ;
-: vars ( -- list ) namespace hash-keys ;
-: values ( -- list ) namespace hash-values ;
-
-! We don't have bound objects in native Factor.
-: has-namespace? hashtable? ;

library/platform/native/parse-syntax.factor

@@ -35,7 +35,6 @@ USE: lists
 USE: logic
 USE: math
 USE: namespaces
-USE: parser
 USE: stack
 USE: strings
 USE: words
@@ -114,6 +113,14 @@ USE: unparser
 
 IN: syntax
 
+: recursive-infer ( -- )
+    #! Mark the last word to be recursively inferred (eg, cond).
+    word  t "recursive-infer" set-word-property ; parsing
+
+: inline ( -- )
+    #! Mark the last word to be inlined.
+    word  t "inline" set-word-property ; parsing
+
 ! The variable "in-definition" is set inside a : ... ;.
 ! ( and #! then add "stack-effect" and "documentation"
 ! properties to the current word if it is set.

library/platform/native/parser.factor

@@ -55,12 +55,6 @@ USE: unparser
         drop f
     ] ifte ;
 
-: parsing ( -- )
-    #! Mark the most recently defined word to execute at parse
-    #! time, rather than run time. The word can use 'scan' to
-    #! read ahead in the input stream.
-    word t "parsing" set-word-property ;
-
 : end? ( -- ? )
     "col" get "line" get str-length >= ;
 
@@ -188,6 +182,14 @@ USE: unparser
 : next-word-ch ( -- ch )
     "col" get "line" get skip-blank "col" set next-ch ;
 
+IN: syntax
+
+: parsing ( -- )
+    #! Mark the most recently defined word to execute at parse
+    #! time, rather than run time. The word can use 'scan' to
+    #! read ahead in the input stream.
+    word t "parsing" set-word-property ;
+
 ! Once this file has loaded, we can use 'parsing' normally.
 ! This hack is needed because in Java Factor, 'parsing' is
 ! not parsing, but in CFactor, it is.

library/platform/native/primitives.factor

@@ -194,7 +194,7 @@ USE: words
     [ add-copy-io-task       " from to callback -- "              [ 3 | 1 ] ]
     [ pending-io-error       " -- "                               [ 0 | 0 ] ]
     [ next-io-task           " -- callback "                      [ 0 | 1 ] ]
-    [ room                   " -- free total "                    [ 0 | 2 ] ]
+    [ room                   " -- free total free total "         [ 0 | 4 ] ]
     [ os-env                 " str -- str "                       [ 1 | 1 ] ]
     [ millis                 " -- n "                             [ 0 | 1 ] ]
     [ init-random            " -- "                               [ 0 | 0 ] ]

library/presentation.factor

@@ -27,6 +27,7 @@
 
 IN: presentation
 USE: combinators
+USE: hashtables
 USE: kernel
 USE: lists
 USE: namespaces
@@ -44,10 +45,10 @@ USE: unparser
 ! significance to the 'fwrite-attr' word when applied to a
 ! stream that supports attributed string output.
 
-: (style) ( name -- style ) "styles" get get* ;
+: (style) ( name -- style ) "styles" get hash ;
 : default-style ( -- style ) "default" (style) ;
 : style ( name -- style ) (style) [ default-style ] unless* ;
-: set-style ( style name -- ) "styles" get set* ;
+: set-style ( style name -- ) "styles" get set-hash ;
 
 <namespace> "styles" set
 

library/prettyprint.factor

@@ -225,9 +225,9 @@ DEFER: prettyprint*
 
 : {.} ( vector -- )
     #! Unparse each element on its own line.
-    [ . ] vector-each ;
+    stack>list [ . ] each ;
 
-: .n namestack  {.} ;
+: .n namestack  [.] ;
 : .s datastack  {.} ;
 : .r callstack  {.} ;
 : .c catchstack {.} ;

library/test/hashtables.factor

@@ -34,8 +34,6 @@ unit-test
 [ t ] [ [ f | t ] hashcode [ f | t ] hashcode = ] unit-test
 [ t ] [ [ 1 [ 2 3 ] 4 ] hashcode [ 1 [ 2 3 ] 4 ] hashcode = ] unit-test
 
-native? [
+[ t ] [ 12 hashcode 12 hashcode = ] unit-test
-    [ t ] [ 12 hashcode 12 hashcode = ] unit-test
+[ t ] [ 12 >bignum hashcode 12 hashcode = ] unit-test
-    [ t ] [ 12 >bignum hashcode 12 hashcode = ] unit-test
+[ t ] [ 12.0 hashcode 12 >bignum hashcode = ] unit-test
-    [ t ] [ 12.0 hashcode 12 >bignum hashcode = ] unit-test
-] when

library/test/inference.factor

@@ -7,7 +7,24 @@ USE: combinators
 USE: vectors
 USE: kernel
 USE: lists
+USE: namespaces
 
+[
+    [ 1 | 2 ]
+    [ 2 | 1 ]
+    [ 0 | 3 ]
+    [ 4 | 2 ]
+    [ 3 | 3 ]
+    [ 0 | 0 ]
+    [ 1 | 5 ]
+    [ 3 | 4 ]
+] "effects" set
+
+[ t ] [
+    "effects" get [
+        dup [ 7 | 7 ] decompose compose [ 7 | 7 ] =
+    ] all?
+] unit-test
 [ 6 ] [ 6 gensym-vector vector-length ] unit-test
 
 [ 3 ] [ [ { 1 2 } { 1 2 3 } ] max-vector-length ] unit-test
@@ -122,5 +139,12 @@ DEFER: foe
 ! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
 ! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
 
+[ [ 2 | 1 ] ] [ [ bitor ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ bitand ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ bitxor ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ mod ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ /i ] infer ] unit-test
+[ [ 2 | 1 ] ] [ [ /f ] infer ] unit-test
+[ [ 2 | 2 ] ] [ [ /mod ] infer ] unit-test
+
 [ [ 2 | 1 ] ] [ [ number= ] infer ] unit-test

library/test/words.factor

@@ -52,3 +52,6 @@ word word-name "last-word-test" set
 [ "test-scope" ] [
     "test-scope" [ "scratchpad" ] search word-name
 ] unit-test
+
+[ t ] [ vocabs list? ] unit-test
+[ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test

library/tools/debugger.factor

@@ -55,15 +55,13 @@ USE: unparser
 : in-parser? ( -- ? )
     "error-line" get "error-col" get and ;
 
-: error-handler-hook
-    #! The game overrides this.
-    ;
-
 : :s ( -- ) "error-datastack"  get {.} ;
 : :r ( -- ) "error-callstack"  get {.} ;
-: :n ( -- ) "error-namestack"  get {.} ;
+: :n ( -- ) "error-namestack"  get [.] ;
 : :c ( -- ) "error-catchstack" get {.} ;
 
+: :get ( var -- value ) "error-namestack" get (get) ;
+
 : default-error-handler ( error -- )
     #! Print the error and return to the top level.
     [
@@ -71,8 +69,6 @@ USE: unparser
 
         [ :s :r :n :c ] [ prettyprint-word " " write ] each
         "show stacks at time of error." print
-
+        \ :get prettyprint-word
-        java? [ ":j shows Java stack trace." print ] when
+        " ( var -- value ) inspects the error namestack." print
-        error-handler-hook
-
     ] when* ;

library/tools/inference.factor

@@ -46,13 +46,20 @@ USE: hashtables
 ! - meta-infer -- evaluate word in meta-interpreter if set.
 ! - infer - quotation with custom inference behavior; ifte uses
 ! this. Word is passed on the stack.
+! - recursive-infer - if true, inferencer will always invoke
+! itself recursively with this word, instead of solving a
+! fixed-point equation for recursive calls.
 
 ! Amount of results we had to add to the datastack
 SYMBOL: d-in
 ! Amount of results we had to add to the callstack
 SYMBOL: r-in
-! Recursive state. Alist maps words to base case effects
+
+! Recursive state. Alist maps words to hashmaps...
 SYMBOL: recursive-state
+! ... with keys:
+SYMBOL: base-case
+SYMBOL: entry-effect
 
 : gensym-vector ( n --  vector )
     dup <vector> swap [ gensym over vector-push ] times ;
@@ -108,10 +115,23 @@ SYMBOL: recursive-state
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 throw ;
 
+: (effect) ( -- [ in | stack ] )
+    d-in get  meta-d get cons ;
+
+: effect ( -- [ in | out ] )
+    #! After inference is finished, collect information.
+    d-in get  meta-d get vector-length cons ;
+
+: <recursive-state> ( -- state )
+    <namespace> [
+        base-case off  effect entry-effect set
+    ] extend ;
+
 DEFER: (infer)
 
 : apply-compound ( word -- )
-    t over recursive-state acons@
+    #! Infer a compound word's stack effect.
+    dup <recursive-state> cons recursive-state cons@
     word-parameter (infer)
     recursive-state uncons@ drop ;
 
@@ -127,9 +147,12 @@ DEFER: (infer)
     #! Push word we're currently inferring effect of.
     recursive-state get car car ;
 
-: no-base-case ( -- )
+: current-state ( -- word )
-    current-word word-name
+    #! Push word we're currently inferring effect of.
-    " does not have a base case." cat2 throw ;
+    recursive-state get car cdr ;
+
+: no-base-case ( word -- )
+    word-name " does not have a base case." cat2 throw ;
 
 : check-recursion ( -- )
     #! If at the location of the recursive call, we're taking
@@ -139,19 +162,33 @@ DEFER: (infer)
         current-word word-name " diverges." cat2 throw
     ] when ;
 
-: recursive-word ( word effect -- )
+: recursive-word ( word state -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error.
-    dup t = [ drop no-base-case ] [ nip consume/produce ] ifte ;
+    base-case swap hash dup [
+        nip consume/produce
+    ] [
+        drop no-base-case
+    ] ifte ;
 
 : apply-object ( obj -- )
     #! Apply the object's stack effect to the inferencer state.
+    #! There are three options: recursive-infer words always
+    #! cause a recursive call of the inferencer, regardless.
+    #! Be careful, you might hang the inferencer. Other words
+    #! solve a fixed-point equation if a recursive call is made,
+    #! otherwise the inferencer is invoked recursively if its
+    #! not a recursive call.
     dup word? [
-        dup recursive-state get assoc [
+        dup "recursive-infer" word-property [
-            check-recursion recursive-word
-        ] [
             apply-word
-        ] ifte*
+        ] [
+            dup recursive-state get assoc dup [
+                check-recursion recursive-word
+            ] [
+                drop apply-word
+            ] ifte
+        ] ifte
     ] [
         push-d
     ] ifte ;
@@ -162,10 +199,6 @@ DEFER: (infer)
     0 r-in set
     f recursive-state set ;
 
-: effect ( -- [ in | out ] )
-    #! After inference is finished, collect information.
-    d-in get meta-d get vector-length cons ;
-
 : (infer) ( quot -- )
     #! Recursive calls to this word are made for nested
     #! quotations.
@@ -174,10 +207,7 @@ DEFER: (infer)
 : infer-branch ( quot -- [ in-d | datastack ] )
     #! Infer the quotation's effect, restoring the meta
     #! interpreter state afterwards.
-    [
+    [ copy-interpreter (infer) (effect) ] with-scope ;
-        copy-interpreter (infer)
-        d-in get  meta-d get cons
-    ] with-scope ;
 
 : difference ( [ in | stack ] -- diff )
     #! Stack height difference of infer-branch return value.
@@ -216,14 +246,26 @@ DEFER: (infer)
         "Unbalanced branches" throw
     ] ifte ;
 
+: compose ( first second -- total )
+    #! Stack effect composition.
+    >r uncons r> uncons >r -
+    dup 0 < [ neg + r> cons ] [ r> + cons ] ifte ;
+
+: decompose ( first second -- solution )
+    #! Return a stack effect such that first*solution = second.
+    2dup 2car
+    2dup > [ "No solution to decomposition" throw ] when
+    swap - -rot 2cdr >r + r> cons ;
+
 : set-base ( [ in | stack ] -- )
     #! Set the base case of the current word.
-    recursive-state uncons@ car >r
+    uncons vector-length cons
-    uncons vector-length cons r>
+    current-state [
-    recursive-state acons@ ;
+        entry-effect get swap decompose base-case set
+    ] bind ;
 
 : recursive-branch ( quot -- )
-    #! Set base case if inference didn't fail.
+    #! Set base case if inference didn't fail
     [ infer-branch set-base ] [ [ drop ] when ] catch ;
 
 : infer-branches ( brachlist -- )

library/tools/inspector.factor

@@ -46,7 +46,7 @@ USE: vectors
 
 : vars. ( -- )
     #! Print a list of defined variables.
-    vars [ print ] each ;
+    namespace hash-keys [.] ;
 
 : object-actions ( -- alist )
     [
@@ -82,9 +82,6 @@ USE: vectors
 : alist-sort ( list -- list )
     [ swap car unparse swap car unparse str-lexi> ] sort ;
 
-: describe-namespace ( namespace -- )
-    [ vars-values ] bind alist-sort describe-assoc ;
-
 : describe-hashtable ( hashtables -- )
     hash>alist alist-sort describe-assoc ;
 
@@ -99,9 +96,6 @@ USE: vectors
         [ assoc? ]
         [ describe-assoc ]
         
-        [ has-namespace? ]
-        [ describe-namespace ]
-        
         [ hashtable? ]
         [ describe-hashtable ]
         

library/tools/interpreter.factor

@@ -60,16 +60,16 @@ SYMBOL: meta-cf
 : init-interpreter ( -- )
     10 <vector> meta-r set
     10 <vector> meta-d set
-    10 <vector> meta-n set
+    f meta-n set
-    10 <vector> meta-c set
+    f meta-c set
     f meta-cf set ;
 
 : copy-interpreter ( -- )
     #! Copy interpreter state from containing namespaces.
     meta-r get vector-clone meta-r set
     meta-d get vector-clone meta-d set
-    meta-n get vector-clone meta-n set
+    meta-n get meta-n set
-    meta-c get vector-clone meta-c set ;
+    meta-c get meta-c set ;
 
 : done-cf? ( -- ? )
     meta-cf get not ;
@@ -135,10 +135,10 @@ SYMBOL: meta-cf
 \ r>   [ pop-r push-d ] set-meta-word
 \ callstack [ meta-r get vector-clone push-d ] set-meta-word
 \ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word
-\ namestack* [ meta-n get push-d ] set-meta-word
+\ namestack [ meta-n get push-d ] set-meta-word
-\ set-namestack* [ pop-d meta-n set ] set-meta-word
+\ set-namestack [ pop-d meta-n set ] set-meta-word
-\ catchstack* [ meta-c get push-d ] set-meta-word
+\ catchstack [ meta-c get push-d ] set-meta-word
-\ set-catchstack* [ pop-d meta-c set ] set-meta-word
+\ set-catchstack [ pop-d meta-c set ] set-meta-word
 \ call [ pop-d meta-call ] set-meta-word
 \ execute [ pop-d meta-word ] set-meta-word
 \ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
@@ -162,22 +162,6 @@ SYMBOL: meta-cf
         meta-d get set-datastack
     ] with-scope ;
 
-: walk-banner ( -- )
-    "The following words control the single-stepper:" print
-    "&s      -- print stepper data stack" print
-    "&r      -- print stepper call stack" print
-    "&n      -- print stepper name stack" print
-    "&c      -- print stepper catch stack" print
-    "step    -- single step" print
-    "(trace) -- trace until end" print
-    "(run)   -- run until end" print ;
-
-: walk ( quot -- )
-    #! Single-step through execution of a quotation.
-    init-interpreter
-    meta-cf set
-    walk-banner ;
-
 : &s
     #! Print stepper data stack.
     meta-d get {.} ;
@@ -188,15 +172,35 @@ SYMBOL: meta-cf
 
 : &n
     #! Print stepper name stack.
-    meta-n get {.} ;
+    meta-n get [.] ;
 
 : &c
     #! Print stepper catch stack.
     meta-c get {.} ;
 
+: &get ( var -- value )
+    #! Print stepper variable value.
+    meta-n get (get) ;
+
 : not-done ( quot -- )
     done? [ "Stepper is done." print drop ] [ call ] ifte ;
 
 : step
     #! Step into current word.
     [ next dup report do ] not-done ;
+
+: walk-banner ( -- )
+    "The following words control the single-stepper:" print
+    [ &s &r &n &c ] [ prettyprint-word " " write ] each
+    "show stepper stacks." print
+    \ &get prettyprint-word
+    " ( var -- value ) inspects the stepper namestack." print
+    \ step prettyprint-word " -- single step" print
+    \ (trace) prettyprint-word " -- trace until end" print
+    \ (run) prettyprint-word " -- run until end" print ;
+
+: walk ( quot -- )
+    #! Single-step through execution of a quotation.
+    init-interpreter
+    meta-cf set
+    walk-banner ;

library/tools/listener.factor

@@ -44,12 +44,7 @@ USE: unparser
 USE: vectors
 
 : print-banner ( -- )
-    [
+    "Factor " write version print
-        "This is " ,
-        java? [ "JVM " , ] when
-        native? [ "native " , ] when
-        "Factor " , version ,
-    ] make-string print
     "Copyright (C) 2003, 2004 Slava Pestov" print
     "Copyright (C) 2004 Chris Double" print
     "Type ``exit'' to exit, ``help'' for help." print ;
@@ -74,22 +69,30 @@ USE: vectors
         listener-step listener-loop
     ] ifte ;
 
+: kb. 1024 /i unparse write " KB" write ;
+
+: (room.) ( free total -- )
+    2dup swap - swap ( free used total )
+    kb. " total " write
+    kb. " used " write
+    kb. " free" print ;
+
 : room. ( -- )
     room
-    1024 /i unparse write " KB total, " write
+    "Data space: " write (room.)
-    1024 /i unparse write " KB free" print ;
+    "Code space: " write (room.) ;
 
 : init-listener ( -- )
     print-banner
+    terpri
     room.
+    terpri
 
     listener-loop ;
 
 : help ( -- )
     "SESSION:" print
-    native? [
+    "\"foo.image\" save-image   -- save heap to a file" print
-        "\"foo.image\" save-image   -- save heap to a file" print
-    ] when
     "room.                    -- show memory usage" print
     "heap-stats.              -- memory allocation breakdown" print
     "garbage-collection       -- force a GC" print
@@ -114,7 +117,7 @@ USE: vectors
     "PROFILER:                [ ... ] call-profile" print
     "                         [ ... ] allot-profile" print
     "TRACE:                   [ ... ] trace" print
-    "SINGLE STEP:             [ ... ] step" print
+    "SINGLE STEP:             [ ... ] walk" print
     terpri
     "HTTP SERVER:             USE: httpd 8888 httpd" print
     "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;

library/tools/telnetd.factor

@@ -46,12 +46,7 @@ USE: threads
     ] with-stream ;
 
 : telnet-connection ( socket -- )
-    #! We don't do multitasking in JFactor.
+    [ telnet-client ] in-thread drop ;
-    java? [
-        telnet-client
-    ] [
-        [ telnet-client ] in-thread drop
-    ] ifte ;
 
 : quit-flag ( -- ? )
     global [ "telnetd-quit-flag" get ] bind ;

library/vocabulary-style.factor

@@ -27,6 +27,7 @@
 
 IN: presentation
 USE: combinators
+USE: hashtables
 USE: lists
 USE: kernel
 USE: namespaces
@@ -36,10 +37,10 @@ USE: words
 : vocab-style ( vocab -- style )
     #! Each vocab has a style object specifying how words are
     #! to be printed.
-    "vocabularies" style get* ;
+    "vocabularies" style hash ;
 
 : set-vocab-style ( style vocab -- )
-    >r default-style append r> "vocabularies" style set* ;
+    >r default-style append r> "vocabularies" style set-hash ;
 
 : word-style ( word -- style )
     word-vocabulary [ vocab-style ] [ default-style ] ifte* ;

library/words.factor

@@ -27,6 +27,7 @@
 
 IN: words
 USE: combinators
+USE: hashtables
 USE: kernel
 USE: lists
 USE: logic
@@ -42,11 +43,11 @@ USE: strings
 
 : vocabs ( -- list )
     #! Push a list of vocabularies.
-    global [ "vocabularies" get [ vars str-sort ] bind ] bind ;
+    global [ "vocabularies" get hash-keys str-sort ] bind ;
 
 : vocab ( name -- vocab )
     #! Get a vocabulary.
-    global [ "vocabularies" get get* ] bind ;
+    global [ "vocabularies" get hash ] bind ;
 
 : word-sort ( list -- list )
     #! Sort a list of words by name.
@@ -55,7 +56,7 @@ USE: strings
 : words ( vocab -- list )
     #! Push a list of all words in a vocabulary.
     #! Filter empty slots.
-    vocab [ values ] bind [ ] subset word-sort ;
+    vocab hash-values [ ] subset word-sort ;
 
 : each-word ( quot -- )
     #! Apply a quotation to each word in the image.

native/memory.c

@@ -71,7 +71,8 @@ bool in_zone(ZONE* z, CELL pointer)
 
 void primitive_room(void)
 {
-	/* push: free total */
+	box_integer(compiling.limit - compiling.here);
+	box_integer(compiling.limit - compiling.base);
 	box_integer(active.limit - active.here);
 	box_integer(active.limit - active.base);
 }