From 99fde7534e68430f948f751b59438b88d3e8b7cf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 2 Aug 2005 05:28:38 +0000
Subject: [PATCH] accurate type signature for make-tuple

---
 library/generic/tuple.factor         |  3 ++-
 library/inference/class-infer.factor | 18 ++++++++++++++----
 2 files changed, 16 insertions(+), 5 deletions(-)

diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index c2ac0c7bbb..6b315763ae 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -15,7 +15,8 @@ hashtables errors sequences vectors ;
 : make-tuple ( class size -- tuple )
     #! Internal allocation function. Do not call it directly,
     #! since you can fool the runtime and corrupt memory by
-    #! specifying an incorrect size.
+    #! specifying an incorrect size. Note that this word is also
+    #! handled specially by the compiler's type inferencer.
     <tuple> [ 2 set-slot ] keep ;
 
 IN: generic
diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor
index 69243b6f3b..bec94cf5d6 100644
--- a/library/inference/class-infer.factor
+++ b/library/inference/class-infer.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic hashtables kernel namespaces sequences vectors
-words ;
+USING: generic hashtables kernel kernel-internals namespaces
+sequences vectors words ;
 
 ! Infer possible classes of values in a dataflow IR.
 
@@ -85,11 +85,21 @@ M: node child-ties ( node -- seq )
         2drop
     ] ifte ;
 
+\ make-tuple [
+    dup node-in-d first literal-value 1vector
+] "output-classes" set-word-prop
+
+: output-classes ( node -- seq )
+    dup node-param "output-classes" word-prop [
+        call
+    ] [
+        node-param "infer-effect" word-prop second
+    ] ?ifte ;
+
 M: #call infer-classes* ( node -- )
     dup node-param [
         dup create-ties
-        dup node-param "infer-effect" word-prop second
-        swap node-out-d intersect-classes
+        dup output-classes swap node-out-d intersect-classes
     ] [
         drop
     ] ifte ;