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

make "struct-class new" work to create a struct with initial values set

db4
Joe Groff 2009-08-12 09:15:46 -04:00
parent 3ac907cbc2
commit f239856649
1 changed files with 14 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
extra/classes/struct/struct.factor
View File

@ -1,3 +1,4 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types byte-arrays classes USING: accessors alien alien.c-types byte-arrays classes
classes.c-types classes.parser classes.tuple classes.c-types classes.parser classes.tuple
classes.tuple.parser classes.tuple.private fry kernel classes.tuple.parser classes.tuple.private fry kernel
@ -30,7 +31,7 @@ M: struct >c-ptr
M: struct-class new M: struct-class new
dup "prototype" word-prop dup "prototype" word-prop
[ >c-ptr clone swap memory>struct ] [ <struct> ] if ; inline [ >c-ptr clone swap memory>struct ] [ <struct> ] if* ; inline
! Struct slot accessors ! Struct slot accessors
@ -39,11 +40,13 @@ M: struct-class reader-quot
[ class>> c-type-getter-boxer ] [ class>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ; [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-class writer-quot : (writer-quot) ( slot -- quot )
nip
[ class>> c-setter ] [ class>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ; [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-class writer-quot
nip (writer-quot) ;
! Struct as c-type ! Struct as c-type
: align-offset ( offset class -- offset' ) : align-offset ( offset class -- offset' )
@ -82,8 +85,14 @@ M: struct-class heap-size
! class definition ! class definition
: struct-prototype ( class -- prototype ) : struct-prototype ( class -- prototype )
[ heap-size <byte-array> ] [ new [ 2 set-slot ] keep ] bi ; ! [ "struct-slots" word-prop ] tri [ heap-size <byte-array> ]
! [ [ initial>> ] [ name>> setter-word ] bi over [ execute( struct value -- struct ) ] [ 2drop ] if ] each ; [ tuple-layout <tuple> [ 2 set-slot ] keep ]
[ "struct-slots" word-prop ] tri
[
[ initial>> ]
[ (writer-quot) ] bi
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
] each ;
: (define-struct-class) ( class slots size align -- ) : (define-struct-class) ( class slots size align -- )
[ [