some experiments with type inference

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index ebb3cf9e84990acdc52c14a190943e0d39465795..fd643a95b24f1421e8485f1ec26563fb51286a9f 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -103,19 +103,36 @@ USE: prettyprint
 : unify-effects ( list -- )
     filter-terminators  dup datastack-effect callstack-effect ;
 
+SYMBOL: cloned
+
 : deep-clone ( vector -- vector )
+    #! Clone a vector if it hasn't already been cloned in this
+    #! with-deep-clone scope.
+    dup cloned get assoc dup [
+        nip
+    ] [
+        drop vector-clone [ dup cloned [ acons ] change ] keep
+    ] ifte ;
+
+: deep-clone-vector ( vector -- vector )
     #! Clone a vector of vectors.
-    [ vector-clone ] vector-map ;
+    [ ( deep-clone ) vector-clone ] vector-map ;
+
+: copy-inference ( -- )
+    #! We avoid cloning the same object more than once in order
+    #! to preserve identity structure.
+    cloned off
+    meta-r [ deep-clone-vector ] change
+    meta-d [ deep-clone-vector ] change
+    d-in [ deep-clone-vector ] change
+    dataflow-graph off ;
 
 : infer-branch ( value save-effect -- namespace )
     <namespace> [
         save-effect set
         uncons [ unswons [ \ value-class set ] bind ] when*
         dup value-recursion recursive-state set
-        meta-r [ deep-clone ] change
-        meta-d [ deep-clone ] change
-        d-in [ deep-clone ] change
-        dataflow-graph off
+        copy-inference
         literal-value infer-quot
         #values values-node
     ] extend ;
@@ -202,11 +219,11 @@ SYMBOL: dual-recursive-state
     [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap
-    peek-d literal? [
-        static-ifte
-    ] [
-        dynamic-ifte
-    ] ifte ;
+!    peek-d literal? [
+!        static-ifte
+!    ] [
+        dynamic-ifte ;
+!    ] ifte ;
 
 \ ifte [ infer-ifte ] "infer" set-word-property
 

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index 9138c4a61d0071e12ce77a980b0d5ed63fccb7de..d19ee27022e117f47f5eb2d5ffefd717020c62f5 100644 (file)
--- a/library/inference/inference.factor
+++ b/library/inference/inference.factor
@@ -197,7 +197,8 @@ DEFER: apply-word
     #! Set the base case of the current word.
     dup [
         car cdr [
-            entry-effect get swap decompose base-case set
+            entry-effect get swap decompose
+            base-case set
         ] bind
     ] [
         2drop

diff --git a/library/inference/words.factor b/library/inference/words.factor
index 44e5a87b546ddb04284b649699450b995bf7dcae..3e120607b59cbc767607828ef0c61f57a4f29c6c 100644 (file)
--- a/library/inference/words.factor
+++ b/library/inference/words.factor
@@ -38,6 +38,7 @@ USE: vectors
 USE: words
 USE: hashtables
 USE: parser
+USE: prettyprint
 
 : with-dataflow ( param op [ intypes outtypes ] quot -- )
     #! Take input parameters, execute quotation, take output
@@ -125,7 +126,7 @@ USE: parser
     ] [
         [
             swap save-effect get [
-                t "no-effect" set-word-property
+               (  t "no-effect" set-word-property ) drop
             ] [
                 drop
             ] ifte rethrow

diff --git a/library/test/inference.factor b/library/test/inference.factor
index 01af33435d3f26b6208cdc6b7bcd5647415b3cbd..89173069ace24924e528a86d3798a9afc702b99d 100644 (file)
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -23,7 +23,7 @@ USE: generic
 ] "effects" set
 
 [ { f 1 2 } { 1 2 3 } ] [
-    { 1 2 } { 1 2 3 } unify-lengths
+    { 1 2 } { 1 2 3 } unify-length
 ] unit-test
 
 [ [ sq ] ] [

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index e699fd4a76e7dca15624e79f9f34458046771aa3..3ac58740a59eeb29c87d1e2bf0ec7d57f8ce9043 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -144,17 +144,6 @@ M: chained-error error. ( error -- )
         " " [ original-error get error. ] with-prefix
     ] bind ;
 
-TRAITS: multi-error
-
-C: multi-error ( list message -- )
-    [ original-error set multi-error set ] extend ;
-
-M: multi-error error. ( error -- )
-    [
-        original-error get error.
-        " " [ multi-error get [ . ] each ] with-prefix
-    ] bind ;
-
 M: object error. ( error -- )
     . ;