more implementation of pointer c-types. make it so that { char* binary } acts like a real pointer to char instead of stringifying, and add byte* typedef for { char* binary }
Joe Groff
parent
971af554e1
commit
d5bf6e55cd
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.data alien.accessors
|
||||
arrays words sequences math kernel namespaces fry cpu.architecture
|
||||
io.encodings.utf8 accessors ;
|
||||
io.encodings.binary io.encodings.utf8 accessors ;
|
||||
IN: alien.arrays
|
||||
|
||||
INSTANCE: array value-type
|
||||
|
|
@ -88,10 +88,14 @@ M: string-type c-type-unboxer
|
|||
drop void* c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second '[ _ alien>string ] ;
|
||||
second dup binary =
|
||||
[ drop void* c-type-boxer-quot ]
|
||||
[ '[ _ alien>string ] ] if ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second '[ _ string>alien ] ;
|
||||
second dup binary =
|
||||
[ drop void* c-type-unboxer-quot ]
|
||||
[ '[ _ string>alien ] ] if ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
|
@ -99,5 +103,8 @@ M: string-type c-type-getter
|
|||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
TYPEDEF: { char* utf8 } char*
|
||||
{ char* utf8 } char <pointer> typedef
|
||||
{ char* utf8 } uchar <pointer> typedef
|
||||
{ char* binary } byte <pointer> typedef
|
||||
{ char* binary } ubyte <pointer> typedef
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.syntax alien.c-types alien.parser
|
||||
eval kernel tools.test sequences system libc alien.strings
|
||||
io.encodings.utf8 math.constants classes.struct classes
|
||||
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
||||
accessors compiler.units ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
|
|
@ -16,13 +16,13 @@ UNION-STRUCT: foo
|
|||
{ a int }
|
||||
{ b int } ;
|
||||
|
||||
[ t ] [ pointer: void c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ pointer: int c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ pointer: int* c-type void* c-type eq? ] unit-test
|
||||
[ f ] [ pointer: foo c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ pointer: foo* c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ pointer: void c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: int c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: int* c-type void* c-type = ] unit-test
|
||||
[ f ] [ pointer: foo c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
|
||||
|
||||
[ t ] [ pointer: char c-type c-string c-type eq? ] unit-test
|
||||
[ t ] [ pointer: char c-type char* c-type = ] unit-test
|
||||
|
||||
[ t ] [ pointer: foo c-type-boxer-quot foo c-type-boxer-quot = ] unit-test
|
||||
|
||||
|
|
@ -30,32 +30,39 @@ UNION-STRUCT: foo
|
|||
|
||||
TYPEDEF: int MyInt
|
||||
|
||||
[ t ] [ int c-type MyInt c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyInt c-type eq? ] unit-test
|
||||
[ t ] [ int c-type MyInt c-type = ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
|
||||
|
||||
[ 32 ] [ { int 8 } heap-size ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
[ t ] [ pointer: char c-type pointer: MyChar c-type = ] unit-test
|
||||
[ t ] [ char* c-type pointer: MyChar c-type = ] unit-test
|
||||
|
||||
TYPEDEF: char MyFunkyChar
|
||||
{ char* ascii } pointer: MyFunkyChar typedef
|
||||
|
||||
[ f ] [ pointer: char c-type pointer: MyFunkyChar c-type = ] unit-test
|
||||
[ { char* ascii } ] [ pointer: MyFunkyChar c-type ] unit-test
|
||||
|
||||
TYPEDEF: char* MyString
|
||||
|
||||
[ t ] [ c-string c-type MyString c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyString c-type eq? ] unit-test
|
||||
[ t ] [ char* c-type MyString c-type = ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
|
||||
|
||||
TYPEDEF: int* MyIntArray
|
||||
|
||||
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
||||
|
||||
TYPEDEF: c-string MyLPBYTE
|
||||
TYPEDEF: char* MyLPBYTE
|
||||
|
||||
[ t ] [ { c-string utf8 } c-type MyLPBYTE c-type = ] unit-test
|
||||
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
] must-fail
|
||||
|
||||
C-TYPE: MyOpaqueType
|
||||
|
||||
[ f ] [ pointer: MyOpaqueType c-type void* c-type eq? ] unit-test
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
] when
|
||||
|
|
@ -68,7 +75,7 @@ os windows? cpu x86.64? and [
|
|||
|
||||
C-TYPE: opaque
|
||||
|
||||
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
|
||||
[ opaque c-type ] [ no-c-type? ] must-fail-with
|
||||
|
||||
[ """
|
||||
|
|
|
|||
|
|
@ -45,21 +45,24 @@ stack-align? ;
|
|||
|
||||
ERROR: no-c-type name ;
|
||||
|
||||
PREDICATE: c-type-word < word
|
||||
"c-type" word-prop ;
|
||||
|
||||
! C type protocol
|
||||
GENERIC: c-type ( name -- c-type ) foldable
|
||||
|
||||
: void? ( c-type -- ? )
|
||||
void = ; inline
|
||||
|
||||
PREDICATE: c-type-word < word
|
||||
"c-type" word-prop ;
|
||||
|
||||
TUPLE: pointer { to initial: void read-only } ;
|
||||
C: <pointer> pointer
|
||||
|
||||
UNION: c-type-name
|
||||
c-type-word pointer ;
|
||||
|
||||
: resolve-typedef ( name -- c-type )
|
||||
dup void? [ no-c-type ] when
|
||||
dup c-type-word? [ c-type ] when ;
|
||||
dup c-type-name? [ c-type ] when ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -77,7 +80,7 @@ GENERIC: c-struct? ( c-type -- ? )
|
|||
|
||||
M: object c-struct? drop f ;
|
||||
|
||||
M: c-type-word c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
|
||||
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
|
||||
|
||||
! These words being foldable means that words need to be
|
||||
! recompiled if a C type is redefined. Even so, folding the
|
||||
|
|
@ -86,65 +89,65 @@ GENERIC: c-type-class ( name -- class )
|
|||
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
||||
M: c-type-word c-type-class c-type c-type-class ;
|
||||
M: c-type-name c-type-class c-type c-type-class ;
|
||||
|
||||
GENERIC: c-type-boxed-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-boxed-class boxed-class>> ;
|
||||
|
||||
M: c-type-word c-type-boxed-class c-type c-type-boxed-class ;
|
||||
M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
|
||||
|
||||
GENERIC: c-type-boxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-boxer boxer>> ;
|
||||
|
||||
M: c-type-word c-type-boxer c-type c-type-boxer ;
|
||||
M: c-type-name c-type-boxer c-type c-type-boxer ;
|
||||
|
||||
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: c-type-word c-type-boxer-quot c-type c-type-boxer-quot ;
|
||||
M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
|
||||
|
||||
GENERIC: c-type-unboxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-unboxer unboxer>> ;
|
||||
|
||||
M: c-type-word c-type-unboxer c-type c-type-unboxer ;
|
||||
M: c-type-name c-type-unboxer c-type c-type-unboxer ;
|
||||
|
||||
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
M: c-type-word c-type-unboxer-quot c-type c-type-unboxer-quot ;
|
||||
M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
|
||||
|
||||
GENERIC: c-type-rep ( name -- rep )
|
||||
|
||||
M: c-type c-type-rep rep>> ;
|
||||
|
||||
M: c-type-word c-type-rep c-type c-type-rep ;
|
||||
M: c-type-name c-type-rep c-type c-type-rep ;
|
||||
|
||||
GENERIC: c-type-getter ( name -- quot )
|
||||
|
||||
M: c-type c-type-getter getter>> ;
|
||||
|
||||
M: c-type-word c-type-getter c-type c-type-getter ;
|
||||
M: c-type-name c-type-getter c-type c-type-getter ;
|
||||
|
||||
GENERIC: c-type-setter ( name -- quot )
|
||||
|
||||
M: c-type c-type-setter setter>> ;
|
||||
|
||||
M: c-type-word c-type-setter c-type c-type-setter ;
|
||||
M: c-type-name c-type-setter c-type c-type-setter ;
|
||||
|
||||
GENERIC: c-type-align ( name -- n )
|
||||
|
||||
M: abstract-c-type c-type-align align>> ;
|
||||
|
||||
M: c-type-word c-type-align c-type c-type-align ;
|
||||
M: c-type-name c-type-align c-type c-type-align ;
|
||||
|
||||
GENERIC: c-type-align-first ( name -- n )
|
||||
|
||||
M: c-type-word c-type-align-first c-type c-type-align-first ;
|
||||
M: c-type-name c-type-align-first c-type c-type-align-first ;
|
||||
|
||||
M: abstract-c-type c-type-align-first align-first>> ;
|
||||
|
||||
|
|
@ -152,7 +155,7 @@ GENERIC: c-type-stack-align? ( name -- ? )
|
|||
|
||||
M: c-type c-type-stack-align? stack-align?>> ;
|
||||
|
||||
M: c-type-word c-type-stack-align? c-type c-type-stack-align? ;
|
||||
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
|
||||
|
||||
: c-type-box ( n c-type -- )
|
||||
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
|
||||
|
|
@ -166,37 +169,37 @@ GENERIC: box-parameter ( n c-type -- )
|
|||
|
||||
M: c-type box-parameter c-type-box ;
|
||||
|
||||
M: c-type-word box-parameter c-type box-parameter ;
|
||||
M: c-type-name box-parameter c-type box-parameter ;
|
||||
|
||||
GENERIC: box-return ( c-type -- )
|
||||
|
||||
M: c-type box-return f swap c-type-box ;
|
||||
|
||||
M: c-type-word box-return c-type box-return ;
|
||||
M: c-type-name box-return c-type box-return ;
|
||||
|
||||
GENERIC: unbox-parameter ( n c-type -- )
|
||||
|
||||
M: c-type unbox-parameter c-type-unbox ;
|
||||
|
||||
M: c-type-word unbox-parameter c-type unbox-parameter ;
|
||||
M: c-type-name unbox-parameter c-type unbox-parameter ;
|
||||
|
||||
GENERIC: unbox-return ( c-type -- )
|
||||
|
||||
M: c-type unbox-return f swap c-type-unbox ;
|
||||
|
||||
M: c-type-word unbox-return c-type unbox-return ;
|
||||
M: c-type-name unbox-return c-type unbox-return ;
|
||||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
GENERIC: heap-size ( name -- size )
|
||||
|
||||
M: c-type-word heap-size c-type heap-size ;
|
||||
M: c-type-name heap-size c-type heap-size ;
|
||||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( name -- size )
|
||||
|
||||
M: c-type-word stack-size c-type stack-size ;
|
||||
M: c-type-name stack-size c-type stack-size ;
|
||||
|
||||
M: c-type stack-size size>> cell align ;
|
||||
|
||||
|
|
@ -233,7 +236,7 @@ MIXIN: value-type
|
|||
GENERIC: typedef ( old new -- )
|
||||
|
||||
PREDICATE: typedef-word < c-type-word
|
||||
"c-type" word-prop c-type-word? ;
|
||||
"c-type" word-prop c-type-name? ;
|
||||
|
||||
M: word typedef ( old new -- )
|
||||
{
|
||||
|
|
@ -243,7 +246,7 @@ M: word typedef ( old new -- )
|
|||
|
||||
M: pointer typedef ( old new -- )
|
||||
to>> dup c-type-word?
|
||||
[ ]
|
||||
[ swap "pointer-c-type" set-word-prop ]
|
||||
[ 2drop ] if ;
|
||||
|
||||
TUPLE: long-long-type < c-type ;
|
||||
|
|
@ -278,6 +281,10 @@ M: long-long-type box-return ( c-type -- )
|
|||
: if-void ( c-type true false -- )
|
||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
byte ubyte char* ;
|
||||
|
||||
CONSTANT: primitive-types
|
||||
{
|
||||
char uchar
|
||||
|
|
@ -287,35 +294,37 @@ CONSTANT: primitive-types
|
|||
longlong ulonglong
|
||||
float double
|
||||
void* bool
|
||||
char*
|
||||
}
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
char* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (pointer-c-type) ( void* type -- void*' )
|
||||
[ clone ] dip c-type-boxer-quot >>boxer-quot ;
|
||||
|
||||
: string-pointer-type? ( type -- ? )
|
||||
dup pointer? [ drop f ]
|
||||
[ resolve-typedef { char uchar } member? ] if ;
|
||||
<PRIVATE
|
||||
|
||||
: resolve-pointer-typedef ( type -- base-type )
|
||||
dup "c-type" word-prop dup word?
|
||||
[ nip resolve-pointer-typedef ] [ drop ] if ;
|
||||
|
||||
: special-pointer-type ( type -- special-type )
|
||||
dup c-type-word? [
|
||||
dup "pointer-c-type" word-prop
|
||||
[ ] [ resolve-pointer-typedef "pointer-c-type" word-prop ] ?if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: primitive-pointer-type? ( type -- ? )
|
||||
dup pointer? [ drop t ] [
|
||||
resolve-typedef [ void? ] [ primitive-types member? ] bi or
|
||||
] if ;
|
||||
dup c-type-word? [
|
||||
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
|
||||
] [ drop t ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: pointer c-type
|
||||
[ \ void* c-type ] dip
|
||||
to>> {
|
||||
{ [ dup string-pointer-type? ] [ drop \ char* c-type ] }
|
||||
{ [ dup primitive-pointer-type? ] [ drop ] }
|
||||
[ (pointer-c-type) ]
|
||||
} cond ;
|
||||
to>> dup special-pointer-type
|
||||
[ nip ] [
|
||||
dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if
|
||||
] ?if ;
|
||||
|
||||
: 8-byte-alignment ( c-type -- c-type )
|
||||
{
|
||||
|
|
@ -528,6 +537,9 @@ M: pointer c-type
|
|||
\ uint c-type \ uintptr_t typedef
|
||||
\ uint c-type \ size_t typedef
|
||||
] if
|
||||
|
||||
\ char \ byte typedef
|
||||
\ uchar \ ubyte typedef
|
||||
] with-compilation-unit
|
||||
|
||||
M: char-16-rep rep-component-type drop char ;
|
||||
|
|
|
|||
|
|
@ -30,9 +30,11 @@ IN: alien.parser
|
|||
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
scan dup "{" =
|
||||
[ drop \ } parse-until >array ]
|
||||
[ parse-c-type ] if ;
|
||||
scan {
|
||||
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
|
||||
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
|
||||
[ parse-c-type ]
|
||||
} cond ;
|
||||
|
||||
: reset-c-type ( word -- )
|
||||
dup "struct-size" word-prop
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ M: c-type-word declarations. drop ;
|
|||
|
||||
GENERIC: pprint-c-type ( c-type -- )
|
||||
M: word pprint-c-type pprint-word ;
|
||||
M: pointer pprint-c-type to>> pprint-c-type "*" text ;
|
||||
M: pointer pprint-c-type pprint* ;
|
||||
M: wrapper pprint-c-type wrapped>> pprint-word ;
|
||||
M: string pprint-c-type text ;
|
||||
M: array pprint-c-type pprint* ;
|
||||
|
|
|
|||
|
|
@ -325,7 +325,7 @@ GENERIC: flatten-value-type ( type -- types )
|
|||
M: object flatten-value-type 1array ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-word flatten-value-type c-type flatten-value-type ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
|
|
|
|||
|
|
@ -119,6 +119,7 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
|
|||
: underlying-type ( c-type -- c-type' )
|
||||
dup "c-type" word-prop {
|
||||
{ [ dup not ] [ drop no-c-type ] }
|
||||
{ [ dup pointer? ] [ 2drop void* ] }
|
||||
{ [ dup c-type-word? ] [ nip underlying-type ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
|
@ -139,6 +140,7 @@ PRIVATE>
|
|||
generate-vocab ;
|
||||
|
||||
M: c-type-word require-c-array define-array-vocab drop ;
|
||||
M: pointer require-c-array drop void* require-c-array ;
|
||||
|
||||
ERROR: specialized-array-vocab-not-loaded c-type ;
|
||||
|
||||
|
|
@ -146,16 +148,19 @@ M: c-type-word c-array-constructor
|
|||
underlying-type
|
||||
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-array-constructor drop void* c-array-constructor ;
|
||||
|
||||
M: c-type-word c-(array)-constructor
|
||||
underlying-type
|
||||
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-(array)-constructor drop void* c-(array)-constructor ;
|
||||
|
||||
M: c-type-word c-direct-array-constructor
|
||||
underlying-type
|
||||
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
|
||||
|
||||
SYNTAX: SPECIALIZED-ARRAYS:
|
||||
";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ INSTANCE: data-map-param immutable-sequence
|
|||
nip '[ _ <sliced-groups> ] ;
|
||||
|
||||
: [>param] ( type -- quot )
|
||||
c-type-count over c-type-word?
|
||||
c-type-count over c-type-name?
|
||||
[ [>c-type-param] ] [ [>object-param] ] if ;
|
||||
|
||||
MACRO: >param ( in -- quot: ( array -- param ) )
|
||||
|
|
@ -74,7 +74,7 @@ MACRO: >param ( in -- quot: ( array -- param ) )
|
|||
"Factor sequences as data-map outputs not supported" throw ;
|
||||
|
||||
: [alloc-param] ( type -- quot )
|
||||
c-type-count over c-type-word?
|
||||
c-type-count over c-type-name?
|
||||
[ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
|
||||
|
||||
MACRO: alloc-param ( out -- quot: ( len -- param ) )
|
||||
|
|
|
|||
Loading…
Reference in New Issue