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

clean up classes.struct code. don't set a bunch of redundant word-props on struct class words

db4
Joe Groff 2009-09-24 11:32:25 -05:00
parent 0845ffaf39
commit eec283354e
1 changed files with 26 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
basis/classes/struct/struct.factor
View File

@ -27,9 +27,8 @@ PREDICATE: struct-class < tuple-class
M: struct-class valid-superclass? drop f ;
GENERIC: struct-slots ( struct-class -- slots )
M: struct-class struct-slots "struct-slots" word-prop ;
: struct-slots ( struct-class -- slots )
"c-type" word-prop fields>> ;
! struct allocation
@ -175,16 +174,15 @@ M: struct-c-type c-struct? drop t ;
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
: c-type-for-class ( class -- c-type )
struct-c-type new swap {
[ drop byte-array >>class ]
[ >>boxed-class ]
[ struct-slots >>fields ]
[ "struct-size" word-prop >>size ]
[ "struct-align" word-prop >>align ]
[ (unboxer-quot) >>unboxer-quot ]
[ (boxer-quot) >>boxer-quot ]
} cleave ;
:: c-type-for-class ( class slots size align -- c-type )
struct-c-type new
byte-array >>class
class >>boxed-class
slots >>fields
size >>size
align >>align
class (unboxer-quot) >>unboxer-quot
class (boxer-quot) >>boxer-quot ;
: align-offset ( offset class -- offset' )
c-type-align align ;
@ -202,7 +200,7 @@ M: struct-c-type c-struct? drop t ;
[ type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
M: struct byte-length class "c-type" word-prop size>> ; foldable
! class definition
@ -221,7 +219,7 @@ M: struct binary-zero?
: make-struct-prototype ( class -- prototype )
dup struct-needs-prototype? [
[ "struct-size" word-prop <byte-array> ]
[ "c-type" word-prop size>> <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
[
@ -236,35 +234,25 @@ M: struct binary-zero?
[ (define-clone-method) ]
bi ;
: (struct-word-props) ( class slots size align -- )
[
[ "struct-slots" set-word-prop ]
[ define-accessors ] 2bi
]
[ "struct-size" set-word-prop ]
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup make-struct-prototype "prototype" set-word-prop ]
[ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
: (define-struct-class) ( class slots offsets-quot -- )
[
empty?
[ struct-must-have-slots ]
[ redefine-struct-tuple-class ] if
]
swap '[
make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props)
]
[ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
slots make-slots dup check-struct-slots :> slot-specs
slot-specs offsets-quot call :> size
slot-specs struct-align :> alignment
class slot-specs size alignment align alignment c-type-for-class :> c-type
c-type class typedef
class slot-specs define-accessors
class dup make-struct-prototype "prototype" set-word-prop
class (struct-methods) ; inline
PRIVATE>
: define-struct-class ( class slots -- )