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