From 06ecb30140c5810ec40c0d793d2f5505ce0ade5e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 19 Aug 2009 21:28:20 -0500
Subject: [PATCH] make slot initial-values check the class for an
 "initial-value" word prop; set this word prop on classes.c-types types

---
 core/slots/slots-tests.factor        |  7 +++++
 core/slots/slots.factor              |  2 +-
 extra/classes/c-types/c-types.factor | 40 ++++++++++++++--------------
 3 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index d22ca31d00..957b525cb3 100644
--- a/core/slots/slots-tests.factor
+++ b/core/slots/slots-tests.factor
@@ -32,3 +32,10 @@ M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
     T{ protocol-slot-test-tuple { x 3 } } clone
     [ 7 + ] change-my-protocol-slot-test x>>
 ] unit-test
+
+UNION: comme-ci integer float ;
+UNION: comme-ca integer float ;
+comme-ca 25.5 "initial-value" set-word-prop
+
+[ 0 ]    [ comme-ci initial-value ] unit-test
+[ 25.5 ] [ comme-ca initial-value ] unit-test
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 3cf9b261dc..95a854f493 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -166,9 +166,9 @@ M: class initial-value* no-initial-value ;
 
 : initial-value ( class -- object )
     {
+        { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] }
         { [ \ f bootstrap-word over class<= ] [ f ] }
         { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
-        { [ dup \ integer bootstrap-word class<= ] [ 0 ] }
         { [ float bootstrap-word over class<= ] [ 0.0 ] }
         { [ string bootstrap-word over class<= ] [ "" ] }
         { [ array bootstrap-word over class<= ] [ { } ] }
diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor
index 0d0b26639f..e53a813825 100644
--- a/extra/classes/c-types/c-types.factor
+++ b/extra/classes/c-types/c-types.factor
@@ -61,33 +61,33 @@ SYMBOLS: long ulong long-bits ;
     ] if
 >>
 
-: set-class-c-type ( class c-type <direct-array> -- )
+: set-class-c-type ( class initial c-type <direct-array> -- )
+    [ "initial-value" set-word-prop ]
     [ c-type "class-c-type" set-word-prop ]
-    [ "class-direct-array" set-word-prop ] bi-curry* bi ;
+    [ "class-direct-array" set-word-prop ] tri-curry* tri ;
 
 : class-c-type ( class -- c-type )
     "class-c-type" word-prop ;
 : class-direct-array ( class -- <direct-array> )
     "class-direct-array" word-prop ;
 
-alien          "void*"          \ <direct-void*-array>          set-class-c-type
-\ f            "void*"          \ <direct-void*-array>          set-class-c-type
-pinned-c-ptr   "void*"          \ <direct-void*-array>          set-class-c-type
-boolean        "bool"           \ <direct-bool-array>           set-class-c-type
-char           "char"           \ <direct-char-array>           set-class-c-type
-uchar          "uchar"          \ <direct-uchar-array>          set-class-c-type
-short          "short"          \ <direct-short-array>          set-class-c-type
-ushort         "ushort"         \ <direct-ushort-array>         set-class-c-type
-int            "int"            \ <direct-int-array>            set-class-c-type
-uint           "uint"           \ <direct-uint-array>           set-class-c-type
-long           "long"           \ <direct-long-array>           set-class-c-type
-ulong          "ulong"          \ <direct-ulong-array>          set-class-c-type
-longlong       "longlong"       \ <direct-longlong-array>       set-class-c-type
-ulonglong      "ulonglong"      \ <direct-ulonglong-array>      set-class-c-type
-float          "double"         \ <direct-double-array>         set-class-c-type
-single-float   "float"          \ <direct-float-array>          set-class-c-type
-complex        "complex-double" \ <direct-complex-double-array> set-class-c-type
-single-complex "complex-float"  \ <direct-complex-float-array>  set-class-c-type
+\ f            f            "void*"          \ <direct-void*-array>          set-class-c-type
+pinned-c-ptr   f            "void*"          \ <direct-void*-array>          set-class-c-type
+boolean        f            "bool"           \ <direct-bool-array>           set-class-c-type
+char           0            "char"           \ <direct-char-array>           set-class-c-type
+uchar          0            "uchar"          \ <direct-uchar-array>          set-class-c-type
+short          0            "short"          \ <direct-short-array>          set-class-c-type
+ushort         0            "ushort"         \ <direct-ushort-array>         set-class-c-type
+int            0            "int"            \ <direct-int-array>            set-class-c-type
+uint           0            "uint"           \ <direct-uint-array>           set-class-c-type
+long           0            "long"           \ <direct-long-array>           set-class-c-type
+ulong          0            "ulong"          \ <direct-ulong-array>          set-class-c-type
+longlong       0            "longlong"       \ <direct-longlong-array>       set-class-c-type
+ulonglong      0            "ulonglong"      \ <direct-ulonglong-array>      set-class-c-type
+float          0.0          "double"         \ <direct-double-array>         set-class-c-type
+single-float   0.0          "float"          \ <direct-float-array>          set-class-c-type
+complex        C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
+single-complex C{ 0.0 0.0 } "complex-float"  \ <direct-complex-float-array>  set-class-c-type
 
 char      [  8 bits  8 >signed ] "coercer" set-word-prop
 uchar     [  8 bits            ] "coercer" set-word-prop