Fix setters for value struct slots and add unit test for this case; this fixes an io.mmap regression on Windows

db4
U-SLAVA-DFB8FF805\Slava 2009-01-28 01:58:57 -06:00
parent 5af6c10eed
commit a4a6885189
4 changed files with 40 additions and 15 deletions

2
basis/alien/arrays/arrays.factor Normal file → Executable file
View File

@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop f ; M: array c-type-boxer-quot drop [ ] ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ;

26
basis/alien/c-types/c-types.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations fry call ; accessors combinators effects continuations fry call classes ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -13,18 +13,20 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type TUPLE: c-type
class { class class initial: object }
boxer boxer-quot unboxer unboxer-quot boxer
getter setter { boxer-quot callable }
reg-class size align stack-align? ; unboxer
{ unboxer-quot callable }
: new-c-type ( class -- type ) { getter callable }
new { setter callable }
int-regs >>reg-class { reg-class initial: int-regs }
object >>class ; inline size
align
stack-align? ;
: <c-type> ( -- type ) : <c-type> ( -- type )
\ c-type new-c-type ; \ c-type new ;
SYMBOL: c-types SYMBOL: c-types
@ -224,7 +226,7 @@ M: f byte-length drop 0 ;
TUPLE: long-long-type < c-type ; TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type ) : <long-long-type> ( -- type )
long-long-type new-c-type ; long-long-type new ;
M: long-long-type unbox-parameter ( n type -- ) M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ; c-type-unboxer %unbox-long-long ;

15
basis/alien/structs/structs-tests.factor Normal file → Executable file
View File

@ -42,3 +42,18 @@ C-UNION: barx
[ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test
] when ] when
C-STRUCT: nested
{ "int" "x" } ;
C-STRUCT: nested-2
{ "nested" "y" } ;
[ 4 ] [
"nested-2" <c-object>
"nested" <c-object>
4 over set-nested-x
over set-nested-2-y
nested-2-y
nested-x
] unit-test

12
basis/alien/structs/structs.factor Normal file → Executable file
View File

@ -2,10 +2,18 @@
! 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
alien.c-types alien.structs.fields cpu.architecture math.order ; alien.c-types alien.structs.fields cpu.architecture math.order
quotations ;
IN: alien.structs IN: alien.structs
TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; TUPLE: struct-type
size
align
fields
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable } ;
M: struct-type heap-size size>> ; M: struct-type heap-size size>> ;