From 1f2001143c6d521f4df444bd395a9ef718c13837 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 25 Nov 2007 15:27:11 -0500
Subject: [PATCH] Add type check to curry primitive

---
 core/cpu/arm/intrinsics/intrinsics.factor | 11 -----------
 core/cpu/ppc/intrinsics/intrinsics.factor | 12 ------------
 core/cpu/x86/intrinsics/intrinsics.factor | 13 -------------
 core/quotations/quotations-tests.factor   |  6 ++++--
 vm/quotations.c                           | 16 +++++++++++++---
 5 files changed, 17 insertions(+), 41 deletions(-)
 mode change 100644 => 100755 vm/quotations.c

diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor
index 9eedd8e494..81b23ea8b2 100755
--- a/core/cpu/arm/intrinsics/intrinsics.factor
+++ b/core/cpu/arm/intrinsics/intrinsics.factor
@@ -418,17 +418,6 @@ IN: cpu.arm.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells %allot
-    "obj" operand 1 %set-slot
-    "quot" operand 2 %set-slot
-    "out" get object %store-tagged
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index f78b7c06e2..e1d86db178 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -580,18 +580,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "vector" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells %allot
-    "obj" operand 11 1 cells STW
-    "quot" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "curry" get object %store-tagged
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "curry" } } }
-    { +output+ { "curry" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index ff6975336d..d1a851b553 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -485,19 +485,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "vector" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells [
-        1 object@ "obj" operand MOV
-        2 object@ "quot" operand MOV
-        ! Store tagged ptr in reg
-        "curry" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "curry" } } }
-    { +output+ { "curry" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand %untag-fixnum
diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor
index 662b9e9f2a..f1cc6cd828 100644
--- a/core/quotations/quotations-tests.factor
+++ b/core/quotations/quotations-tests.factor
@@ -1,8 +1,8 @@
 USING: math kernel quotations tools.test sequences ;
 IN: temporary
 
-[ [ 3 ] ] [ 3 f curry ] unit-test
-[ [ \ + ] ] [ \ + f curry ] unit-test
+[ [ 3 ] ] [ 3 [ ] curry ] unit-test
+[ [ \ + ] ] [ \ + [ ] curry ] unit-test
 [ [ \ + = ] ] [ \ + [ = ] curry ] unit-test
 
 [ [ 1 + 2 + 3 + ] ] [
@@ -14,3 +14,5 @@ IN: temporary
 [ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
 
 [ [ "hi" ] ] [ "hi" 1quotation ] unit-test
+
+[ 1 \ + curry ] unit-test-fails
diff --git a/vm/quotations.c b/vm/quotations.c
old mode 100644
new mode 100755
index 472ec76f1e..9d98fa7842
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -192,9 +192,19 @@ XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset)
 DEFINE_PRIMITIVE(curry)
 {
 	F_CURRY *curry = allot_object(CURRY_TYPE,sizeof(F_CURRY));
-	curry->quot = dpop();
-	curry->obj = dpop();
-	dpush(tag_object(curry));
+
+	switch(type_of(dpeek()))
+	{
+	case QUOTATION_TYPE:
+	case CURRY_TYPE:
+		curry->quot = dpop();
+		curry->obj = dpop();
+		dpush(tag_object(curry));
+		break;
+	default:
+		type_error(QUOTATION_TYPE,dpeek());
+		break;
+	}
 }
 
 void uncurry(CELL obj)