steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

use a "pointer" wrapper tuple to indicate pointer types instead of the current slipshod approach

db4
Joe Groff 2010-02-21 16:27:36 -08:00
parent 9b0530dc97
commit 5955ba06df
13 changed files with 159 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/alien/arrays/arrays.factor
View File

@ -99,8 +99,5 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ char* utf8 } char* typedef
char* uchar* typedef
TYPEDEF: { char* utf8 } char*
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

33
basis/alien/c-types/c-types-tests.factor
View File

@ -16,41 +16,46 @@ UNION-STRUCT: foo
{ 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 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: char c-type c-string c-type eq? ] 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
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 ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type pointer: MyInt c-type eq? ] unit-test
[ 32 ] [ { int 8 } heap-size ] 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 ] [ c-string c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type pointer: MyString c-type eq? ] unit-test
TYPEDEF: int* MyIntArray
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
TYPEDEF: c-string MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[ t ] [ { c-string 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

97
basis/alien/c-types/c-types.factor
View File

@ -17,7 +17,7 @@ SYMBOLS:
long ulong
longlong ulonglong
float double
void* bool
bool void*
void ;
DEFER: <int>
@ -48,28 +48,18 @@ 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 ;
M: array resolve-pointer-type
first resolve-pointer-type ;
TUPLE: pointer { to initial: void read-only } ;
C: <pointer> pointer
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
dup c-type-word? [ c-type ] when ;
<PRIVATE
@ -87,7 +77,7 @@ GENERIC: c-struct? ( c-type -- ? )
M: object c-struct? drop f ;
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
M: c-type-word 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
@ -96,65 +86,65 @@ GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: c-type-name c-type-class c-type c-type-class ;
M: c-type-word 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-name c-type-boxed-class c-type c-type-boxed-class ;
M: c-type-word 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-name c-type-boxer c-type c-type-boxer ;
M: c-type-word 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-name c-type-boxer-quot c-type c-type-boxer-quot ;
M: c-type-word 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-name c-type-unboxer c-type c-type-unboxer ;
M: c-type-word 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-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
M: c-type-word 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-name c-type-rep c-type c-type-rep ;
M: c-type-word c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
M: c-type-name c-type-getter c-type c-type-getter ;
M: c-type-word c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
M: c-type-name c-type-setter c-type c-type-setter ;
M: c-type-word 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-name c-type-align c-type c-type-align ;
M: c-type-word c-type-align c-type c-type-align ;
GENERIC: c-type-align-first ( name -- n )
M: c-type-name c-type-align-first c-type c-type-align-first ;
M: c-type-word c-type-align-first c-type c-type-align-first ;
M: abstract-c-type c-type-align-first align-first>> ;
@ -162,7 +152,7 @@ GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
M: c-type-word 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
@ -176,37 +166,37 @@ GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
M: c-type-name box-parameter c-type box-parameter ;
M: c-type-word box-parameter c-type box-parameter ;
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
M: c-type-name box-return c-type box-return ;
M: c-type-word box-return c-type box-return ;
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
M: c-type-word unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
M: c-type-name unbox-return c-type unbox-return ;
M: c-type-word unbox-return c-type unbox-return ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size )
M: c-type-name heap-size c-type heap-size ;
M: c-type-word heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
M: c-type-name stack-size c-type stack-size ;
M: c-type-word stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
@ -243,20 +233,19 @@ MIXIN: value-type
GENERIC: typedef ( old new -- )
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
"c-type" word-prop c-type-word? ;
M: word typedef ( old new -- )
{
[ 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?
[ ]
[ 2drop ] if ;
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- c-type )
@ -302,7 +291,31 @@ CONSTANT: primitive-types
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
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 ;
: primitive-pointer-type? ( type -- ? )
dup pointer? [ drop t ] [
resolve-typedef [ void? ] [ primitive-types member? ] bi or
] 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 ;
: 8-byte-alignment ( c-type -- c-type )
{

4
basis/alien/fortran/fortran.factor
View File

@ -392,13 +392,13 @@ PRIVATE>
: 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 )

18
basis/alien/parser/parser-tests.factor
View File

@ -18,20 +18,16 @@ CONSTANT: eleven 11
[ { 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

5
basis/alien/parser/parser.factor
View File

@ -19,13 +19,12 @@ IN: alien.parser
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
[ 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 ;

3
basis/alien/prettyprint/prettyprint.factor
View File

@ -21,10 +21,13 @@ 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: 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*

3
basis/alien/syntax/syntax.factor
View File

@ -47,3 +47,6 @@ SYNTAX: &:
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
SYNTAX: pointer:
scan-c-type <pointer> suffix! ;

57
basis/classes/struct/struct-tests.factor
View File

@ -374,6 +374,63 @@ STRUCT: bit-field-test
[ 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 }

2
basis/compiler/codegen/codegen.factor
View File

@ -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-name flatten-value-type c-type flatten-value-type ;
M: c-type-word flatten-value-type c-type flatten-value-type ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.

14
basis/specialized-arrays/specialized-arrays.factor
View File

@ -116,12 +116,10 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
;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 c-type-word? ] [ nip underlying-type ] }
[ drop ]
} cond ;
@ -140,21 +138,21 @@ PRIVATE>
[ 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 ;
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: 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: 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

6
basis/windows/types/types.factor
View File

@ -11,11 +11,7 @@ TYPEDEF: uchar UCHAR
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

4
extra/alien/data/map/map.factor
View File

@ -54,7 +54,7 @@ INSTANCE: data-map-param immutable-sequence
nip '[ _ <sliced-groups> ] ;
: [>param] ( type -- quot )
c-type-count over c-type-name?
c-type-count over c-type-word?
[ [>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-name?
c-type-count over c-type-word?
[ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )