Fix setters for value struct slots and add unit test for this case; this fixes an io.mmap regression on Windows
parent
5af6c10eed
commit
a4a6885189
basis/alien
|
@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
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 ] ;
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
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
|
||||
|
||||
DEFER: <int>
|
||||
|
@ -13,18 +13,20 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
class
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class
|
||||
object >>class ; inline
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ reg-class initial: int-regs }
|
||||
size
|
||||
align
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
\ c-type new ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
@ -224,7 +226,7 @@ M: f byte-length drop 0 ;
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type new-c-type ;
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
|
@ -42,3 +42,18 @@ C-UNION: barx
|
|||
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||
] 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
|
||||
|
|
|
@ -2,10 +2,18 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
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
|
||||
|
||||
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>> ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue