From 9680d5b6bbf3265ff56194a916e4c560f6689a75 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Nov 2004 03:23:57 +0000 Subject: [PATCH] oop fix, split up inference --- Makefile | 2 +- TODO.FACTOR.txt | 4 +- examples/oop.factor | 2 +- factor/FactorReader.java | 2 +- factor/jedit/FactorOptionPane.java | 11 + factor/jedit/FactorPlugin.java | 15 +- factor/jedit/FactorPlugin.props | 3 + library/bootstrap/boot-stage2.factor | 5 +- library/bootstrap/boot.factor | 9 +- library/bootstrap/image.factor | 71 +++--- library/bootstrap/init-stage2.factor | 5 - library/cli.factor | 4 +- library/combinators.factor | 2 +- library/hashtables.factor | 2 +- library/inference/branches.factor | 138 ++++++++++ library/inference/inference.factor | 168 ++++++++++++ library/inference/stack.factor | 57 +++++ library/inference/words.factor | 133 ++++++++++ library/math/arithmetic.factor | 2 +- library/syntax/parse-syntax.factor | 2 + library/test/inference.factor | 25 +- library/test/interpreter.factor | 25 +- library/test/math/rational.factor | 2 + library/tools/debugger.factor | 9 + library/tools/inference.factor | 365 --------------------------- library/vocabularies.factor | 4 + 26 files changed, 630 insertions(+), 437 deletions(-) create mode 100644 library/inference/branches.factor create mode 100644 library/inference/inference.factor create mode 100644 library/inference/stack.factor create mode 100644 library/inference/words.factor delete mode 100644 library/tools/inference.factor diff --git a/Makefile b/Makefile index a4070b4858..3d73735146 100644 --- a/Makefile +++ b/Makefile @@ -60,7 +60,7 @@ solaris: f: $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) - # $(STRIP) $@ + $(STRIP) $@ clean: rm -f $(OBJS) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 6c3deaf680..c99f626a1c 100644 --- a/TODO.FACTOR.txt +++ b/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: diff --git a/examples/oop.factor b/examples/oop.factor index 8bd1c6f36c..e5200bb68a 100644 --- a/examples/oop.factor +++ b/examples/oop.factor @@ -39,7 +39,7 @@ SYMBOL: traits #! where foo is a traits type creates a new instance #! of foo. [ constructor-word [ ] ] keep - traits-map [ traits pick set* ] cons append + traits-map [ traits pick set-hash ] cons append define-compound ; : predicate-word ( word -- word ) diff --git a/factor/FactorReader.java b/factor/FactorReader.java index 1a80808292..3f4a16298d 100644 --- a/factor/FactorReader.java +++ b/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); } //}}} diff --git a/factor/jedit/FactorOptionPane.java b/factor/jedit/FactorOptionPane.java index 7f1b837de3..e8c42e9560 100644 --- a/factor/jedit/FactorOptionPane.java +++ b/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) { diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index d20d220497..d91528314d 100644 --- a/factor/jedit/FactorPlugin.java +++ b/factor/jedit/FactorPlugin.java @@ -84,13 +84,14 @@ public class FactorPlugin extends EditPlugin { if(external == null) { - Process p = Runtime.getRuntime().exec( - new String[] { - jEdit.getProperty("factor.external.program"), - jEdit.getProperty("factor.external.image"), - "-no-ansi", - "-jedit" - }); + String[] args = jEdit.getProperty("factor.external.args","-jedit") + .split(" "); + String[] nargs = new String[args.length + 3]; + nargs[0] = jEdit.getProperty("factor.external.program"); + nargs[1] = jEdit.getProperty("factor.external.image"); + nargs[2] = "-no-ansi"; + System.arraycopy(args,0,nargs,3,args.length); + Process p = Runtime.getRuntime().exec(nargs); p.getErrorStream().close(); external = new ExternalFactor( diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index bbd9d83ffc..c3481f4805 100644 --- a/factor/jedit/FactorPlugin.props +++ b/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 diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 93e5210dae..655292bd29 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index e24d021540..d53563d8ab 100644 --- a/library/bootstrap/boot.factor +++ b/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 diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 496b1835f9..dc00af5a7c 100644 --- a/library/bootstrap/image.factor +++ b/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 ; -: emit ( cell -- ) image vector-push ; +! The image being constructed; a vector of word-size integers +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 ; -: (set-global) ( namespace -- ) ' global-offset fixup ; +: vocabularies, ( -- ) + #! Produces code with stack effect ( -- vocabularies ). + #! This code sets up vocabulary hash tables. + \ , + [ + "vocabularies" get [ + uncons hash>alist , \ alist>hash , , \ set , + ] hash-each + ] make-list , + \ extend , ; : global, ( -- ) - "vocabularies" get "vocabularies" - namespace-buckets - dup >r set-hash r> (set-global) ; + #! Produces code with stack effect ( vocabularies -- ). + ' global-offset fixup + "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 "image" set + 300000 image set 521 "objects" set namespace-buckets "vocabularies" set ! Note that this is a vector that we can side-effect, @@ -374,7 +379,7 @@ DEFER: ' ! parser namespaces. 1000 "word-fixups" set call - "image" get + image get ] with-scope ; : with-image ( quot -- image ) diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 986ceac01b..0668d6ec95 100644 --- a/library/bootstrap/init-stage2.factor +++ b/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. diff --git a/library/cli.factor b/library/cli.factor index 03eda3e8d8..fae4d0508e 100644 --- a/library/cli.factor +++ b/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 ; diff --git a/library/combinators.factor b/library/combinators.factor index c0fe2ac852..4bece90155 100644 --- a/library/combinators.factor +++ b/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 diff --git a/library/hashtables.factor b/library/hashtables.factor index 18f71b5473..9cc83aa847 100644 --- a/library/hashtables.factor +++ b/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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor new file mode 100644 index 0000000000..c7a3047563 --- /dev/null +++ b/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 diff --git a/library/inference/inference.factor b/library/inference/inference.factor new file mode 100644 index 0000000000..aa7ed56edd --- /dev/null +++ b/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 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 ; + +: ( -- state ) + [ + 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 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 ; diff --git a/library/inference/stack.factor b/library/inference/stack.factor new file mode 100644 index 0000000000..78492920b6 --- /dev/null +++ b/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 diff --git a/library/inference/words.factor b/library/inference/words.factor new file mode 100644 index 0000000000..0c43e8b9cf --- /dev/null +++ b/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 diff --git a/library/math/arithmetic.factor b/library/math/arithmetic.factor index ead58048c8..0753afd43b 100644 --- a/library/math/arithmetic.factor +++ b/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. diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 289efd0d43..01d0cf9e9f 100644 --- a/library/syntax/parse-syntax.factor +++ b/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 diff --git a/library/test/inference.factor b/library/test/inference.factor index 78ae5468d5..7fc174fa9e 100644 --- a/library/test/inference.factor +++ b/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 ] ] [ [ list? ] infer ] unit-test +[ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test +[ [ 1 | 1 ] ] [ [ last ] 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 diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index 27cf4db24b..8f519aaee8 100644 --- a/library/test/interpreter.factor +++ b/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 diff --git a/library/test/math/rational.factor b/library/test/math/rational.factor index 7f8f90c337..19916dc591 100644 --- a/library/test/math/rational.factor +++ b/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 diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 54efff5857..5fd7bcf0a7 100644 --- a/library/tools/debugger.factor +++ b/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 diff --git a/library/tools/inference.factor b/library/tools/inference.factor deleted file mode 100644 index c9d29d7ec8..0000000000 --- a/library/tools/inference.factor +++ /dev/null @@ -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 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 ; - -: ( -- state ) - [ - 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 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 diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 8024607784..998447492f 100644 --- a/library/vocabularies.factor +++ b/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 ;