oop fix, split up inference

Makefile

@@ -60,7 +60,7 @@ solaris:
 
 f: $(OBJS)
 	$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
-	# $(STRIP) $@
+	$(STRIP) $@
 
 clean:
 	rm -f $(OBJS)

TODO.FACTOR.txt

@@ -38,17 +38,16 @@
 
 - profiler is inaccurate: wrong word on cs
 - better i/o scheduler
-- don't rehash strings on every startup
 - remove sbufs
 - cat, reverse-cat primitives
 - first-class hashtables
-- hash words in stage 2 of bootstrap
 - rewrite accessors and mutators in Factor, with slot/set-slot primitive
 - replace -export-dynamic with sundry-xt
 - add a socket timeout
 
 + misc:
 
+- unit test weirdness: 2 lines appears at end
 - jedit ==> jedit-word, jedit takes a file name
 - command line parsing cleanup
 - nicer way to combine two paths
@@ -58,7 +57,6 @@
   objects
 - worddef props
 - prettyprint: when unparse called due to recursion, write a link
-- FORGET: and forget
 
 + httpd:
 

examples/oop.factor

@@ -39,7 +39,7 @@ SYMBOL: traits
     #! <foo> where foo is a traits type creates a new instance
     #! of foo.
     [ constructor-word [ <namespace> ] ] keep
-    traits-map [ traits pick set* ] cons append
+    traits-map [ traits pick set-hash ] cons append
     define-compound ;
 
 : predicate-word ( word -- word )

factor/FactorReader.java

@@ -346,7 +346,7 @@ public class FactorReader
 	public void pushExclusiveState(FactorWord start, FactorWord defining)
 		throws FactorParseException
 	{
-		if(getCurrentState().start != toplevel)
+		if(states != null && getCurrentState().start != toplevel)
 			scanner.error(start + " cannot be nested");
 		pushState(start,defining);
 	} //}}}

factor/jedit/FactorOptionPane.java

@@ -51,6 +51,8 @@ public class FactorOptionPane extends AbstractOptionPane
 			createProgramField(jEdit.getProperty("factor.external.program")));
 		addComponent(jEdit.getProperty("options.factor.image"),
 			createImageField(jEdit.getProperty("factor.external.image")));
+		addComponent(jEdit.getProperty("options.factor.args"),
+			createArgsField(jEdit.getProperty("factor.external.args")));
 	} //}}}
 	
 	//{{{ _save() method
@@ -58,11 +60,13 @@ public class FactorOptionPane extends AbstractOptionPane
 	{
 		jEdit.setProperty("factor.external.program",program.getText());
 		jEdit.setProperty("factor.external.image",image.getText());
+		jEdit.setProperty("factor.external.args",args.getText());
 	} //}}}
 	
 	//{{{ Private members
 	private JTextField program;
 	private JTextField image;
+	private JTextField args;
 
 	//{{{ createProgramField() metnod
 	private JComponent createProgramField(String text)
@@ -78,6 +82,13 @@ public class FactorOptionPane extends AbstractOptionPane
 		return createFieldAndButton(image);
 	} //}}}
 	
+	//{{{ createArgsField() metnod
+	private JComponent createArgsField(String text)
+	{
+		args = new JTextField(text);
+		return args;
+	} //}}}
+	
 	//{{{ createFieldAndButton() metnod
 	private JComponent createFieldAndButton(JTextField field)
 	{

factor/jedit/FactorPlugin.java

@@ -84,13 +84,14 @@ public class FactorPlugin extends EditPlugin
 	{
 		if(external == null)
 		{
-			Process p = Runtime.getRuntime().exec(
+			String[] args = jEdit.getProperty("factor.external.args","-jedit")
-				new String[] {
+				.split(" ");
-					jEdit.getProperty("factor.external.program"),
+			String[] nargs = new String[args.length + 3];
-					jEdit.getProperty("factor.external.image"),
+			nargs[0] = jEdit.getProperty("factor.external.program");
-					"-no-ansi",
+			nargs[1] = jEdit.getProperty("factor.external.image");
-					"-jedit"
+			nargs[2] = "-no-ansi";
-				});
+			System.arraycopy(args,0,nargs,3,args.length);
+			Process p = Runtime.getRuntime().exec(nargs);
 			p.getErrorStream().close();
 
 			external = new ExternalFactor(

factor/jedit/FactorPlugin.props

@@ -81,3 +81,6 @@ options.factor.code=new factor.jedit.FactorOptionPane();
 options.factor.program=Factor runtime executable:
 options.factor.image=Factor image:
 options.factor.choose=Choose file...
+options.factor.args=Additional arguments:
+
+factor.external.args=-jedit

library/bootstrap/boot-stage2.factor

@@ -102,7 +102,10 @@ USE: stdio
     "/library/tools/heap-stats.factor"
     "/library/gensym.factor"
     "/library/tools/interpreter.factor"
-    "/library/tools/inference.factor"
+    "/library/inference/inference.factor"
+    "/library/inference/words.factor"
+    "/library/inference/branches.factor"
+    "/library/inference/stack.factor"
 
     "/library/bootstrap/image.factor"
     "/library/bootstrap/cross-compiler.factor"

library/bootstrap/boot.factor

@@ -28,6 +28,11 @@
 USE: lists
 USE: image
 USE: parser
+USE: namespaces
+USE: stdio
+USE: combinators
+USE: kernel
+USE: vectors
 
 primitives,
 [
@@ -77,5 +82,7 @@ DEFER: boot
 
 [
     boot
+    "Good morning!" print
+    global vector? [ "vocabs set" ] [ "vocabs not set" ] ifte print
     "/library/bootstrap/boot-stage2.factor" run-resource
-] (set-boot)
+] boot-quot set

library/bootstrap/image.factor

@@ -38,11 +38,6 @@
 ! It initializes the core interpreter services, and proceeds to
 ! run platform/native/boot-stage2.factor.
 
-IN: namespaces
-
-( Java Factor doesn't have this )
-: namespace-buckets 23 ;
-
 IN: image
 USE: combinators
 USE: errors
@@ -63,10 +58,15 @@ USE: vectors
 USE: unparser
 USE: words
 
-: image "image" get ;
+! The image being constructed; a vector of word-size integers
-: emit ( cell -- ) image vector-push ;
+SYMBOL: image
 
-: fixup ( value offset -- ) image set-vector-nth ;
+! Boot quotation, set by boot.factor
+SYMBOL: boot-quot
+
+: emit ( cell -- ) image get vector-push ;
+
+: fixup ( value offset -- ) image get set-vector-nth ;
 
 ( Object memory )
 
@@ -127,7 +127,7 @@ USE: words
 ( Allocator )
 
 : here ( -- size ) 
-    image vector-length header-size - cell * base + ;
+    image get vector-length header-size - cell * base + ;
 
 : here-as ( tag -- pointer )
     here swap bitor ;
@@ -195,9 +195,9 @@ USE: words
     ] ifte ;
 
 : fixup-words ( -- )
-    "image" get [
+    image get [
         dup word? [ fixup-word ] when
-    ] vector-map "image" set ;
+    ] vector-map image set ;
 
 : 'word ( word -- pointer )
     dup pooled-object dup [ nip ] [ drop ] ifte ;
@@ -209,18 +209,6 @@ DEFER: '
 : cons, ( -- pointer ) cons-tag here-as ;
 : 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
 
-( Ratios -- almost the same as a cons )
-
-: ratio, ( -- pointer ) ratio-tag here-as ;
-: 'ratio ( a/b -- tagged )
-    dup denominator ' swap numerator ' ratio, -rot emit emit ;
-
-( Complex -- almost the same as ratio )
-
-: complex, ( -- pointer ) complex-tag here-as ;
-: 'complex ( #{ a b } -- tagged )
-    dup imaginary ' swap real ' complex, -rot emit emit ;
-
 ( Strings )
 
 : align-string ( n str -- )
@@ -317,8 +305,6 @@ DEFER: '
     [
         [ fixnum?  ] [ 'fixnum      ]
         [ bignum?  ] [ 'bignum      ]
-        [ ratio?   ] [ 'ratio       ]
-        [ complex? ] [ 'complex     ]
         [ word?    ] [ 'word        ]
         [ cons?    ] [ 'cons        ]
         [ string?  ] [ 'string      ]
@@ -331,16 +317,35 @@ DEFER: '
 
 ( End of the image )
 
-: (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
+: vocabularies, ( -- )
-: (set-global) ( namespace -- ) ' global-offset fixup ;
+    #! Produces code with stack effect ( -- vocabularies ).
+    #! This code sets up vocabulary hash tables.
+    \ <namespace> ,
+    [
+        "vocabularies" get [
+            uncons hash>alist , \ alist>hash , , \ set ,
+        ] hash-each
+    ] make-list ,
+    \ extend , ;
 
 : global, ( -- )
-    "vocabularies" get "vocabularies"
+    #! Produces code with stack effect ( vocabularies -- ).
-    namespace-buckets <hashtable>
+    <namespace> ' global-offset fixup
-    dup >r set-hash r> (set-global) ;
+    "vocabularies" ,
+    \ global ,
+    \ set-hash , ;
+
+: hash-quot ( -- quot )
+    #! Generate a quotation to generate vocabulary and global
+    #! namespace hashtables.
+    [ vocabularies, global, ] make-list ;
+
+: boot, ( quot -- )
+    boot-quot get append ' boot-quot-offset fixup ;
 
 : end ( -- )
-    global,
+    hash-quot
+    boot,
     fixup-words
     here base - heap-size-offset fixup ;
 
@@ -366,7 +371,7 @@ DEFER: '
 
 : with-minimal-image ( quot -- image )
     [
-        300000 <vector> "image" set
+        300000 <vector> image set
         521 <hashtable> "objects" set
         namespace-buckets <hashtable> "vocabularies" set
         ! Note that this is a vector that we can side-effect,
@@ -374,7 +379,7 @@ DEFER: '
         ! parser namespaces.
         1000 <vector> "word-fixups" set
         call
-        "image" get
+        image get
     ] with-scope ;
 
 : with-image ( quot -- image )

library/bootstrap/init-stage2.factor

@@ -47,11 +47,6 @@ USE: unparser
 
 : cli-args ( -- args ) 10 getenv ;
 
-: init-error-handler ( -- )
-    [ 1 exit* ] >c ( last resort )
-    [ default-error-handler 1 exit* ] >c
-    [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
-
 : warm-boot ( -- )
     #! A fully bootstrapped image has this as the boot
     #! quotation.

library/cli.factor

@@ -80,13 +80,13 @@ USE: words
 : cli-arg ( argument -- argument )
     #! Handle a command-line argument. If the argument was
     #! consumed, returns f. Otherwise returns the argument.
-    dup [
+    dup f-or-"" [
         dup "-" str-head? dup [
             cli-param drop f
         ] [
             drop
         ] ifte
-    ] when ;
+    ] unless ;
 
 : parse-switches ( args -- args )
     [ cli-arg ] map ;

library/combinators.factor

@@ -120,7 +120,7 @@ USE: stack
     #!
     #! In order to compile, the quotation must consume one more
     #! value than it produces.
-    over [ call ] [ 2drop ] ifte ; inline
+    dupd [ drop ] ifte ; inline
 
 : forever ( quot -- )
     #! The code is evaluated in an infinite loop. Typically, a

library/hashtables.factor

@@ -49,7 +49,7 @@ USE: vectors
 
 : (hashcode) ( key table -- index )
     #! Compute the index of the bucket for a key.
-    >r hashcode HEX: ffffff bitand r> vector-length mod ;
+    >r hashcode r> vector-length rem ;
 
 : hash* ( key table -- [ key | value ] )
     #! Look up a value in the hashtable. First the bucket is

library/inference/branches.factor

@@ -0,0 +1,138 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: combinators
+USE: errors
+USE: interpreter
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+USE: hashtables
+
+DEFER: (infer)
+
+: (effect) ( -- [ in | stack ] )
+    d-in get  meta-d get cons ;
+
+: infer-branch ( quot -- [ in-d | datastack ] )
+    #! Infer the quotation's effect, restoring the meta
+    #! interpreter state afterwards.
+    [ copy-interpreter (infer) (effect) ] with-scope ;
+
+: difference ( [ in | stack ] -- diff )
+    #! Stack height difference of infer-branch return value.
+    uncons vector-length - ;
+
+: balanced? ( list -- ? )
+    #! Check if a list of [ in | stack ] pairs has the same
+    #! stack height.
+    [ difference ] map all=? ;
+
+: max-vector-length ( list -- length )
+    [ vector-length ] map [ > ] top ;
+
+: unify-lengths ( list -- list )
+    #! Pad all vectors to the same length. If one vector is
+    #! shorter, pad it with unknown results at the bottom.
+    dup max-vector-length swap [ dupd ensure nip ] map nip ;
+
+: unify-result ( obj obj -- obj )
+    #! Replace values with unknown result if they differ,
+    #! otherwise retain them.
+    2dup = [ drop ] [ 2drop gensym ] ifte ;
+
+: unify-stacks ( list -- stack )
+    #! Replace differing literals in stacks with unknown
+    #! results.
+    uncons [ [ unify-result ] vector-2map ] each ;
+
+: unify ( list -- )
+    #! Unify meta-interpreter state from two branches.
+    dup balanced? [
+        unzip
+        unify-lengths unify-stacks meta-d set
+        [ > ] top d-in set
+    ] [
+        "Unbalanced branches" throw
+    ] ifte ;
+
+: recursive-branch ( quot -- )
+    #! Set base case if inference didn't fail
+    [
+        car infer-branch recursive-state get set-base
+    ] [
+        [ drop ] when
+    ] catch ;
+
+: infer-branches ( brachlist -- )
+    #! Recursive stack effect inference is done here. If one of
+    #! the branches has an undecidable stack effect, we set the
+    #! base case to this stack effect and try again.
+    dup [ recursive-branch ] each
+    [ car infer-branch ] map unify ;
+
+: infer-ifte ( -- )
+    #! Infer effects for both branches, unify.
+    pop-d pop-d 2list
+    pop-d drop ( condition )
+    infer-branches ;
+
+: vtable>list ( [ vtable | rstate ] -- list )
+    #! generic and 2generic use vectors of words, we need lists
+    #! of quotations. Filter out no-method. Dirty workaround;
+    #! later properly handle throw.
+    unswons vector>list [
+        dup \ no-method = [ drop f ] [ unit over cons ] ifte
+    ] map [ ] subset nip ;
+
+: infer-generic ( -- )
+    #! Infer effects for all branches, unify.
+    pop-d vtable>list
+    peek-d drop ( dispatch )
+    infer-branches ;
+
+: infer-2generic ( -- )
+    #! Infer effects for all branches, unify.
+    pop-d vtable>list
+    peek-d drop ( dispatch )
+    peek-d drop ( dispatch )
+    infer-branches ;
+
+\ ifte [ infer-ifte ] "infer" set-word-property
+
+\ generic [ infer-generic ] "infer" set-word-property
+\ generic [ 2 | 0 ] "infer-effect" set-word-property
+
+\ 2generic [ infer-2generic ] "infer" set-word-property
+\ 2generic [ 3 | 0 ] "infer-effect" set-word-property

library/inference/inference.factor

@@ -0,0 +1,168 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: combinators
+USE: errors
+USE: interpreter
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+USE: hashtables
+
+! Word properties that affect inference:
+! - infer-effect -- must be set. controls number of inputs
+! expected, and number of outputs produced.
+! - infer - quotation with custom inference behavior; ifte uses
+! this. Word is passed on the stack.
+
+! Amount of results we had to add to the datastack
+SYMBOL: d-in
+
+! Recursive state. Alist maps words to hashmaps...
+SYMBOL: recursive-state
+! ... with keys:
+SYMBOL: base-case
+SYMBOL: entry-effect
+
+! We build a dataflow graph for the compiler.
+SYMBOL: dataflow-graph
+
+: dataflow, ( obj -- )
+    #! Add a node to the dataflow IR.
+    dataflow-graph cons@ ;
+
+: gensym-vector ( n --  vector )
+    dup <vector> swap [ gensym over vector-push ] times ;
+
+: inputs ( count stack -- stack )
+    #! Add this many inputs to the given stack.
+    >r gensym-vector dup r> vector-append ;
+
+: ensure ( count stack -- count stack )
+    #! Ensure stack has this many elements. Return number of
+    #! elements added.
+    2dup vector-length > [
+        [ vector-length - dup ] keep inputs
+    ] [
+        >r drop 0 r>
+    ] ifte ;
+
+: ensure-d ( count -- )
+    #! Ensure count of unknown results are on the stack.
+    meta-d get ensure meta-d set d-in +@ ;
+
+: consume-d ( count -- )
+    #! Remove count of elements.
+    [ pop-d drop ] times ;
+
+: produce-d ( count -- )
+    #! Push count of unknown results.
+    [ gensym push-d ] times ;
+
+: consume/produce ( [ in | out ] -- )
+    unswons dup ensure-d consume-d produce-d ;
+
+: 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 ;
+
+: init-inference ( recursive-state -- )
+    init-interpreter
+    0 d-in set
+    recursive-state set
+    dataflow-graph off ;
+
+: with-recursive-state ( word quot -- )
+    over <recursive-state> cons recursive-state cons@
+    call
+    recursive-state uncons@ drop ;
+
+DEFER: apply-word
+
+: 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? [
+        apply-word
+    ] [
+        #! Literals are annotated with the current recursive
+        #! state.
+        dup dataflow,  recursive-state get cons push-d
+    ] ifte ;
+
+: (infer) ( quot -- )
+    #! Recursive calls to this word are made for nested
+    #! quotations.
+    [ apply-object ] each ;
+
+: compose ( first second -- total )
+    #! Stack effect composition.
+    >r uncons r> uncons >r -
+    dup 0 < [ neg + r> cons ] [ r> + cons ] ifte ;
+
+: raise ( [ in | out ] -- [ in | out ] )
+    uncons 2dup min tuck - >r - r> cons ;
+
+: 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 raise ;
+
+: set-base ( [ in | stack ] rstate -- )
+    #! Set the base case of the current word.
+    >r uncons vector-length cons r>  car cdr [
+        entry-effect get swap decompose base-case set
+    ] bind ;
+
+: infer ( quot -- [ in | out ] )
+    #! Stack effect of a quotation.
+    [
+        f init-inference (infer)  effect
+        ( dataflow-graph get USE: prettyprint . )
+    ] with-scope ;
+
+: try-infer ( quot -- effect/f )
+    #! Push f if inference fails.
+    [ infer ] [ [ drop f ] when ] catch ;

library/inference/stack.factor

@@ -0,0 +1,57 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: interpreter
+USE: stack
+USE: words
+USE: lists
+
+: meta-infer ( word -- )
+    #! Mark a word as being partially evaluated.
+    dup unit [ car host-word ] cons  "infer" set-word-property ;
+
+\ >r [ pop-d push-r ] "infer" set-word-property
+\ r> [ pop-r push-d ] "infer" set-word-property
+
+\ drop meta-infer
+\ 2drop meta-infer 
+\ 3drop meta-infer
+\ dup meta-infer
+\ 2dup meta-infer
+\ 3dup meta-infer
+\ swap meta-infer
+\ over meta-infer
+\ pick meta-infer
+\ nip meta-infer
+\ tuck meta-infer
+\ rot meta-infer
+\ -rot meta-infer
+\ 2nip meta-infer
+\ transp meta-infer
+\ dupd meta-infer
+\ swapd meta-infer

library/inference/words.factor

@@ -0,0 +1,133 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: combinators
+USE: errors
+USE: interpreter
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+USE: hashtables
+
+: apply-effect ( word [ in | out ] -- )
+    #! If a word does not have special inference behavior, we
+    #! either execute the word in the meta interpreter (if it is
+    #! side-effect-free and all parameters are literal), or
+    #! simply apply its stack effect to the meta-interpreter.
+    swap "infer" word-property dup [
+        swap car ensure-d call
+    ] [
+        drop consume/produce
+    ] ifte ;
+
+: no-effect ( word -- )
+    "Unknown stack effect: " swap word-name cat2 throw ;
+
+: infer-compound ( word -- effect )
+    #! Infer a word's stack effect, and cache it.
+    [
+        recursive-state get init-inference
+        [
+            dup word-parameter (infer) effect
+            [ "infer-effect" set-word-property ] keep
+        ] with-recursive-state
+    ] with-scope ;
+
+: inline-compound ( word -- )
+    [ word-parameter (infer) ] with-recursive-state ;
+
+: apply-compound ( word -- )
+    #! Infer a compound word's stack effect.
+    dup "inline-infer" word-property [
+        inline-compound
+    ] [
+        [
+            dup dataflow,  infer-compound consume/produce
+        ] [
+            [
+                dup t "inline-infer" set-word-property
+                inline-compound
+            ] when
+        ] catch
+    ] ifte ;
+
+: current-word ( -- word )
+    #! Push word we're currently inferring effect of.
+    recursive-state get car car ;
+
+: 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
+    #! more items from the stack than producing, we have a
+    #! diverging recursion.
+    d-in get meta-d get vector-length > [
+        current-word word-name " diverges." cat2 throw
+    ] when ;
+
+: recursive-word ( word state -- )
+    #! Handle a recursive call, by either applying a previously
+    #! inferred base case, or raising an error.
+    base-case swap hash dup [
+        nip consume/produce
+    ] [
+        drop no-base-case
+    ] ifte ;
+
+: apply-word ( word -- )
+    #! Apply the word's stack effect to the inferencer state.
+    dup recursive-state get assoc dup [
+        check-recursion recursive-word
+    ] [
+        drop dup "infer-effect" word-property dup [
+            over dataflow,
+            apply-effect
+        ] [
+            drop dup compound? [ apply-compound ] [ no-effect ] ifte
+        ] ifte
+    ] ifte ;
+
+: infer-call ( [ rstate | quot ] -- )
+    [
+        pop-d uncons recursive-state set (infer)
+        d-in get meta-d get
+    ] with-scope  meta-d set d-in set ;
+
+\ call [ infer-call ] "infer" set-word-property
+
+\ + [ 2 | 1 ] "infer-effect" set-word-property
+\ - [ 2 | 1 ] "infer-effect" set-word-property
+\ * [ 2 | 1 ] "infer-effect" set-word-property
+\ / [ 2 | 1 ] "infer-effect" set-word-property

library/math/arithmetic.factor

@@ -67,7 +67,7 @@ USE: stack
 
 : rem ( x y -- x%y )
     #! Like modulus, but always gives a positive result.
-    dup >r + r> mod ;
+    [ mod ] keep  over 0 < [ + ] [ drop ] ifte ;
 
 : sgn ( n -- -1/0/1 )
     #! Push the sign of a real number.

library/syntax/parse-syntax.factor

@@ -166,6 +166,8 @@ IN: syntax
 
 ! Vocabularies
 : DEFER: CREATE drop ; parsing
+: FORGET: scan-word forget ; parsing
+
 : USE: scan "use" cons@ ; parsing
 : IN: scan dup "use" cons@ "in" set ; parsing
 

library/test/inference.factor

@@ -129,6 +129,24 @@ DEFER: foe
 : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
 [ [ bad-bin ] infer ] unit-test-fails
 
+: nested-when ( -- )
+    t [
+        t [
+            5 drop
+        ] when
+    ] when ;
+
+[ [ 0 | 0 ] ] [ [ nested-when ] infer ] unit-test
+
+: nested-when* ( -- )
+    [
+        [
+            drop
+        ] when*
+    ] when* ;
+
+[ [ 1 | 0 ] ] [ [ nested-when* ] infer ] unit-test
+
 [ [ 2 | 1 ] ] [ [ fie ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ foe ] infer ] unit-test
 
@@ -139,15 +157,16 @@ DEFER: foe
 [ [ 1 | 2 ] ] [ [ uncons ] infer ] unit-test
 [ [ 1 | 1 ] ] [ [ unit ] infer ] unit-test
 [ [ 1 | 2 ] ] [ [ unswons ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
 
 [ [ 1 | 1 ] ] [ [ length ] infer ] unit-test
 [ [ 1 | 1 ] ] [ [ reverse ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ contains? ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ tree-contains? ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ remove ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ prune ] infer ] unit-test
 
 [ [ 2 | 1 ] ] [ [ bitor ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ bitand ] infer ] unit-test

library/test/interpreter.factor

@@ -10,46 +10,49 @@ USE: math
 USE: lists
 USE: kernel
 
+: test-interpreter
+    init-interpreter run meta-d get ;
+
 [ { 1 2 3 } ] [
-    init-interpreter [ 1 2 3 ] run meta-d get
+    [ 1 2 3 ] test-interpreter
 ] unit-test
 
 [ { "Yo" 2 } ] [
-    init-interpreter [ 2 >r "Yo" r> ] run meta-d get
+    [ 2 >r "Yo" r> ] test-interpreter
 ] unit-test
 
 [ { 2 } ] [
-    init-interpreter [ t [ 2 ] [ "hi" ] ifte ] run meta-d get
+    [ t [ 2 ] [ "hi" ] ifte ] test-interpreter
 ] unit-test
 
 [ { "hi" } ] [
-    init-interpreter [ f [ 2 ] [ "hi" ] ifte ] run meta-d get
+    [ f [ 2 ] [ "hi" ] ifte ] test-interpreter
 ] unit-test
 
 [ { 4 } ] [
-    init-interpreter [ 2 2 fixnum+ ] run meta-d get
+    [ 2 2 fixnum+ ] test-interpreter
 ] unit-test
 
 [ { "Hey" "there" } ] [
-    init-interpreter [ [ "Hey" | "there" ] uncons ] run meta-d get
+    [ [ "Hey" | "there" ] uncons ] test-interpreter
 ] unit-test
 
 [ { t } ] [
-    init-interpreter [ "XYZ" "XYZ" = ] run meta-d get
+    [ "XYZ" "XYZ" = ] test-interpreter
 ] unit-test
 
 [ { f } ] [
-    init-interpreter [ "XYZ" "XuZ" = ] run meta-d get
+    [ "XYZ" "XuZ" = ] test-interpreter
 ] unit-test
 
 [ { #{ 1 1.5 } { } #{ 1 1.5 } { } } ] [
-    init-interpreter [ #{ 1 1.5 } { } 2dup ] run meta-d get
+    [ #{ 1 1.5 } { } 2dup ] test-interpreter
 ] unit-test
 
 [ { 4 } ] [
-    init-interpreter [ 2 2 + ] run meta-d get
+    [ 2 2 + ] test-interpreter
 ] unit-test
 
 [ { "4\n" } ] [
-    init-interpreter [ [ 2 2 + . ] with-string ] run meta-d get
+    [ [ 2 2 + . ] with-string ] test-interpreter
 ] unit-test

library/test/math/rational.factor

@@ -85,6 +85,8 @@ unit-test
 
 [ -3 ] [ -3 10 mod ] unit-test
 [ 7 ] [ -3 10 rem ] unit-test
+[ 7 ] [ -13 10 rem ] unit-test
+[ 0 ] [ 37 37 rem ] unit-test
 
 [ -1 ] [ -12.55 sgn ] unit-test
 [ 1 ] [ 100000000000000000000000000000000 sgn ] unit-test

library/tools/debugger.factor

@@ -172,3 +172,12 @@ USE: math
     #! Execute a quotation, and if it throws an error, print it
     #! and return to the caller.
     [ [ default-error-handler ] when* ] catch ;
+
+: init-error-handler ( -- )
+    [ 1 exit* ] >c ( last resort )
+    [ default-error-handler 1 exit* ] >c
+    [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
+
+! So that stage 2 boot gives a useful error message if something
+! fails after this file is loaded.
+init-error-handler

library/tools/inference.factor

@@ -1,365 +0,0 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: inference
-USE: combinators
-USE: errors
-USE: interpreter
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-USE: strings
-USE: vectors
-USE: words
-USE: hashtables
-
-! Word properties that affect inference:
-! - infer-effect -- must be set. controls number of inputs
-! expected, and number of outputs produced.
-! - 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 hashmaps...
-SYMBOL: recursive-state
-! ... with keys:
-SYMBOL: base-case
-SYMBOL: entry-effect
-
-: gensym-vector ( n --  vector )
-    dup <vector> swap [ gensym over vector-push ] times ;
-
-: inputs ( count stack -- stack )
-    #! Add this many inputs to the given stack.
-    >r gensym-vector dup r> vector-append ;
-
-: ensure ( count stack -- count stack )
-    #! Ensure stack has this many elements. Return number of
-    #! elements added.
-    2dup vector-length > [
-        [ vector-length - dup ] keep inputs
-    ] [
-        >r drop 0 r>
-    ] ifte ;
-
-: ensure-d ( count -- )
-    #! Ensure count of unknown results are on the stack.
-    meta-d get ensure meta-d set d-in +@ ;
-
-: consume-d ( count -- )
-    #! Remove count of elements.
-    [ pop-d drop ] times ;
-
-: produce-d ( count -- )
-    #! Push count of unknown results.
-    [ gensym push-d ] times ;
-
-: consume/produce ( [ in | out ] -- )
-    unswons dup ensure-d consume-d produce-d ;
-
-: apply-effect ( word [ in | out ] -- )
-    #! If a word does not have special inference behavior, we
-    #! either execute the word in the meta interpreter (if it is
-    #! side-effect-free and all parameters are literal), or
-    #! simply apply its stack effect to the meta-interpreter.
-    swap "infer" word-property dup [
-        swap car ensure-d call
-    ] [
-        drop consume/produce
-    ] ifte ;
-
-: 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 ;
-
-: init-inference ( recursive-state -- )
-    init-interpreter
-    0 d-in set
-    0 r-in set
-    recursive-state set ;
-
-DEFER: (infer)
-
-: with-recursive-state ( word quot -- )
-    over <recursive-state> cons recursive-state cons@
-    call
-    recursive-state uncons@ drop ;
-
-: infer-compound ( word -- effect )
-    #! Infer a word's stack effect, and cache it.
-    [
-        recursive-state get init-inference
-        [
-            dup word-parameter (infer) effect
-            [ "infer-effect" set-word-property ] keep
-        ] with-recursive-state
-    ] with-scope ;
-
-: inline-compound ( word -- )
-    [ word-parameter (infer) ] with-recursive-state ;
-
-: apply-compound ( word -- )
-    #! Infer a compound word's stack effect.
-    dup "inline-infer" word-property [
-        inline-compound
-    ] [
-        [
-            infer-compound consume/produce
-        ] [
-            [
-                dup t "inline-infer" set-word-property
-                inline-compound
-            ] when
-        ] catch
-    ] ifte ;
-
-: apply-word ( word -- )
-    #! Apply the word's stack effect to the inferencer state.
-    dup "infer-effect" word-property dup [
-        apply-effect
-    ] [
-        drop dup compound? [ apply-compound ] [ no-effect ] ifte
-    ] ifte ;
-
-: current-word ( -- word )
-    #! Push word we're currently inferring effect of.
-    recursive-state get car car ;
-
-: current-state ( -- word )
-    #! Push word we're currently inferring effect of.
-    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
-    #! more items from the stack than producing, we have a
-    #! diverging recursion.
-    d-in get meta-d get vector-length > [
-        current-word word-name " diverges." cat2 throw
-    ] when ;
-
-: recursive-word ( word state -- )
-    #! Handle a recursive call, by either applying a previously
-    #! inferred base case, or raising an error.
-    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-infer" word-property [
-            apply-word
-        ] [
-            dup recursive-state get assoc dup [
-                check-recursion recursive-word
-            ] [
-                drop apply-word
-            ] ifte
-        ] ifte
-    ] [
-        push-d
-    ] ifte ;
-
-: (infer) ( quot -- )
-    #! Recursive calls to this word are made for nested
-    #! quotations.
-    [ apply-object ] each ;
-
-: infer-branch ( quot -- [ in-d | datastack ] )
-    #! Infer the quotation's effect, restoring the meta
-    #! interpreter state afterwards.
-    [ copy-interpreter (infer) (effect) ] with-scope ;
-
-: difference ( [ in | stack ] -- diff )
-    #! Stack height difference of infer-branch return value.
-    uncons vector-length - ;
-
-: balanced? ( list -- ? )
-    #! Check if a list of [ in | stack ] pairs has the same
-    #! stack height.
-    [ difference ] map all=? ;
-
-: max-vector-length ( list -- length )
-    [ vector-length ] map [ > ] top ;
-
-: unify-lengths ( list -- list )
-    #! Pad all vectors to the same length. If one vector is
-    #! shorter, pad it with unknown results at the bottom.
-    dup max-vector-length swap [ dupd ensure nip ] map nip ;
-
-: unify-result ( obj obj -- obj )
-    #! Replace values with unknown result if they differ,
-    #! otherwise retain them.
-    2dup = [ drop ] [ 2drop gensym ] ifte ;
-
-: unify-stacks ( list -- stack )
-    #! Replace differing literals in stacks with unknown
-    #! results.
-    uncons [ [ unify-result ] vector-2map ] each ;
-
-: unify ( list -- )
-    #! Unify meta-interpreter state from two branches.
-    dup balanced? [
-        unzip
-        unify-lengths unify-stacks meta-d set
-        [ > ] top d-in set
-    ] [
-        "Unbalanced branches" throw
-    ] ifte ;
-
-: compose ( first second -- total )
-    #! Stack effect composition.
-    >r uncons r> uncons >r -
-    dup 0 < [ neg + r> cons ] [ r> + cons ] ifte ;
-
-: raise ( [ in | out ] -- [ in | out ] )
-    uncons 2dup min tuck - >r - r> cons ;
-
-: 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 raise ;
-
-: set-base ( [ in | stack ] -- )
-    #! Set the base case of the current word.
-    uncons vector-length cons
-    current-state [
-        entry-effect get swap decompose base-case set
-    ] bind ;
-
-: recursive-branch ( quot -- )
-    #! Set base case if inference didn't fail
-    [ infer-branch set-base ] [ [ drop ] when ] catch ;
-
-: infer-branches ( brachlist -- )
-    #! Recursive stack effect inference is done here. If one of
-    #! the branches has an undecidable stack effect, we set the
-    #! base case to this stack effect and try again.
-    dup [ recursive-branch ] each [ infer-branch ] map unify ;
-
-: infer-ifte ( -- )
-    #! Infer effects for both branches, unify.
-    pop-d pop-d 2list pop-d drop ( condition ) infer-branches ;
-
-: vtable>list ( vtable -- list )
-    #! generic and 2generic use vectors of words, we need lists
-    #! of quotations. Filter out no-method. Dirty workaround;
-    #! later properly handle throw.
-    vector>list [
-        dup \ no-method = [ drop f ] [ unit ] ifte
-    ] map [ ] subset ;
-
-: infer-generic ( -- )
-    #! Infer effects for all branches, unify.
-    pop-d vtable>list peek-d drop ( dispatch ) infer-branches ;
-
-: infer-2generic ( -- )
-    #! Infer effects for all branches, unify.
-    pop-d vtable>list
-    peek-d drop ( dispatch )
-    peek-d drop ( dispatch )
-    infer-branches ;
-
-: infer ( quot -- [ in | out ] )
-    #! Stack effect of a quotation.
-    [ f init-inference (infer)  effect ] with-scope ;
-
-: try-infer ( quot -- effect/f )
-    #! Push f if inference fails.
-    [ infer ] [ [ drop f ] when ] catch ;
-
-: meta-infer ( word -- )
-    #! Mark a word as being partially evaluated.
-    dup unit [ car host-word ] cons  "infer" set-word-property ;
-
-\ call [ pop-d (infer) ] "infer" set-word-property
-\ ifte [ infer-ifte ] "infer" set-word-property
-
-\ generic [ infer-generic ] "infer" set-word-property
-\ generic [ 2 | 0 ] "infer-effect" set-word-property
-
-\ 2generic [ infer-2generic ] "infer" set-word-property
-\ 2generic [ 3 | 0 ] "infer-effect" set-word-property
-
-\ >r [ pop-d push-r ] "infer" set-word-property
-\ r> [ pop-r push-d ] "infer" set-word-property
-
-\ drop meta-infer
-\ 2drop meta-infer 
-\ 3drop meta-infer
-\ dup meta-infer
-\ 2dup meta-infer
-\ 3dup meta-infer
-\ swap meta-infer
-\ over meta-infer
-\ pick meta-infer
-\ nip meta-infer
-\ tuck meta-infer
-\ rot meta-infer
-\ -rot meta-infer
-\ 2nip meta-infer
-\ transp meta-infer
-\ dupd meta-infer
-\ swapd meta-infer
-
-\ + [ 2 | 1 ] "infer-effect" set-word-property
-\ - [ 2 | 1 ] "infer-effect" set-word-property
-\ * [ 2 | 1 ] "infer-effect" set-word-property
-\ / [ 2 | 1 ] "infer-effect" set-word-property

library/vocabularies.factor

@@ -69,3 +69,7 @@ USE: stack
     #! already contains the word, the existing instance is
     #! returned.
     2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ;
+
+: forget ( word -- )
+    #! Remove a word definition.
+    dup word-vocabulary vocab [ word-name off ] bind ;