f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
- # $(STRIP) $@
+ $(STRIP) $@
clean:
rm -f $(OBJS)
\r
- profiler is inaccurate: wrong word on cs\r
- better i/o scheduler\r
-- don't rehash strings on every startup\r
- remove sbufs\r
- cat, reverse-cat primitives\r
- first-class hashtables\r
-- hash words in stage 2 of bootstrap\r
- rewrite accessors and mutators in Factor, with slot/set-slot primitive\r
- replace -export-dynamic with sundry-xt\r
- add a socket timeout\r
\r
+ misc:\r
\r
+- unit test weirdness: 2 lines appears at end\r
- jedit ==> jedit-word, jedit takes a file name\r
- command line parsing cleanup\r
- nicer way to combine two paths\r
objects\r
- worddef props\r
- prettyprint: when unparse called due to recursion, write a link\r
-- FORGET: and forget\r
\r
+ httpd:\r
\r
#! <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 )
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);
} //}}}
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
{
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)
return createFieldAndButton(image);
} //}}}
+ //{{{ createArgsField() metnod
+ private JComponent createArgsField(String text)
+ {
+ args = new JTextField(text);
+ return args;
+ } //}}}
+
//{{{ createFieldAndButton() metnod
private JComponent createFieldAndButton(JTextField field)
{
{
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(
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/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"
USE: lists
USE: image
USE: parser
+USE: namespaces
+USE: stdio
+USE: combinators
+USE: kernel
+USE: vectors
primitives,
[
[
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
! 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
USE: unparser
USE: words
-: image "image" get ;
-: emit ( cell -- ) image vector-push ;
+! The image being constructed; a vector of word-size integers
+SYMBOL: image
+
+! Boot quotation, set by boot.factor
+SYMBOL: boot-quot
-: fixup ( value offset -- ) image set-vector-nth ;
+: emit ( cell -- ) image get vector-push ;
+
+: fixup ( value offset -- ) image get set-vector-nth ;
( Object memory )
( 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 ;
] 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 ;
: 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 -- )
[
[ fixnum? ] [ 'fixnum ]
[ bignum? ] [ 'bignum ]
- [ ratio? ] [ 'ratio ]
- [ complex? ] [ 'complex ]
[ word? ] [ 'word ]
[ cons? ] [ 'cons ]
[ string? ] [ 'string ]
( 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.
+ \ <namespace> ,
+ [
+ "vocabularies" get [
+ uncons hash>alist , \ alist>hash , , \ set ,
+ ] hash-each
+ ] make-list ,
+ \ extend , ;
: global, ( -- )
- "vocabularies" get "vocabularies"
- namespace-buckets <hashtable>
- dup >r set-hash r> (set-global) ;
+ #! Produces code with stack effect ( vocabularies -- ).
+ <namespace> ' 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 ;
: 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,
! parser namespaces.
1000 <vector> "word-fixups" set
call
- "image" get
+ image get
] with-scope ;
: with-image ( quot -- image )
: 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.
: 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 ;
#!
#! 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
: (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
--- /dev/null
+! :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
--- /dev/null
+! :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 ;
--- /dev/null
+! :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
--- /dev/null
+! :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
: 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.
! Vocabularies
: DEFER: CREATE drop ; parsing
+: FORGET: scan-word forget ; parsing
+
: USE: scan "use" cons@ ; parsing
: IN: scan dup "use" cons@ "in" set ; parsing
: 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
[ [ 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
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
[ -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
#! 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
+++ /dev/null
-! :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
#! 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 ;
projects / factor.git / commitdiff