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

alien.structs: simplify logic and remove dead code

db4
Slava Pestov 2009-03-22 17:47:48 -05:00
parent d1436cea15
commit 52cac7fd4e
3 changed files with 17 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
basis/alien/structs/fields/fields.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private math namespaces USING: accessors arrays kernel kernel.private math namespaces
make sequences strings words effects combinators alien.c-types ; make sequences strings words effects combinators alien.c-types ;
@ -6,28 +6,6 @@ IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ; TUPLE: field-spec name offset type reader writer ;
: reader-effect ( type spec -- effect )
[ 1array ] [ name>> 1array ] bi* <effect> ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over reader>>
swap "declared-effect" set-word-prop
reader>> swap "reading" set-word-prop ;
: writer-effect ( type spec -- effect )
name>> swap 2array 0 <effect> ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over writer>>
swap "declared-effect" set-word-prop
writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word ) : reader-word ( class name vocab -- word )
[ "-" glue ] dip create ; [ "-" glue ] dip create ;
@ -55,17 +33,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: define-struct-slot-word ( word quot spec effect -- ) : define-struct-slot-word ( word quot spec effect -- )
[ offset>> prefix ] dip define-inline ; [ offset>> prefix ] dip define-inline ;
: define-getter ( type spec -- ) : define-getter ( spec -- )
[ set-reader-props ] keep [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
[ reader>> ]
[ type>> c-type-getter-boxer ]
[ ] tri
(( c-ptr -- value )) define-struct-slot-word ; (( c-ptr -- value )) define-struct-slot-word ;
: define-setter ( type spec -- ) : define-setter ( spec -- )
[ set-writer-props ] keep
[ writer>> ] [ type>> c-setter ] [ ] tri [ writer>> ] [ type>> c-setter ] [ ] tri
(( value c-ptr -- )) define-struct-slot-word ; (( value c-ptr -- )) define-struct-slot-word ;
: define-field ( type spec -- ) : define-field ( spec -- )
[ define-getter ] [ define-setter ] 2bi ; [ define-getter ] [ define-setter ] bi ;

2
basis/alien/structs/structs-tests.factor
View File

@ -24,7 +24,7 @@ os winnt? cpu x86? and [
] when ] when
] when ] when
: MAX_FOOS 30 ; CONSTANT: MAX_FOOS 30
C-STRUCT: foox C-STRUCT: foox
{ { "int" MAX_FOOS } "x" } ; { { "int" MAX_FOOS } "x" } ;

22
basis/alien/structs/structs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs generic hashtables kernel kernel.private USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry math namespaces parser sequences strings words libc fry
@ -56,10 +56,10 @@ M: struct-type stack-size
: (define-struct) ( name size align fields -- ) : (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip [ [ align ] keep ] dip
struct-type new struct-type new
swap >>fields swap >>fields
swap >>align swap >>align
swap >>size swap >>size
swap typedef ; swap typedef ;
: make-fields ( name vocab fields -- fields ) : make-fields ( name vocab fields -- fields )
[ first2 <field-spec> ] with with map ; [ first2 <field-spec> ] with with map ;
@ -68,12 +68,11 @@ M: struct-type stack-size
[ c-type-align ] [ max ] map-reduce ; [ c-type-align ] [ max ] map-reduce ;
: define-struct ( name vocab fields -- ) : define-struct ( name vocab fields -- )
[ [ 2drop ] [ make-fields ] 3bi
[ 2drop ] [ make-fields ] 3bi [ struct-offsets ] keep
[ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep
[ [ type>> ] map compute-struct-align ] keep [ (define-struct) ] keep
[ (define-struct) ] keep [ define-field ] each ;
] [ 2drop '[ _ swap define-field ] ] 3bi each ;
: define-union ( name members -- ) : define-union ( name members -- )
[ expand-constants ] map [ expand-constants ] map
@ -83,4 +82,3 @@ M: struct-type stack-size
: offset-of ( field struct -- offset ) : offset-of ( field struct -- offset )
c-types get at fields>> c-types get at fields>>
[ name>> = ] with find nip offset>> ; [ name>> = ] with find nip offset>> ;