From: Joe Groff Date: Mon, 22 Feb 2010 00:27:36 +0000 (-0800) Subject: use a "pointer" wrapper tuple to indicate pointer types instead of the current slipsh... X-Git-Tag: 0.97~4841^2~26 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=5955ba06df0505ae5a7f4335170f982e8645355b use a "pointer" wrapper tuple to indicate pointer types instead of the current slipshod approach --- diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 7eed1a0664..cf6e8640f0 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -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 diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index faee8955e9..5f903c9a34 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -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 ] [ foo heap-size int heap-size = ] unit-test +[ t ] [ pointer: char c-type c-string c-type eq? ] unit-test -TYPEDEF: int MyInt +[ t ] [ pointer: foo c-type-boxer-quot foo c-type-boxer-quot = ] unit-test -[ t ] [ int c-type MyInt c-type eq? ] unit-test -[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test +[ t ] [ foo heap-size int heap-size = ] unit-test -TYPEDEF: char MyChar +TYPEDEF: int MyInt -[ 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 } ] 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 ] unit-test ] when diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a929cba954..4a7fd840ef 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -17,7 +17,7 @@ SYMBOLS: long ulong longlong ulonglong float double - void* bool + bool void* void ; DEFER: @@ -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? ; - -M: word resolve-pointer-type - dup "pointer-c-type" word-prop - [ ] [ drop void* ] ?if ; + void = ; inline -M: array resolve-pointer-type - first resolve-pointer-type ; +TUPLE: pointer { to initial: void read-only } ; +C: 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 ; > ; -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 *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 ; : ( -- c-type ) @@ -302,7 +291,31 @@ CONSTANT: primitive-types SYMBOLS: ptrdiff_t intptr_t uintptr_t size_t - char* uchar* ; + char* ; + +>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 ) { diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 65e927f85a..9255c66c9f 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -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) ] [ 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) ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor index e405f49995..b7f7b10628 100644 --- a/basis/alien/parser/parser-tests.factor +++ b/basis/alien/parser/parser-tests.factor @@ -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 diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 0cf495fd25..09ee88c173 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -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) ] } [ 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 ; diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index ded8f692cd..6bfbf313a1 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -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* diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 295bcff089..9eb8ca6287 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -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 suffix! ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index cddca71188..0316b1fae0 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -374,6 +374,63 @@ STRUCT: bit-field-test [ 1 ] [ bit-field-test 257 >>c c>> ] unit-test [ 3 ] [ bit-field-test heap-size ] unit-test +STRUCT: referent + { y int } ; +STRUCT: referrer + { x referent* } ; + +[ 57 ] [ + [ + referrer + referent malloc-struct &free + 57 >>y + >>x + x>> y>> + ] with-destructors +] unit-test + +STRUCT: self-referent + { x self-referent* } + { y int } ; + +[ 75 ] [ + [ + self-referent + 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 + backward-referent malloc-struct &free + 41 >>y + >>x + x>> y>> + ] with-destructors +] unit-test + +[ 14 ] [ + [ + backward-referent + forward-referent malloc-struct &free + 14 >>y + >>x + x>> y>> + ] with-destructors +] unit-test + cpu ppc? [ STRUCT: ppc-align-test-1 { x longlong } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 963ed0ab28..d6e58f7ac1 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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. diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index fe2a93844c..67689998ab 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -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>> "" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 9e322d9cde..4f527513fc 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -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 diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 6c93e8f4b6..06997bce56 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -54,7 +54,7 @@ INSTANCE: data-map-param immutable-sequence nip '[ _ ] ; : [>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 ) )