119 lines
3.1 KiB
Factor
119 lines
3.1 KiB
Factor
! Copyright (C) 2004, 2007 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: alien
|
|
USING: arrays generator errors generic hashtables kernel
|
|
kernel-internals math namespaces parser sequences strings
|
|
words libc ;
|
|
|
|
! Some code for interfacing with C structures.
|
|
: define-struct-slot-word ( offset word quot -- )
|
|
rot add* define-compound ;
|
|
|
|
: define-getter ( offset type reader -- )
|
|
#! Define a word with stack effect ( alien -- obj ) in the
|
|
#! current 'in' vocabulary.
|
|
swap c-getter define-struct-slot-word ;
|
|
|
|
: define-setter ( offset type writer -- )
|
|
#! Define a word with stack effect ( obj alien -- ) in the
|
|
#! current 'in' vocabulary.
|
|
swap c-setter define-struct-slot-word ;
|
|
|
|
: align-offset ( offset type -- offset )
|
|
c-type c-type-align align ;
|
|
|
|
: define-field ( offset type reader writer -- offset )
|
|
>r >r [ align-offset ] keep 2dup
|
|
r> define-getter 2dup
|
|
r> define-setter
|
|
heap-size + ;
|
|
|
|
: if-value-structs? ( ctype true false -- )
|
|
value-structs?
|
|
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
|
|
|
|
TUPLE: struct-type size align ;
|
|
|
|
C: struct-type ( width align -- type )
|
|
[ set-struct-type-align ] keep
|
|
[ set-struct-type-size ] keep ;
|
|
|
|
M: struct-type heap-size struct-type-size ;
|
|
|
|
M: struct-type c-type-align struct-type-align ;
|
|
|
|
M: struct-type c-type-stack-align? drop f ;
|
|
|
|
M: struct-type unbox-parameter
|
|
[ heap-size %unbox-struct ]
|
|
[ unbox-parameter ]
|
|
if-value-structs? ;
|
|
|
|
M: struct-type unbox-return
|
|
f swap heap-size %unbox-struct ;
|
|
|
|
M: struct-type box-parameter
|
|
[ heap-size %box-struct ]
|
|
[ box-parameter ]
|
|
if-value-structs? ;
|
|
|
|
M: struct-type box-return
|
|
f swap heap-size %box-struct ;
|
|
|
|
M: struct-type stack-size
|
|
[ heap-size ] [ stack-size ] if-value-structs? ;
|
|
|
|
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
|
|
|
: (define-struct) ( name vocab width align -- )
|
|
[ align ] keep <struct-type> -rot define-c-type ;
|
|
|
|
: define-union ( name vocab members -- )
|
|
dup [ heap-size ] map supremum
|
|
swap [ c-type-align ] map supremum (define-struct) ;
|
|
|
|
: define-struct-early ( name vocab fields -- fields )
|
|
#! Just defer the words so that we have accessors at
|
|
#! parse time
|
|
[
|
|
pick pick >r >r first2 r> swap r>
|
|
[ reader-word ] 3keep writer-word
|
|
3array
|
|
] map 2nip ;
|
|
|
|
: define-struct ( name vocab fields -- )
|
|
[ 0 [ first3 define-field ] reduce ] keep
|
|
[ first c-type-align ] map supremum (define-struct) ;
|
|
|
|
UNION: value-type array struct-type ;
|
|
|
|
M: array c-type ;
|
|
|
|
M: array heap-size unclip heap-size [ * ] reduce ;
|
|
|
|
M: array c-type-align first c-type c-type-align ;
|
|
|
|
M: array c-type-stack-align? drop f ;
|
|
|
|
M: array unbox-parameter drop "void*" unbox-parameter ;
|
|
|
|
M: array unbox-return drop "void*" unbox-return ;
|
|
|
|
M: array box-parameter drop "void*" box-parameter ;
|
|
|
|
M: array box-return drop "void*" box-return ;
|
|
|
|
M: array stack-size drop "void*" stack-size ;
|
|
|
|
M: value-type c-type-reg-class drop T{ int-regs } ;
|
|
|
|
M: value-type c-type-prep drop f ;
|
|
|
|
M: value-type c-type-getter
|
|
drop [ swap <displaced-alien> ] ;
|
|
|
|
M: value-type c-type-setter ( type -- quot )
|
|
[
|
|
dup c-type-getter % \ swap , heap-size , \ memcpy ,
|
|
] [ ] make ;
|