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

make a corresponding traditional C-STRUCT: for STRUCT: classes

db4
Joe Groff 2009-08-19 22:50:02 -05:00
parent abad5a71fd
commit 60468308f1
1 changed files with 34 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien alien.c-types byte-arrays classes USING: accessors alien alien.c-types alien.structs arrays
classes.c-types classes.parser classes.tuple byte-arrays classes classes.c-types classes.parser classes.tuple
classes.tuple.parser classes.tuple.private combinators classes.tuple.parser classes.tuple.private combinators
combinators.smart fry generalizations generic.parser kernel combinators.smart fry generalizations generic.parser kernel
kernel.private libc macros make math math.order parser kernel.private libc macros make math math.order parser
@ -50,10 +50,20 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
: pad-struct-slots ( values class -- values' class ) : pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ; [ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot )
[ class>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot ) : (writer-quot) ( slot -- quot )
[ class>> c-setter ] [ class>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ; [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
M: struct-class boa>object M: struct-class boa>object
swap pad-struct-slots swap pad-struct-slots
[ (struct) ] [ struct-slots ] bi [ (struct) ] [ struct-slots ] bi
@ -64,9 +74,7 @@ M: struct-class boa>object
GENERIC: struct-slot-values ( struct -- sequence ) GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot M: struct-class reader-quot
nip nip (reader-quot) ;
[ class>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-class writer-quot M: struct-class writer-quot
nip (writer-quot) ; nip (writer-quot) ;
@ -83,6 +91,19 @@ M: struct-class writer-quot
! Struct as c-type ! Struct as c-type
: slot>field ( slot -- field )
[ class>> c-type ] [ name>> ] bi 2array ;
: define-struct-for-class ( class -- )
[
[ name>> ] [ vocabulary>> ] [ struct-slots [ slot>field ] map ] tri
define-struct
] [
[ name>> c-type ]
[ (unboxer-quot) >>unboxer-quot ]
[ (boxer-quot) >>boxer-quot ] tri drop
] bi ;
: align-offset ( offset class -- offset' ) : align-offset ( offset class -- offset' )
c-type-align align ; c-type-align align ;
@ -98,7 +119,8 @@ M: struct-class writer-quot
: struct-align ( slots -- align ) : struct-align ( slots -- align )
[ class>> c-type-align ] [ max ] map-reduce ; [ class>> c-type-align ] [ max ] map-reduce ;
M: struct-class c-type ; M: struct-class c-type
name>> c-type ;
M: struct-class c-type-align M: struct-class c-type-align
"struct-align" word-prop ; "struct-align" word-prop ;
@ -111,10 +133,10 @@ M: struct-class c-type-setter
'[ @ swap @ _ memcpy ] ; '[ @ swap @ _ memcpy ] ;
M: struct-class c-type-boxer-quot M: struct-class c-type-boxer-quot
'[ _ memory>struct ] ; (boxer-quot) ;
M: struct-class c-type-unboxer-quot M: struct-class c-type-unboxer-quot
drop [ >c-ptr ] ; (unboxer-quot) ;
M: struct-class heap-size M: struct-class heap-size
"struct-size" word-prop ; "struct-size" word-prop ;
@ -149,11 +171,13 @@ M: struct-class direct-array-of
[ class>> c-type drop ] each ; [ class>> c-type drop ] each ;
: (define-struct-class) ( class slots offsets-quot -- ) : (define-struct-class) ( class slots offsets-quot -- )
[ drop struct f define-tuple-class ] swap '[ [ drop struct f define-tuple-class ] swap
'[
make-slots dup make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props) (struct-word-props)
] 2bi ; inline ]
[ drop define-struct-for-class ] 2tri ; inline
: define-struct-class ( class slots -- ) : define-struct-class ( class slots -- )
[ struct-offsets ] (define-struct-class) ; [ struct-offsets ] (define-struct-class) ;