! 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
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 ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
-{ char* utf8 } char* typedef
-char* uchar* typedef
+{ char* utf8 } char <pointer> typedef
+{ char* utf8 } uchar <pointer> typedef
+{ char* binary } byte <pointer> typedef
+{ char* binary } ubyte <pointer> typedef
-char char* "pointer-c-type" set-word-prop
-uchar uchar* "pointer-c-type" set-word-prop
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
{ a int }
{ b int } ;
-[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
-[ t ] [ char* resolve-pointer-type 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 char* c-type = ] unit-test
+
+[ t ] [ pointer: foo c-type-boxer-quot foo c-type-boxer-quot = ] unit-test
[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
-[ t ] [ int c-type MyInt c-type eq? ] unit-test
-[ t ] [ void* c-type MyInt resolve-pointer-type 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 ] [ char c-type MyChar c-type eq? ] unit-test
-[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
-[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ pointer: char c-type pointer: MyChar c-type = ] unit-test
+[ t ] [ char* c-type pointer: MyChar c-type = ] unit-test
-[ 32 ] [ { int 8 } heap-size ] 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 ] [ char* c-type MyString c-type eq? ] unit-test
-[ t ] [ void* c-type MyString resolve-pointer-type 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: uchar* MyLPBYTE
+TYPEDEF: char* MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
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
[ """
long ulong
longlong ulonglong
float double
- void* bool
+ bool void*
void ;
DEFER: <int>
ERROR: no-c-type name ;
-PREDICATE: c-type-word < word
- "c-type" word-prop ;
-
-UNION: c-type-name string c-type-word ;
-
! C type protocol
GENERIC: c-type ( name -- c-type ) foldable
-GENERIC: resolve-pointer-type ( name -- c-type )
-
-<< \ void \ void* "pointer-c-type" set-word-prop >>
-
: void? ( c-type -- ? )
- { void "void" } member? ;
+ void = ; inline
-M: word resolve-pointer-type
- dup "pointer-c-type" word-prop
- [ ] [ drop void* ] ?if ;
+PREDICATE: c-type-word < word
+ "c-type" word-prop ;
+
+TUPLE: pointer { to initial: void read-only } ;
+C: <pointer> pointer
-M: array resolve-pointer-type
- first resolve-pointer-type ;
+UNION: c-type-name
+ c-type-word pointer ;
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
{
[ nip define-symbol ]
[ swap "c-type" set-word-prop ]
- [
- swap dup c-type-name? [
- resolve-pointer-type
- "pointer-c-type" set-word-prop
- ] [ 2drop ] if
- ]
} 2cleave ;
+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 ;
: <long-long-type> ( -- 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
longlong ulonglong
float double
void* bool
+ char*
}
-SYMBOLS:
- ptrdiff_t intptr_t uintptr_t size_t
- char* uchar* ;
+: (pointer-c-type) ( void* type -- void*' )
+ [ clone ] dip c-type-boxer-quot >>boxer-quot ;
+
+<PRIVATE
+
+: resolve-pointer-typedef ( type -- base-type )
+ dup "c-type" word-prop dup word?
+ [ nip resolve-pointer-typedef ] [
+ pointer? [ drop void* ] when
+ ] 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 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 special-pointer-type
+ [ nip ] [
+ dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if
+ ] ?if ;
: 8-byte-alignment ( c-type -- 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 ;
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
- [ (fortran-type>c-type) resolve-pointer-type ]
+ [ (fortran-type>c-type) <pointer> ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
c:void swap
- [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
+ [ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
- [ void* ] [ "int*" parse-c-type ] unit-test
- [ void* ] [ "int**" parse-c-type ] unit-test
- [ void* ] [ "int***" parse-c-type ] unit-test
- [ void* ] [ "int****" parse-c-type ] unit-test
- [ char* ] [ "char*" parse-c-type ] unit-test
- [ void* ] [ "char**" parse-c-type ] unit-test
- [ void* ] [ "char***" parse-c-type ] unit-test
- [ void* ] [ "char****" parse-c-type ] unit-test
+ [ pointer: void ] [ "void*" parse-c-type ] unit-test
+ [ pointer: int ] [ "int*" parse-c-type ] unit-test
+ [ pointer: int* ] [ "int**" parse-c-type ] unit-test
+ [ pointer: int** ] [ "int***" parse-c-type ] unit-test
+ [ pointer: int*** ] [ "int****" parse-c-type ] unit-test
+ [ pointer: char ] [ "char*" parse-c-type ] unit-test
[ char2 ] [ "char2" parse-c-type ] unit-test
- [ char* ] [ "char2*" parse-c-type ] unit-test
+ [ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
- [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
-
] with-file-vocabs
! Reported by mnestic
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
+ { [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
{ [ dup search ] [ parse-c-type-name ] }
- { [ "**" ?tail ] [ drop void* ] }
- { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
- { [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
+ { [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
: parse-c-type ( string -- type )
(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
M: c-type-word definition drop f ;
M: c-type-word declarations. drop ;
+<PRIVATE
+GENERIC: pointer-string ( pointer -- string/f )
+M: object pointer-string drop f ;
+M: word pointer-string name>> ;
+M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
+PRIVATE>
+
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
+M: pointer pprint-c-type
+ dup pointer-string
+ [ swap present-text ]
+ [ pprint* ] if* ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
+M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
+
M: typedef-word definer drop \ TYPEDEF: f ;
M: typedef-word synopsis*
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
+
+SYNTAX: pointer:
+ scan-c-type <pointer> suffix! ;
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data ascii
+USING: accessors alien alien.c-types alien.data alien.syntax ascii
assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
+STRUCT: referent
+ { y int } ;
+STRUCT: referrer
+ { x referent* } ;
+
+[ 57 ] [
+ [
+ referrer <struct>
+ referent malloc-struct &free
+ 57 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+STRUCT: self-referent
+ { x self-referent* }
+ { y int } ;
+
+[ 75 ] [
+ [
+ self-referent <struct>
+ self-referent malloc-struct &free
+ 75 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+C-TYPE: forward-referent
+STRUCT: backward-referent
+ { x forward-referent* }
+ { y int } ;
+STRUCT: forward-referent
+ { x backward-referent* }
+ { y int } ;
+
+[ 41 ] [
+ [
+ forward-referent <struct>
+ backward-referent malloc-struct &free
+ 41 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+[ 14 ] [
+ [
+ backward-referent <struct>
+ forward-referent malloc-struct &free
+ 14 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
cpu ppc? [
STRUCT: ppc-align-test-1
{ x longlong }
;FUNCTOR
-: (underlying-type) ( word -- c-type ) "c-type" word-prop ; inline
-
: underlying-type ( c-type -- c-type' )
- dup (underlying-type) {
+ dup "c-type" word-prop {
{ [ dup not ] [ drop no-c-type ] }
- { [ dup c-type-name? ] [ nip underlying-type ] }
+ { [ dup pointer? ] [ 2drop void* ] }
+ { [ dup c-type-word? ] [ nip underlying-type ] }
[ drop ]
} cond ;
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
generate-vocab ;
-M: c-type-name require-c-array define-array-vocab drop ;
+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 ;
-M: c-type-name 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-name 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-name c-direct-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 ;
TYPEDEF: uchar BYTE
TYPEDEF: ushort wchar_t
-SYMBOL: wchar_t*
-<<
-{ char* utf16n } \ wchar_t* typedef
-\ wchar_t \ wchar_t* "pointer-c-type" set-word-prop
->>
+TYPEDEF: { char* utf16n } wchar_t*
TYPEDEF: wchar_t WCHAR