Dynamic scope inference

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 3e007834097fb7601cc89ab07bb6e5f5c817c817..33ac362c76aec819eb15a00b03d13ae93f3265fe 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,5 @@
 + 0.87:
 
-- cocoa: move window while factor is busy: mouse gets messed up!
 - live search: timer delay would be nice
 - menu should stay up if mouse button released
 - roundoff is still not quite right with tracks
@@ -19,7 +18,6 @@
 - intrinsic fixnum>float float>fixnum
 - mac intel: struct returns from objc methods
 - faster apropos
-- infer which variables are read, written in a quotation
 - compiled call traces
 
 + ui:

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 08148a6afa4e69de149a36a80e66a9e02995a55d..42d4e4ea048e7aee20e8e5864daf15edb9988042 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -7,72 +7,70 @@ optimizer parser sequences sequences-internals words ;
 [
     print-warnings off
 
+    ! Wrap everything in a catch which starts a listener so
+    ! you can see what went wrong, instead of dealing with a
+    ! fep
     [
-        ! Wrap everything in a catch which starts a listener so
-        ! you can see what went wrong, instead of dealing with a
-        ! fep
-        [
-            "Cross-referencing..." print flush
-            H{ } clone changed-words set-global
-            H{ } clone crossref set-global xref-words
-
-            cpu "x86" = [
-                macosx?
-                "resource:/library/compiler/x86/alien-macosx.factor"
-                "resource:/library/compiler/x86/alien.factor"
-                ? run-file
+        "Cross-referencing..." print flush
+        H{ } clone changed-words set-global
+        H{ } clone crossref set-global xref-words
+
+        cpu "x86" = [
+            macosx?
+            "resource:/library/compiler/x86/alien-macosx.factor"
+            "resource:/library/compiler/x86/alien.factor"
+            ? run-file
+        ] when
+
+        "compile" get [
+            windows? [
+                "resource:/library/windows/dlls.factor"
+                run-file
             ] when
 
-            "compile" get [
-                windows? [
-                    "resource:/library/windows/dlls.factor"
-                    run-file
-                ] when
+            \ number= compile
+            \ + compile
+            \ nth compile
+            \ set-nth compile
+            \ = compile
 
-                \ number= compile
-                \ + compile
-                \ nth compile
-                \ set-nth compile
-                \ = compile
+            ! Load UI backend
+            "cocoa" get [
+                "library/ui/cocoa" require
+            ] when
 
-                ! Load UI backend
-                "cocoa" get [
-                    "library/ui/cocoa" require
-                ] when
+            "x11" get [
+                "library/ui/x11" require
+            ] when
 
-                "x11" get [
-                    "library/ui/x11" require
-                ] when
+            windows? [
+                "library/ui/windows" require
+            ] when
 
-                windows? [
-                    "library/ui/windows" require
+            ! Load native I/O code
+            "native-io" get [
+                unix? [
+                    "library/io/unix" require
                 ] when
-
-                ! Load native I/O code
-                "native-io" get [
-                    unix? [
-                        "library/io/unix" require
-                    ] when
-                    windows? [
-                        "library/io/windows" require
-                    ] when
+                windows? [
+                    "library/io/windows" require
                 ] when
+            ] when
 
-                parse-command-line
+            parse-command-line
 
-                compile-all
+            compile-all
 
-                "Initializing native I/O..." print flush
-                "native-io" get [ init-io ] when
+            "Initializing native I/O..." print flush
+            "native-io" get [ init-io ] when
 
-                ! We only do this if we are compiled, otherwise
-                ! it takes too long.
-                "Building online help search index..." print
-                flush
-                H{ } clone parent-graph set-global xref-help
-                H{ } clone term-index set-global index-help
-            ] when
-        ] no-parse-hook
+            ! We only do this if we are compiled, otherwise
+            ! it takes too long.
+            "Building online help search index..." print
+            flush
+            H{ } clone parent-graph set-global xref-help
+            H{ } clone term-index set-global index-help
+        ] when
 
         run-bootstrap-init
 
@@ -83,6 +81,10 @@ optimizer parser sequences sequences-internals words ;
             0 exit
         ] set-boot
 
+        "compile" get [ 
+            [ recompile ] parse-hook set-global
+        ] when
+
         f error set-global
         f error-continuation set-global
 

diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 4d19bbcbb7f7e4d393941cb46e703174687ceae7..17225e8fbbcdb3367673bc4053cf4c5a8f113231 100644 (file)
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -69,6 +69,7 @@ SYMBOL: architecture
 
 : emit-object ( header tag quot -- addr )
     swap here-as >r swap tag-header emit call align-here r> ;
+    inline
 
 ! Image header
 
@@ -224,7 +225,7 @@ M: string '
 : emit-array ( list type -- pointer )
     >r [ ' ] map r> object-tag [
         dup length emit-fixnum
-        ( elements -- ) emit-seq
+        emit-seq
     ] emit-object ;
 
 : transfer-tuple ( tuple -- tuple )

diff --git a/library/compiler/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor
index ef420050c53ea6652827ab2683e1df82b801570a..c7ab5d4be6c2f2d51ef2e9164cc0de283f4c9454 100644 (file)
--- a/library/compiler/alien/alien-callback.factor
+++ b/library/compiler/alien/alien-callback.factor
@@ -27,7 +27,7 @@ M: alien-callback-error summary
     alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
 
 \ alien-callback [ string object quotation ] [ alien ] <effect>
-"infer-effect" set-word-prop
+"inferred-effect" set-word-prop
 
 \ alien-callback [
     empty-node <alien-callback> dup node,

diff --git a/library/compiler/alien/alien-indirect.factor b/library/compiler/alien/alien-indirect.factor
index 3fed61c16bb1669eccd79011ce874c17cae99263..72590c50439ac2dd9917a86bf4c2315d8c2b210b 100644 (file)
--- a/library/compiler/alien/alien-indirect.factor
+++ b/library/compiler/alien/alien-indirect.factor
@@ -16,7 +16,7 @@ M: alien-indirect-error summary
     drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ;
 
 \ alien-indirect [ string object string ] [ ] <effect>
-"infer-effect" set-word-prop
+"inferred-effect" set-word-prop
 
 \ alien-indirect [
     empty-node <alien-indirect>

diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor
index 165e29891b7979f67173786a9d56bbc79ac90721..26bd931677cc7c00d529f84f9da937c377909474 100644 (file)
--- a/library/compiler/alien/alien-invoke.factor
+++ b/library/compiler/alien/alien-invoke.factor
@@ -9,7 +9,7 @@ TUPLE: alien-invoke library function return parameters ;
 C: alien-invoke make-node ;
 
 : alien-invoke-stack ( node -- )
-    dup alien-invoke-parameters length over consume-values
+    dup alien-invoke-parameters over consume-values
     dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
 
 : alien-invoke-dlsym ( node -- symbol dll )
@@ -29,7 +29,7 @@ M: alien-invoke-error summary
     [ inference-warning ] recover ;
 
 \ alien-invoke [ string object string object ] [ ] <effect>
-"infer-effect" set-word-prop
+"inferred-effect" set-word-prop
 
 \ alien-invoke [
     empty-node <alien-invoke>

diff --git a/library/compiler/alien/objc/utilities.factor b/library/compiler/alien/objc/utilities.factor
index 2e6f6d0e38e0e3317f44815d9d3c73c72fa94ea7..3d53ec05a4fa60d4169ae49558cb5f204a94a35c 100644 (file)
--- a/library/compiler/alien/objc/utilities.factor
+++ b/library/compiler/alien/objc/utilities.factor
@@ -121,7 +121,7 @@ H{ } clone objc-methods set-global
 \ (send) [ pop-literal nip infer-send ] "infer" set-word-prop
 
 \ (send) [ object object ] [ ] <effect>
-"infer-effect" set-word-prop
+"inferred-effect" set-word-prop
 
 : send ( ... selector -- ... ) f (send) ; inline
 

diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 9aade068ebae4d1a4a926add70217492290cbc27..59930220f08f4a041d35d38837fdd935ef83af11 100644 (file)
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -32,10 +32,10 @@ M: f batch-ends drop ;
 
 : word-dataflow ( word -- dataflow )
     [
-        dup ?no-effect
+        dup "no-effect" word-prop [ no-effect ] when
         dup dup add-recursive-state
-        dup specialized-def (dataflow)
-        swap current-effect check-effect
+        [ specialized-def (dataflow) ] keep
+        finish-word 2drop
     ] with-infer ;
 
 : (compile) ( word -- )
@@ -50,11 +50,8 @@ M: f batch-ends drop ;
     [ (compile) ] with-compiler ;
 
 : try-compile ( word -- )
-    [
-        compile
-    ] [
-        batch-errors get compile-error update-xt
-    ] recover ;
+    [ compile ]
+    [ batch-errors get compile-error update-xt ] recover ;
 
 : compile-batch ( seq -- )
     batch-errors get batch-begins
@@ -78,5 +75,3 @@ M: f batch-ends drop ;
     changed-words get [
         dup hash-keys compile-batch clear-hash
     ] when* ;
-
-[ recompile ] parse-hook set

diff --git a/library/compiler/inference/branches.factor b/library/compiler/inference/branches.factor
index f9563e5e2c59e859029e86377e40d7490e770ff7..7a39e8cc10638826f0ca29d14e92195ba1368fda 100644 (file)
--- a/library/compiler/inference/branches.factor
+++ b/library/compiler/inference/branches.factor
@@ -55,16 +55,41 @@ TUPLE: unbalanced-branches-error in out ;
     swap meta-r active-variable
     unify-effect meta-r set drop ;
 
+TUPLE: unbalanced-namestacks ;
+
+: unify-namestacks ( seq -- )
+    flip
+    [ H{ } clone [ dupd hash-update ] reduce ] map
+    meta-n set ;
+
+: namestack-effect ( seq -- )
+    #! If the namestack is unbalanced, we don't throw an error
+    meta-n active-variable
+    dup [ length ] map all-equal? [
+        <unbalanced-namestacks> inference-error
+    ] unless
+    unify-namestacks ;
+
+: unify-vars ( seq -- )
+    #! Don't use active-variable here, because we want to
+    #! consider variables set right before a throw too
+    [ inferred-vars swap hash ] map apply-var-seq ;
+
 : unify-effects ( seq -- )
-    dup datastack-effect dup callstack-effect
+    dup datastack-effect
+    dup callstack-effect
+    dup namestack-effect
+    dup unify-vars
     [ terminated? swap hash ] all? terminated? set ;
 
 : unify-dataflow ( effects -- nodes )
     [ dataflow-graph swap hash ] map ;
 
 : copy-inference ( -- )
-    meta-r [ clone ] change
     meta-d [ clone ] change
+    meta-r [ clone ] change
+    meta-n [ [ clone ] map ] change
+    inferred-vars [ clone ] change
     d-in [ ] change
     dataflow-graph off
     current-node off ;

diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
index fd4212da29ebaa9a2df231a48868ca835b019b6a..239176021794c2841917862dec838ec69a3ce3a7 100644 (file)
--- a/library/compiler/inference/dataflow.factor
+++ b/library/compiler/inference/dataflow.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference
 USING: arrays generic hashtables kernel math
-namespaces parser sequences words ;
+namespaces parser sequences words vectors ;
 
 SYMBOL: d-in
 SYMBOL: meta-d

diff --git a/library/compiler/inference/errors.factor b/library/compiler/inference/errors.factor
index 0c6a4e78b4531096924fbbc36663d85eda165bb5..c45044750e9b669cda9fcbb65852350e90e73c33 100644 (file)
--- a/library/compiler/inference/errors.factor
+++ b/library/compiler/inference/errors.factor
@@ -28,6 +28,10 @@ M: too-many-r> summary
     drop
     "Quotation pops retain stack elements which it did not push" ;
 
+M: too-many-n> summary
+    drop
+    "Quotation pops name stack elements which it did not push" ;
+
 M: no-effect error.
     "The word " write
     no-effect-word pprint

diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor
index 0e7cb7fb16a6a8f7df8c2ec919b77148335aab76..c6956cb23338becaef401a582eb76be6171e39f1 100644 (file)
--- a/library/compiler/inference/inference.factor
+++ b/library/compiler/inference/inference.factor
@@ -3,7 +3,7 @@
 IN: inference
 USING: arrays errors generic io kernel
 math namespaces parser prettyprint sequences strings
-vectors words ;
+vectors words tools ;
 
 TUPLE: inference-error rstate major? ;
 
@@ -29,17 +29,14 @@ M: object value-literal
 
 : value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
 
-: add-inputs ( n stack -- n stack )
-    tuck length - dup 0 >
+: add-inputs ( seq stack -- n stack )
+    tuck [ length ] 2apply - dup 0 >
     [ dup value-vector [ rot nappend ] keep ]
     [ drop 0 swap ] if ;
 
-: ensure-values ( n -- )
+: ensure-values ( seq -- )
     meta-d [ add-inputs ] change d-in [ + ] change ;
 
-: short-effect ( -- pair )
-    d-in get meta-d get length 2array ;
-
 SYMBOL: terminated?
 
 : current-effect ( -- effect )
@@ -50,8 +47,10 @@ SYMBOL: recorded
 
 : init-inference ( recursive-state -- )
     terminated? off
-    V{ } clone meta-r set
     V{ } clone meta-d set
+    V{ } clone meta-r set
+    V{ } clone meta-n set
+    empty-vars inferred-vars set
     0 d-in set
     recursive-state set
     dataflow-graph off
@@ -97,9 +96,11 @@ TUPLE: too-many-r> ;
     ] when ;
 
 : undo-infer ( -- )
-    recorded get
-    [ "infer" word-prop not ] subset
-    [ f "infer-effect" set-word-prop ] each ;
+    recorded get [ "infer" word-prop not ] subset [
+        dup
+        f "inferred-vars" set-word-prop
+        f "inferred-effect" set-word-prop
+    ] each ;
 
 : with-infer ( quot -- )
     [
@@ -115,8 +116,19 @@ TUPLE: too-many-r> ;
         ] recover
     ] with-scope ;
 
-: infer ( quot -- effect )
-    [ infer-quot short-effect ] with-infer ;
+: infer ( quot -- effect infer-vars )
+    [ infer-quot inferred-vars get current-effect ] with-infer ;
+
+: vars. ( seq str -- )
+    over empty? [ 2drop ] [ print [ . ] each ] if ;
+
+: infer. ( quot -- )
+    infer
+    "* Stack effect:" print effect>string print
+    dup inferred-vars-reads "* Reads free variables:" vars.
+    dup inferred-vars-writes "* Writes free variables:" vars.
+    dup inferred-vars-reads-globals "* Reads global variables:" vars.
+    inferred-vars-writes-globals "* Writes global variables:" vars. ;
 
 : (dataflow) ( quot -- dataflow )
     infer-quot f #return node, dataflow-graph get ;

diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor
index c41bcb94155e5cd8ba92c3ae2e1d229a938e8533..bba878d2bb66cace58f140bcf8b7c761ad1913fd 100644 (file)
--- a/library/compiler/inference/known-words.factor
+++ b/library/compiler/inference/known-words.factor
@@ -1,60 +1,62 @@
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: inference
 USING: arrays alien assembler errors generic hashtables
 hashtables-internals io io-internals kernel
 kernel-internals math math-internals memory parser
-sequences strings vectors words prettyprint ;
+sequences strings vectors words prettyprint namespaces ;
 
 \ declare [
     pop-literal nip
-    dup length ensure-values
+    dup ensure-values
     dup length d-tail
     swap #declare
     [ 2dup set-node-in-d set-node-out-d ] keep
     node,
 ] "infer" set-word-prop
-\ declare { object } { } <effect> "infer-effect" set-word-prop
+\ declare { object } { } <effect> "inferred-effect" set-word-prop
 
-\ fixnum< { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
+\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
 \ fixnum< t "foldable" set-word-prop
 
-\ fixnum<= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
+\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
 \ fixnum<= t "foldable" set-word-prop
 
-\ fixnum> { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
+\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
 \ fixnum> t "foldable" set-word-prop
 
-\ fixnum>= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
+\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
 \ fixnum>= t "foldable" set-word-prop
 
-\ eq? { object object } { object } <effect> "infer-effect" set-word-prop
+\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
 \ eq? t "foldable" set-word-prop
 
 ! Primitive combinators
-\ call { object } { } <effect> "infer-effect" set-word-prop
+\ call { object } { } <effect> "inferred-effect" set-word-prop
 
 \ call [ pop-literal infer-quot-value ] "infer" set-word-prop
 
-\ execute { word } { } <effect> "infer-effect" set-word-prop
+\ execute { word } { } <effect> "inferred-effect" set-word-prop
 
 \ execute [
     pop-literal unit infer-quot-value
 ] "infer" set-word-prop
 
-\ if { object object object } { } <effect> "infer-effect" set-word-prop
+\ if { object object object } { } <effect> "inferred-effect" set-word-prop
 
 \ if [
     2 #drop node, pop-d pop-d swap 2array
     #if pop-d drop infer-branches
 ] "infer" set-word-prop
 
-\ cond { object } { } <effect> "infer-effect" set-word-prop
+\ cond { object } { } <effect> "inferred-effect" set-word-prop
 
 \ cond [
     pop-literal <reversed>
     [ no-cond ] swap alist>quot infer-quot-value
 ] "infer" set-word-prop
 
-\ dispatch { fixnum array } { } <effect> "infer-effect" set-word-prop
+\ dispatch { fixnum array } { } <effect> "inferred-effect" set-word-prop
 
 \ dispatch [
     pop-literal nip [ <value> ] map
@@ -64,300 +66,352 @@ sequences strings vectors words prettyprint ;
 ! Non-standard control flow
 \ throw { object } { } <effect>
 t over set-effect-terminated?
-"infer-effect" set-word-prop
+"inferred-effect" set-word-prop
 
 ! Stack effects for all primitives
-\ rehash-string { string } { } <effect> "infer-effect" set-word-prop
+\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
 
-\ string>sbuf { string } { sbuf } <effect> "infer-effect" set-word-prop
+\ string>sbuf { string } { sbuf } <effect> "inferred-effect" set-word-prop
 
-\ bignum>fixnum { bignum } { fixnum } <effect> "infer-effect" set-word-prop
+\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ bignum>fixnum t "foldable" set-word-prop
 
-\ float>fixnum { float } { fixnum } <effect> "infer-effect" set-word-prop
+\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
 \ bignum>fixnum t "foldable" set-word-prop
 
-\ fixnum>bignum { fixnum } { bignum } <effect> "infer-effect" set-word-prop
+\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
 \ fixnum>bignum t "foldable" set-word-prop
 
-\ float>bignum { float } { bignum } <effect> "infer-effect" set-word-prop
+\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
 \ float>bignum t "foldable" set-word-prop
 
-\ fixnum>float { fixnum } { float } <effect> "infer-effect" set-word-prop
+\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
 \ fixnum>float t "foldable" set-word-prop
 
-\ bignum>float { bignum } { float } <effect> "infer-effect" set-word-prop
+\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
 \ bignum>float t "foldable" set-word-prop
 
-\ (fraction>) { integer integer } { rational } <effect> "infer-effect" set-word-prop
+\ (fraction>) { integer integer } { rational } <effect> "inferred-effect" set-word-prop
 \ (fraction>) t "foldable" set-word-prop
 
-\ string>float { string } { float } <effect> "infer-effect" set-word-prop
+\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
 \ string>float t "foldable" set-word-prop
 
-\ float>string { float } { string } <effect> "infer-effect" set-word-prop
+\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
 \ float>string t "foldable" set-word-prop
 
-\ float>bits { real } { integer } <effect> "infer-effect" set-word-prop
+\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
 \ float>bits t "foldable" set-word-prop
 
-\ double>bits { real } { integer } <effect> "infer-effect" set-word-prop
+\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
 \ double>bits t "foldable" set-word-prop
 
-\ bits>float { integer } { float } <effect> "infer-effect" set-word-prop
+\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
 \ bits>float t "foldable" set-word-prop
 
-\ bits>double { integer } { float } <effect> "infer-effect" set-word-prop
+\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
 \ bits>double t "foldable" set-word-prop
 
-\ <complex> { real real } { number } <effect> "infer-effect" set-word-prop
+\ <complex> { real real } { number } <effect> "inferred-effect" set-word-prop
 \ <complex> t "foldable" set-word-prop
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
+\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum+ t "foldable" set-word-prop
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum+fast t "foldable" set-word-prop
 
-\ fixnum- { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
+\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum- t "foldable" set-word-prop
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-fast t "foldable" set-word-prop
 
-\ fixnum* { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
+\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum* t "foldable" set-word-prop
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
+\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum/i t "foldable" set-word-prop
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-mod t "foldable" set-word-prop
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum/mod t "foldable" set-word-prop
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-bitand t "foldable" set-word-prop
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-bitor t "foldable" set-word-prop
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-bitxor t "foldable" set-word-prop
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> "infer-effect" set-word-prop
+\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
 \ fixnum-bitnot t "foldable" set-word-prop
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
+\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum-shift t "foldable" set-word-prop
 
-\ bignum= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
+\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum= t "foldable" set-word-prop
 
-\ bignum+ { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum+ t "foldable" set-word-prop
 
-\ bignum- { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum- t "foldable" set-word-prop
 
-\ bignum* { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum* t "foldable" set-word-prop
 
-\ bignum/i { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum/i t "foldable" set-word-prop
 
-\ bignum-mod { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-mod t "foldable" set-word-prop
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> "infer-effect" set-word-prop
+\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
 \ bignum/mod t "foldable" set-word-prop
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-bitand t "foldable" set-word-prop
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-bitor t "foldable" set-word-prop
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-bitxor t "foldable" set-word-prop
 
-\ bignum-bitnot { bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-bitnot t "foldable" set-word-prop
 
-\ bignum-shift { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
+\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
 \ bignum-shift t "foldable" set-word-prop
 
-\ bignum< { bignum bignum } { object } <effect> "infer-effect" set-word-prop
+\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum< t "foldable" set-word-prop
 
-\ bignum<= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
+\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum<= t "foldable" set-word-prop
 
-\ bignum> { bignum bignum } { object } <effect> "infer-effect" set-word-prop
+\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum> t "foldable" set-word-prop
 
-\ bignum>= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
+\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum>= t "foldable" set-word-prop
 
-\ float+ { float float } { float } <effect> "infer-effect" set-word-prop
+\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
 \ float+ t "foldable" set-word-prop
 
-\ float- { float float } { float } <effect> "infer-effect" set-word-prop
+\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
 \ float- t "foldable" set-word-prop
 
-\ float* { float float } { float } <effect> "infer-effect" set-word-prop
+\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
 \ float* t "foldable" set-word-prop
 
-\ float/f { float float } { float } <effect> "infer-effect" set-word-prop
+\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
 \ float/f t "foldable" set-word-prop
 
-\ float< { float float } { object } <effect> "infer-effect" set-word-prop
+\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
 \ float< t "foldable" set-word-prop
 
-\ float-mod { float float } { float } <effect> "infer-effect" set-word-prop
+\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
 \ float-mod t "foldable" set-word-prop
 
-\ float<= { float float } { object } <effect> "infer-effect" set-word-prop
+\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
 \ float<= t "foldable" set-word-prop
 
-\ float> { float float } { object } <effect> "infer-effect" set-word-prop
+\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
 \ float> t "foldable" set-word-prop
 
-\ float>= { float float } { object } <effect> "infer-effect" set-word-prop
+\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
 \ float>= t "foldable" set-word-prop
 
-\ (word) { object object } { word } <effect> "infer-effect" set-word-prop
+\ (word) { object object } { word } <effect> "inferred-effect" set-word-prop
 
-\ update-xt { word } { } <effect> "infer-effect" set-word-prop
+\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
 
-\ word-xt { word } { integer } <effect> "infer-effect" set-word-prop
+\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
 
-\ getenv { fixnum } { object } <effect> "infer-effect" set-word-prop
-\ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
-\ stat { string } { object object object object } <effect> "infer-effect" set-word-prop
-\ (directory) { string } { array } <effect> "infer-effect" set-word-prop
-\ data-gc { integer } { } <effect> "infer-effect" set-word-prop
+\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
+\ stat { string } { object object object object } <effect> "inferred-effect" set-word-prop
+\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
+\ data-gc { integer } { } <effect> "inferred-effect" set-word-prop
 
 ! code-gc does not declare a stack effect since it might be
 ! called from a compiled word which becomes unreachable during
 ! the course of its execution, resulting in a crash
 
-\ gc-time { } { integer } <effect> "infer-effect" set-word-prop
-\ save-image { string } { } <effect> "infer-effect" set-word-prop
-\ exit { integer } { } <effect> "infer-effect" set-word-prop
-\ data-room { } { integer integer array } <effect> "infer-effect" set-word-prop
-\ code-room { } { integer integer } <effect> "infer-effect" set-word-prop
-\ os-env { string } { object } <effect> "infer-effect" set-word-prop
-\ millis { } { integer } <effect> "infer-effect" set-word-prop
+\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
+\ save-image { string } { } <effect> "inferred-effect" set-word-prop
+\ exit { integer } { } <effect> "inferred-effect" set-word-prop
+\ data-room { } { integer integer array } <effect> "inferred-effect" set-word-prop
+\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
+\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
+\ millis { } { integer } <effect> "inferred-effect" set-word-prop
 
-\ type { object } { fixnum } <effect> "infer-effect" set-word-prop
+\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
 \ type t "foldable" set-word-prop
 
-\ tag { object } { fixnum } <effect> "infer-effect" set-word-prop
+\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
 \ tag t "foldable" set-word-prop
 
-\ cwd { } { string } <effect> "infer-effect" set-word-prop
-\ cd { string } { } <effect> "infer-effect" set-word-prop
+\ cwd { } { string } <effect> "inferred-effect" set-word-prop
+\ cd { string } { } <effect> "inferred-effect" set-word-prop
 
-\ dlopen { string } { dll } <effect> "infer-effect" set-word-prop
-\ dlsym { string object } { integer } <effect> "infer-effect" set-word-prop
-\ dlclose { dll } { } <effect> "infer-effect" set-word-prop
+\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
+\ dlsym { string object } { integer } <effect> "inferred-effect" set-word-prop
+\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
 
-\ <byte-array> { integer } { byte-array } <effect> "infer-effect" set-word-prop
+\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "infer-effect" set-word-prop
+\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-signed-2 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-signed-1 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
+\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
+\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-float { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
+\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
 
-\ set-alien-double { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-double { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
+\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
 
-\ alien>char-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
+\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
 
-\ string>char-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
+\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
 
-\ alien>u16-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
+\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
 
-\ string>u16-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
+\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
 
-\ string>memory { string integer } { } <effect> "infer-effect" set-word-prop
-\ memory>string { integer integer } { string } <effect> "infer-effect" set-word-prop
+\ string>memory { string integer } { } <effect> "inferred-effect" set-word-prop
+\ memory>string { integer integer } { string } <effect> "inferred-effect" set-word-prop
 
-\ alien-address { alien } { integer } <effect> "infer-effect" set-word-prop
+\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
 
-\ slot { object fixnum } { object } <effect> "infer-effect" set-word-prop
+\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
 
-\ set-slot { object object fixnum } { } <effect> "infer-effect" set-word-prop
+\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
 
-\ char-slot { fixnum object } { fixnum } <effect> "infer-effect" set-word-prop
+\ char-slot { fixnum object } { fixnum } <effect> "inferred-effect" set-word-prop
 
-\ set-char-slot { fixnum fixnum object } { } <effect> "infer-effect" set-word-prop
-\ resize-array { integer array } { array } <effect> "infer-effect" set-word-prop
-\ resize-string { integer string } { string } <effect> "infer-effect" set-word-prop
+\ set-char-slot { fixnum fixnum object } { } <effect> "inferred-effect" set-word-prop
+\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
+\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
 
-\ (hashtable) { } { hashtable } <effect> "infer-effect" set-word-prop
+\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
 
-\ <array> { integer object } { array } <effect> "infer-effect" set-word-prop
+\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
 
-\ begin-scan { } { } <effect> "infer-effect" set-word-prop
-\ next-object { } { object } <effect> "infer-effect" set-word-prop
-\ end-scan { } { } <effect> "infer-effect" set-word-prop
+\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
+\ next-object { } { object } <effect> "inferred-effect" set-word-prop
+\ end-scan { } { } <effect> "inferred-effect" set-word-prop
 
-\ size { object } { fixnum } <effect> "infer-effect" set-word-prop
+\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
 
-\ die { } { } <effect> "infer-effect" set-word-prop
-\ fopen { string string } { alien } <effect> "infer-effect" set-word-prop
-\ fgetc { alien } { object } <effect> "infer-effect" set-word-prop
-\ fwrite { string alien } { } <effect> "infer-effect" set-word-prop
-\ fflush { alien } { } <effect> "infer-effect" set-word-prop
-\ fclose { alien } { } <effect> "infer-effect" set-word-prop
-\ expired? { object } { object } <effect> "infer-effect" set-word-prop
+\ die { } { } <effect> "inferred-effect" set-word-prop
+\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
+\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
+\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
+\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
+\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
+\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
 
-\ <wrapper> { object } { wrapper } <effect> "infer-effect" set-word-prop
+\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
 \ <wrapper> t "foldable" set-word-prop
 
-\ (clone) { object } { object } <effect> "infer-effect" set-word-prop
+\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
 
-\ become { object fixnum } { object } <effect> "infer-effect" set-word-prop
+\ become { object fixnum } { object } <effect> "inferred-effect" set-word-prop
 
-\ array>vector { array } { vector } <effect> "infer-effect" set-word-prop
+\ array>vector { array } { vector } <effect> "inferred-effect" set-word-prop
 
-\ finalize-compile { array } { } <effect> "infer-effect" set-word-prop
+\ finalize-compile { array } { } <effect> "inferred-effect" set-word-prop
 
-\ <string> { integer integer } { string } <effect> "infer-effect" set-word-prop
+\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
 
-\ <quotation> { integer } { quotation } <effect> "infer-effect" set-word-prop
+\ <quotation> { integer } { quotation } <effect> "inferred-effect" set-word-prop
+
+! Dynamic scope inference
+: if-tos-literal ( quot -- )
+    peek-d dup value? [ value-literal swap call ] [ 2drop ] if ;
+    inline
+
+\ >n [ H{ } clone push-n ] "infer-vars" set-word-prop
+
+\ >n { object } { } <effect> "inferred-effect" set-word-prop
+
+TUPLE: too-many-n> ;
+
+: apply-n> ( -- )
+    meta-n get empty? [
+        <too-many-n>> inference-error
+    ] [
+        pop-n drop
+    ] if ;
+
+\ n> [ apply-n> ] "infer-vars" set-word-prop
+
+\ n> { } { object } <effect> "inferred-effect" set-word-prop
+
+\ ndrop [ apply-n> ] "infer-vars" set-word-prop
+
+\ ndrop { } { } <effect> "inferred-effect" set-word-prop
+
+\ get [
+    [ apply-var-read ] if-tos-literal
+] "infer-vars" set-word-prop
+
+\ get { object } { object } <effect> "inferred-effect" set-word-prop
+
+\ set [
+    [ apply-var-write ] if-tos-literal
+] "infer-vars" set-word-prop
+
+\ set { object object } { } <effect> "inferred-effect" set-word-prop
+
+\ get-global [
+    [ apply-global-read ]
+    if-tos-literal
+] "infer-vars" set-word-prop
+
+\ get-global { object } { object } <effect> "inferred-effect" set-word-prop
+
+\ set-global [
+    [ apply-global-write ]
+    if-tos-literal
+] "infer-vars" set-word-prop
+
+\ set-global { object object } { } <effect> "inferred-effect" set-word-prop

diff --git a/library/compiler/inference/stack.factor b/library/compiler/inference/stack.factor
index d0958ac9f9c02318ec78af1688fc569b34d31578..574ee104b45de1997d1ebd2b53fd86ce8647d873 100644 (file)
--- a/library/compiler/inference/stack.factor
+++ b/library/compiler/inference/stack.factor
@@ -18,7 +18,7 @@ sequences words parser words ;
     infer-shuffle-outputs ;
 
 : define-shuffle ( word shuffle -- )
-    [ "infer-effect" set-word-prop ] 2keep
+    [ "inferred-effect" set-word-prop ] 2keep
     [ infer-shuffle ] curry "infer" set-word-prop ;
 
 {
@@ -47,7 +47,7 @@ sequences words parser words ;
     0 1 rot node-outputs
 ] "infer" set-word-prop
 
-\ >r { object } { } <effect> "infer-effect" set-word-prop
+\ >r { object } { } <effect> "inferred-effect" set-word-prop
 
 \ r> [
     check-r>
@@ -57,4 +57,4 @@ sequences words parser words ;
     1 0 rot node-outputs
 ] "infer" set-word-prop
 
-\ r> { } { object } <effect> "infer-effect" set-word-prop
+\ r> { } { object } <effect> "inferred-effect" set-word-prop

diff --git a/library/compiler/inference/variables.factor b/library/compiler/inference/variables.factor
new file mode 100644 (file)
index 0000000..313e799
--- /dev/null
+++ b/library/compiler/inference/variables.factor
@@ -0,0 +1,54 @@
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inference
+USING: kernel sequences hashtables kernel-internals words
+namespaces generic vectors namespaces ;
+
+! Name stack and variable binding simulation
+SYMBOL: meta-n
+
+: push-n meta-n get push ;
+: pop-n meta-n get pop ;
+: peek-n meta-n get peek ;
+
+TUPLE: inferred-vars reads writes reads-globals writes-globals ;
+
+: vars-trivial? ( vars -- ? ) tuple-slots [ empty? ] all? ;
+
+: empty-vars ( -- vars )
+    V{ } clone V{ } clone V{ } clone V{ } clone
+    <inferred-vars> ;
+
+: apply-var-seq ( seq -- )
+    inferred-vars [
+        >r [ tuple-slots ] map r> tuple-slots add flip
+        [ concat prune >vector ] map first4 <inferred-vars>
+    ] change ;
+    
+: apply-var-read ( symbol -- )
+    dup meta-n get [ hash-member? ] contains-with? [
+        drop
+    ] [
+        inferred-vars get inferred-vars-reads push-new
+    ] if ;
+    
+: apply-var-write ( symbol -- )
+    meta-n get empty? [
+        inferred-vars get inferred-vars-writes push-new
+    ] [
+        dup peek-n set-hash
+    ] if ;
+
+: apply-global-read ( symbol -- )
+    inferred-vars get inferred-vars-reads-globals push-new ;
+
+: apply-global-write ( symbol -- )
+    inferred-vars get inferred-vars-writes-globals push-new ;
+
+: apply-vars ( vars -- )
+    [
+        dup inferred-vars-reads [ apply-var-read ] each
+        dup inferred-vars-writes [ apply-var-write ] each
+        dup inferred-vars-reads-globals [ apply-global-read ] each
+        inferred-vars-writes-globals [ apply-global-write ] each
+    ] when* ;

diff --git a/library/compiler/inference/words.factor b/library/compiler/inference/words.factor
index 667b9e74398a1bf96010b829bf7e843bc9fd8ffb..4cf0a69fe31ace73ef220d76664c78108a230768 100644 (file)
--- a/library/compiler/inference/words.factor
+++ b/library/compiler/inference/words.factor
@@ -5,29 +5,32 @@ math math-internals namespaces parser prettyprint sequences
 strings vectors words ;
 IN: inference
 
-: consume-values ( n node -- )
+: consume-values ( seq node -- )
+    >r length r>
     over ensure-values
     over 0 rot node-inputs
     meta-d get [ length swap - ] keep set-length ;
 
-: produce-values ( n node -- )
+: produce-values ( seq node -- )
     >r [ drop <computed> ] map dup r> set-node-out-d
     meta-d get swap nappend ;
 
 : recursing? ( word -- label/f )
     recursive-state get <reversed> assoc ;
 
+: if-inline ( word true false -- )
+    >r >r dup "inline" word-prop r> r> if ; inline
+
 : make-call-node ( word -- node )
-    dup "inline" word-prop
     [ dup recursing? [ #call-label ] [ #call ] ?if ]
     [ #call ]
-    if ;
+    if-inline ;
 
-: consume/produce ( word effect -- )
+: consume/produce ( effect word -- )
     meta-d get clone >r
     swap make-call-node dup node,
-    over effect-in length over consume-values
-    over effect-out length over produce-values
+    over effect-in over consume-values
+    over effect-out over produce-values
     r> over #call-label? [ swap set-node-in-d ] [ 2drop ] if
     effect-terminated? [ terminate ] when ;
 
@@ -45,7 +48,7 @@ TUPLE: no-effect word ;
 : add-recursive-state ( word label -- )
     2array recursive-state [ swap add ] change ;
 
-: inline-block ( word -- node-block variables )
+: inline-block ( word -- node-block data )
     [
         copy-inference nest-node
         gensym 2dup add-recursive-state
@@ -87,15 +90,14 @@ M: #call-label collect-recursion*
         apply-infer node-child node-successor splice-node drop
     ] if ;
 
-: infer-compound ( word -- effect )
+: infer-compound ( word -- hash )
     [
-        recursive-state get init-inference
-        [ inline-block nip [ current-effect ] bind ] keep
-    ] with-scope over consume/produce ;
+        recursive-state get init-inference inline-block nip
+    ] with-scope ;
 
-GENERIC: apply-word
+GENERIC: infer-word ( word -- effect data )
 
-M: object apply-word no-effect ;
+M: word infer-word no-effect ;
 
 TUPLE: effect-error word effect ;
 
@@ -104,57 +106,76 @@ TUPLE: effect-error word effect ;
 
 : check-effect ( word effect -- )
     over "infer" word-prop [
-        2drop
-    ] [
         over recorded get push
-        dup pick "declared-effect" word-prop dup
-        [ effect<= [ effect-error ] unless ] [ 2drop ] if
-        "infer-effect" set-word-prop
-    ] if ;
-
-M: compound apply-word
-    [
-        dup infer-compound check-effect
-    ] [
-        swap t "no-effect" set-word-prop rethrow
-    ] recover ;
-
-: ?no-effect ( word -- )
-    dup "no-effect" word-prop [ no-effect ] [ drop ] if ;
-
-: apply-default ( word -- )
-    dup ?no-effect
-    dup "infer-effect" word-prop [
-        over "infer" word-prop [
-            swap effect-in length ensure-values call drop
-        ] [
-            consume/produce
-        ] if*
-    ] [
-        apply-word
-    ] if* ;
-
-M: word apply-object apply-default ;
+        over "declared-effect" word-prop 2dup
+        [ swap effect<= [ effect-error ] unless ] [ 2drop ] if
+    ] unless 2drop ;
+
+: save-inferred-data ( word effect vars -- )
+    >r over r>
+    dup vars-trivial? [ drop f ] when
+    "inferred-vars" set-word-prop
+    "inferred-effect" set-word-prop ;
+
+: finish-word ( word -- effect vars )
+    current-effect 2dup check-effect
+    inferred-vars get
+    [ save-inferred-data ] 2keep ;
+
+M: compound infer-word
+    [ dup infer-compound [ finish-word ] bind ]
+    [ swap t "no-effect" set-word-prop rethrow ] recover ;
+
+: custom-infer ( word -- )
+    #! Customized inference behavior
+    dup "inferred-vars" word-prop apply-vars
+    dup "inferred-effect" word-prop effect-in ensure-values
+    "infer" word-prop call ;
+
+: apply-effect/vars ( word effect vars -- )
+    apply-vars consume/produce ;
+
+: cached-infer ( word -- )
+    dup "inferred-effect" word-prop
+    over "inferred-vars" word-prop
+    apply-effect/vars ;
+
+: apply-word ( word -- )
+    {
+        { [ dup "no-effect" word-prop ] [ no-effect ] }
+        { [ dup "infer" word-prop ] [ custom-infer ] }
+        { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
+        { [ t ] [ dup infer-word apply-effect/vars ] }
+    } cond ;
+
+M: word apply-object apply-word ;
 
 M: symbol apply-object apply-literal ;
 
 TUPLE: recursive-declare-error word ;
 
-: recursive-effect ( word -- effect )
-    dup stack-effect
-    [ ] [ <recursive-declare-error> inference-error ] ?if ;
+: declared-infer ( word -- )
+    dup stack-effect [
+        consume/produce
+    ] [
+        <recursive-declare-error> inference-error
+    ] if* ;
 
-M: compound apply-object
-    dup "inline" word-prop [
-        dup recursive-state get peek first eq? [
-            dup recursive-effect consume/produce
-        ] [
-            inline-closure
-        ] if
+: apply-inline ( word -- )
+    dup recursive-state get peek first eq?
+    [ declared-infer ] [ inline-closure ] if ;
+
+: apply-compound ( word -- )
+    dup recursing? [ declared-infer ] [ apply-word ] if ;
+
+: custom-infer-vars ( word -- )
+    dup "infer-vars" word-prop dup [
+        swap "inferred-effect" word-prop effect-in ensure-values
+        call
     ] [
-        dup recursing? [
-            dup recursive-effect consume/produce
-        ] [
-            apply-default
-        ] if
+        2drop
     ] if ;
+
+M: compound apply-object
+    dup custom-infer-vars
+    [ apply-inline ] [ apply-compound ] if-inline ;

diff --git a/library/compiler/load.factor b/library/compiler/load.factor
index 07d555d00ea6e3f403c73f98ad5166b17dba5071..57392a0e0c954374ded8e3b6738597e8f29ffef3 100644 (file)
--- a/library/compiler/load.factor
+++ b/library/compiler/load.factor
@@ -2,6 +2,7 @@ PROVIDE: library/compiler
 { +files+ {
     "inference/shuffle.factor"
     "inference/dataflow.factor"
+    "inference/variables.factor"
     "inference/inference.factor"
     "inference/branches.factor"
     "inference/words.factor"

diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 900621ff6008f2bffb2c7bafa29a216f54e5d419..37f81282bd73bc1ec5d317e607733c3d9405e087 100644 (file)
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -119,7 +119,7 @@ M: node child-ties
     dup node-param "output-classes" word-prop [
         call
     ] [
-        node-param "infer-effect" word-prop effect-out
+        node-param "inferred-effect" word-prop effect-out
         dup [ word? ] all? [ drop f ] unless
     ] if* ;
 

diff --git a/library/compiler/test/inference.factor b/library/compiler/test/inference.factor
index 9391b7eee449febca1dca8883f5d443e076a2f45..29b127a1a3349e00abfb06d9af4a5fbe130a96a9 100644 (file)
--- a/library/compiler/test/inference.factor
+++ b/library/compiler/test/inference.factor
@@ -3,6 +3,9 @@ math math-internals namespaces parser sequences strings test
 vectors words ;
 IN: temporary
 
+: short-effect
+    dup effect-in length swap effect-out length 2array nip ;
+
 [ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
 
 [ t ] [ [ ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
@@ -11,20 +14,20 @@ IN: temporary
 
 [ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
 
-[ { 0 0 } ] [ f infer ] unit-test
-[ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test
-[ { 1 2 } ] [ [ dup ] infer ] unit-test
+[ { 0 0 } ] [ f infer short-effect ] unit-test
+[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test
+[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test
 
-[ { 1 2 } ] [ [ [ dup ] call ] infer ] unit-test
-[ [ call ] infer ] unit-test-fails
+[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test
+[ [ call ] infer short-effect ] unit-test-fails
 
-[ { 2 4 } ] [ [ 2dup ] infer ] unit-test
+[ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test
 
-[ { 1 0 } ] [ [ [ ] [ ] if ] infer ] unit-test
-[ [ if ] infer ] unit-test-fails
-[ [ [ ] if ] infer ] unit-test-fails
-[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
-[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer ] unit-test
+[ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test
+[ [ if ] infer short-effect ] unit-test-fails
+[ [ [ ] if ] infer short-effect ] unit-test-fails
+[ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails
+[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test
 
 [ { 4 3 } ] [
     [
@@ -33,18 +36,18 @@ IN: temporary
         ] [
             -rot
         ] if
-    ] infer
+    ] infer short-effect
 ] unit-test
 
-[ { 1 1 } ] [ [ dup [ ] when ] infer ] unit-test
-[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
-[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer ] unit-test
+[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test
 
-[ { 1 0 } ] [ [ [ drop ] when* ] infer ] unit-test
-[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
+[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test
 
 [ { 0 1 } ] [
-    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer
+    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect
 ] unit-test
 
 [
@@ -57,37 +60,37 @@ IN: temporary
 
 : termination-test-2 [ termination-test-1 ] [ 3 ] if ;
 
-[ { 1 1 } ] [ [ termination-test-2 ] infer ] unit-test
+[ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test
 
 : infinite-loop infinite-loop ;
 
-[ [ infinite-loop ] infer ] unit-test-fails
+[ [ infinite-loop ] infer short-effect ] unit-test-fails
 
 : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] unit-test-fails
+[ [ no-base-case-1 ] infer short-effect ] unit-test-fails
 
 : simple-recursion-1 ( obj -- obj )
     dup [ simple-recursion-1 ] [ ] if ;
 
-[ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test
+[ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test
 
 : simple-recursion-2 ( obj -- obj )
     dup [ ] [ simple-recursion-2 ] if ;
 
-[ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test
+[ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test
 
 : bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
 
-[ [ bad-recursion-2 ] infer ] unit-test-fails
+[ [ bad-recursion-2 ] infer short-effect ] unit-test-fails
 
 : funny-recursion ( obj -- obj )
     dup [ funny-recursion 1 ] [ 2 ] if drop ;
 
-[ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test
+[ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test
 
 ! Simple combinators
-[ { 1 2 } ] [ [ [ first ] keep second ] infer ] unit-test
+[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test
 
 ! Mutual recursion
 DEFER: foe
@@ -110,8 +113,8 @@ DEFER: foe
         2drop f
     ] if ;
 
-[ { 2 1 } ] [ [ fie ] infer ] unit-test
-[ { 2 1 } ] [ [ foe ] infer ] unit-test
+[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test
 
 : nested-when ( -- )
     t [
@@ -120,7 +123,7 @@ DEFER: foe
         ] when
     ] when ;
 
-[ { 0 0 } ] [ [ nested-when ] infer ] unit-test
+[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test
 
 : nested-when* ( obj -- )
     [
@@ -129,11 +132,11 @@ DEFER: foe
         ] when*
     ] when* ;
 
-[ { 1 0 } ] [ [ nested-when* ] infer ] unit-test
+[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test
 
 SYMBOL: sym-test
 
-[ { 0 1 } ] [ [ sym-test ] infer ] unit-test
+[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test
 
 : terminator-branch
     dup [
@@ -142,7 +145,7 @@ SYMBOL: sym-test
         "foo" throw
     ] if ;
 
-[ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test
+[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test
 
 : recursive-terminator ( obj -- )
     dup [
@@ -151,12 +154,12 @@ SYMBOL: sym-test
         "Hi" throw
     ] if ;
 
-[ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test
+[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test
 
 GENERIC: potential-hang ( obj -- obj )
 M: fixnum potential-hang dup [ potential-hang ] when ;
 
-[ ] [ [ 5 potential-hang ] infer drop ] unit-test
+[ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test
 
 TUPLE: funny-cons car cdr ;
 GENERIC: iterate ( obj -- )
@@ -164,24 +167,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
-[ { 1 0 } ] [ [ iterate ] infer ] unit-test
+[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test
 
 ! Regression
 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
-[ { 3 0 } ] [ [ dog ] infer ] unit-test
+[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test
 
 ! Regression
 DEFER: monkey
 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
-[ { 3 0 } ] [ [ friend ] infer ] unit-test
+[ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test
 
-! Regression -- same as above but we infer the second word first
+! Regression -- same as above but we infer short-effect the second word first
 DEFER: blah2
 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
-[ { 3 0 } ] [ [ blah2 ] infer ] unit-test
+[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test
 
 ! Regression
 DEFER: blah4
@@ -189,7 +192,7 @@ DEFER: blah4
     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 : blah4 ( a b c -- )
     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
-[ { 3 0 } ] [ [ blah4 ] infer ] unit-test
+[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test
 
 ! Regression
 : bad-combinator ( obj quot -- )
@@ -199,14 +202,14 @@ DEFER: blah4
         [ swap slip ] keep swap bad-combinator
     ] if ; inline
 
-[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
+[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails
 
 ! Regression
 : bad-input#
     dup string? [ 2array throw ] unless
     over string? [ 2array throw ] unless ;
 
-[ { 2 2 } ] [ [ bad-input# ] infer ] unit-test
+[ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test
 
 ! Regression
 
@@ -214,18 +217,18 @@ DEFER: blah4
 DEFER: do-crap
 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer ] unit-test-fails
+[ [ do-crap ] infer short-effect ] unit-test-fails
 
 ! This one does not
 DEFER: do-crap*
 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer ] unit-test-fails
+[ [ do-crap* ] infer short-effect ] unit-test-fails
 
 ! Regression
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
-[ { 2 1 } ] [ [ too-deep ] infer ] unit-test
+[ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test
 
 ! Error reporting is wrong
 G: xyz math-combination ;
@@ -233,7 +236,7 @@ M: fixnum xyz 2array ;
 M: ratio xyz 
     [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
 
-[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
+[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
 
 ! Doug Coleman discovered this one while working on the
 ! calendar library
@@ -265,17 +268,17 @@ DEFER: C
         [ dup B C ]
     } dispatch ;
 
-[ { 1 0 } ] [ [ A ] infer ] unit-test
-[ { 1 0 } ] [ [ B ] infer ] unit-test
-[ { 1 0 } ] [ [ C ] infer ] unit-test
+[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test
+[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test
+[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test
 
 ! I found this bug by thinking hard about the previous one
 DEFER: Y
 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 : Y ( a b -- c d ) X ;
 
-[ { 2 2 } ] [ [ X ] infer ] unit-test
-[ { 2 2 } ] [ [ Y ] infer ] unit-test
+[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test
+[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test
 
 ! This one comes from UI code
 DEFER: #1
@@ -284,68 +287,92 @@ DEFER: #1
 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
 
-[ \ #4 word-def infer ] unit-test-fails
-[ [ #1 ] infer ] unit-test-fails
+[ \ #4 word-def infer short-effect ] unit-test-fails
+[ [ #1 ] infer short-effect ] unit-test-fails
 
 ! Similar
 DEFER: bar
 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 
-[ [ foo ] infer ] unit-test-fails
+[ [ foo ] infer short-effect ] unit-test-fails
 
-[ 1234 infer ] unit-test-fails
+[ 1234 infer short-effect ] unit-test-fails
 
 ! This used to hang
-[ [ [ dup call ] dup call ] infer ] unit-test-fails
+[ [ [ dup call ] dup call ] infer short-effect ] unit-test-fails
 
 ! This form should not have a stack effect
 
 : bad-recursion-1 ( a -- b )
     dup [ drop bad-recursion-1 5 ] [ ] if ;
 
-[ [ bad-recursion-1 ] infer ] unit-test-fails
+[ [ bad-recursion-1 ] infer short-effect ] unit-test-fails
 
 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer ] unit-test-fails
+[ [ bad-bin ] infer short-effect ] unit-test-fails
 
-[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
+[ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test
 
 ! Test some random library words
 
-[ { 1 1 } ] [ [ unit ] infer ] unit-test
-
-[ { 1 0 } ] [ [ >n ] infer ] unit-test
-[ { 0 1 } ] [ [ n> ] infer ] unit-test
-
-[ { 2 1 } ] [ [ bitor ] infer ] unit-test
-[ { 2 1 } ] [ [ bitand ] infer ] unit-test
-[ { 2 1 } ] [ [ bitxor ] infer ] unit-test
-[ { 2 1 } ] [ [ mod ] infer ] unit-test
-[ { 2 1 } ] [ [ /i ] infer ] unit-test
-[ { 2 1 } ] [ [ /f ] infer ] unit-test
-[ { 2 2 } ] [ [ /mod ] infer ] unit-test
-[ { 2 1 } ] [ [ + ] infer ] unit-test
-[ { 2 1 } ] [ [ - ] infer ] unit-test
-[ { 2 1 } ] [ [ * ] infer ] unit-test
-[ { 2 1 } ] [ [ / ] infer ] unit-test
-[ { 2 1 } ] [ [ < ] infer ] unit-test
-[ { 2 1 } ] [ [ <= ] infer ] unit-test
-[ { 2 1 } ] [ [ > ] infer ] unit-test
-[ { 2 1 } ] [ [ >= ] infer ] unit-test
-[ { 2 1 } ] [ [ number= ] infer ] unit-test
-
-[ { 1 1 } ] [ [ string>number ] infer ] unit-test
-[ { 2 1 } ] [ [ = ] infer ] unit-test
-[ { 1 1 } ] [ [ get ] infer ] unit-test
-
-[ { 2 0 } ] [ [ push ] infer ] unit-test
-[ { 2 0 } ] [ [ set-length ] infer ] unit-test
-[ { 2 1 } ] [ [ append ] infer ] unit-test
-[ { 1 1 } ] [ [ peek ] infer ] unit-test
-
-[ { 1 1 } ] [ [ length ] infer ] unit-test
-[ { 1 1 } ] [ [ reverse ] infer ] unit-test
-[ { 2 1 } ] [ [ member? ] infer ] unit-test
-[ { 2 1 } ] [ [ remove ] infer ] unit-test
-[ { 1 1 } ] [ [ natural-sort ] infer ] unit-test
+[ { 1 1 } ] [ [ unit ] infer short-effect ] unit-test
+
+! Unbalanced >n/n> is an error now!
+! [ { 1 0 } ] [ [ >n ] infer short-effect ] unit-test
+! [ { 0 1 } ] [ [ n> ] infer short-effect ] unit-test
+
+[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test
+[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test
+
+[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test
+
+[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test
+[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test
+
+[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test
+[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test
+[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test
+
+! Test scope inference
+SYMBOL: x
+
+[ [ n> ] infer ] unit-test-fails
+[ [ ndrop ] infer ] unit-test-fails
+[ V{ x } ] [ [ x get ] infer drop inferred-vars-reads ] unit-test
+[ V{ x } ] [ [ x set ] infer drop inferred-vars-writes ] unit-test
+[ V{ x } ] [ [ [ x get ] with-scope ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ [ x set ] with-scope ] infer drop inferred-vars-writes ] unit-test
+[ V{ x } ] [ [ [ x get ] bind ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ [ x set ] bind ] infer drop inferred-vars-writes ] unit-test
+[ V{ x } ] [ [ [ x get ] make-hash ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ [ x set ] make-hash ] infer drop inferred-vars-writes ] unit-test
+[ V{ building } ] [ [ , ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ [ 3 , ] { } make ] infer drop inferred-vars-reads ] unit-test
+[ V{ x } ] [ [ [ x get ] [ 5 ] if ] infer drop inferred-vars-reads ] unit-test
+[ V{ x } ] [ [ >n [ x get ] [ 5 ] if n> ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ >n [ x set ] [ drop ] if x get n> ] infer drop inferred-vars-reads ] unit-test
+[ V{ x } ] [ [ >n x get ndrop ] infer drop inferred-vars-reads ] unit-test
+[ V{ } ] [ [ >n x set ndrop ] infer drop inferred-vars-writes ] unit-test
+
+[ [ >n ] [ ] if ] unit-test-fails

diff --git a/library/effects.factor b/library/effects.factor
index 2e3741b32eb654f18ab1b386cbc085645142db16..da7cbd01ff2e93f8acc9d081e56bcb8f0c9ee5a4 100644 (file)
--- a/library/effects.factor
+++ b/library/effects.factor
@@ -44,7 +44,7 @@ C: effect
 
 : stack-effect ( word -- effect/f )
     dup "declared-effect" word-prop [ ] [
-        dup "infer-effect" word-prop [ ] [ drop f ] ?if
+        dup "inferred-effect" word-prop [ ] [ drop f ] ?if
     ] ?if ;
 
 M: effect clone

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index 68506088fcfbc9823e7eb5a34226c99ab65990ad..dcca8a251f6a0f5efa21a2ef3dfe82abfd90ada1 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -34,7 +34,9 @@ SYMBOL: restarts
     error-continuation get continuation-name hash-stack ;
 
 : :res ( n -- )
-    restarts get nth first3 continue-with ;
+    restarts get-global nth
+    f restarts set-global
+    first3 continue-with ;
 
 : :edit ( -- )
     error get

diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor
index e6d49b20843ab0b3e531a7b028bf70db969b6b76..4291ea25561c22c87c1e3ae0b953b5b97011a109 100644 (file)
--- a/library/ui/hierarchy.factor
+++ b/library/ui/hierarchy.factor
@@ -75,7 +75,7 @@ M: gadget ungraft* drop ;
 : build-spec ( spec quot -- )
     swap (build-spec) call ;
 
-\ build-spec 2 0 <effect> "infer-effect" set-word-prop
+\ build-spec 2 0 <effect> "inferred-effect" set-word-prop
 
 \ build-spec [
     pop-literal pop-literal nip (build-spec) infer-quot-value

diff --git a/library/words.factor b/library/words.factor
index e9f823c39cc1ea154ca1b7a012ef91a249d71174..82c2b4cce63ce6748d3bf38b524988059b955fd5 100644 (file)
--- a/library/words.factor
+++ b/library/words.factor
@@ -85,8 +85,10 @@ SYMBOL: crossref
         { [ dup "infer" word-prop ] [ drop ] }
         { [ t ] [
             dup changed-word
-            { "infer-effect" "base-case" "no-effect" }
-            reset-props
+            {
+                "inferred-effect" "inferred-vars"
+                "base-case" "no-effect"
+            } reset-props
         ] }
     } cond ;