steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2009-08-19 21:28:20 -05:00
parent 767d64622d
commit 06ecb30140
3 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
core/slots/slots-tests.factor
View File

@ -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

2
core/slots/slots.factor
View File

@ -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<= ] [ { } ] }

40
extra/classes/c-types/c-types.factor
View File

@ -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