steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

oop fix, split up inference

cvs
Slava Pestov 2004-11-27 03:23:57 +00:00
parent 68b9312154
commit 9680d5b6bb
26 changed files with 630 additions and 437 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

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

4
TODO.FACTOR.txt
View File

@ -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:

2
examples/oop.factor
View File

@ -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 )

2
factor/FactorReader.java
View File

@ -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);
} //}}}

11
factor/jedit/FactorOptionPane.java
View File

@ -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)
{

15
factor/jedit/FactorPlugin.java
View File

@ -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(

3
factor/jedit/FactorPlugin.props
View File

@ -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

5
library/bootstrap/boot-stage2.factor
View File

@ -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"

9
library/bootstrap/boot.factor
View File

@ -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

71
library/bootstrap/image.factor
View File

@ -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.
\ <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 ;
@ -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 )

5
library/bootstrap/init-stage2.factor
View File

@ -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.

4
library/cli.factor
View File

@ -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 ;

2
library/combinators.factor
View File

@ -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

2
library/hashtables.factor
View File

@ -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

138
library/inference/branches.factor Normal file
View File

@ -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

168
library/inference/inference.factor Normal file
View File

@ -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 ;

57
library/inference/stack.factor Normal file
View File

@ -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

133
library/inference/words.factor Normal file
View File

@ -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

2
library/math/arithmetic.factor
View File

@ -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.

2
library/syntax/parse-syntax.factor
View File

@ -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

25
library/test/inference.factor
View File

@ -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

25
library/test/interpreter.factor
View File

@ -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

2
library/test/math/rational.factor
View File

@ -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

9
library/tools/debugger.factor
View File

@ -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

365
library/tools/inference.factor
View File

@ -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

4
library/vocabularies.factor
View File

@ -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 ;