make slot initial-values check the class for an "initial-value" word prop; set this...

diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index d22ca31d001dbab44f004a204624874a9e214858..957b525cb3115043e8fc972ca5affe6073066f31 100644 (file)
--- 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 3cf9b261dca4d3dab54f663b749e4f9bfbf7a0dc..95a854f4936fdaea90f636b6f6ed41ec5bf86728 100755 (executable)
--- 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 0d0b26639f869fef0c386fe2d22292e821d188cb..e53a813825d6b001721f868dfb92605ccffb41f0 100644 (file)
--- 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