]> gitweb.factorcode.org Git - factor.git/commitdiff
use a "pointer" wrapper tuple to indicate pointer types instead of the current slipsh...
authorJoe Groff <arcata@gmail.com>
Mon, 22 Feb 2010 00:27:36 +0000 (16:27 -0800)
committerJoe Groff <arcata@gmail.com>
Mon, 22 Feb 2010 00:27:36 +0000 (16:27 -0800)
13 files changed:
basis/alien/arrays/arrays.factor
basis/alien/c-types/c-types-tests.factor
basis/alien/c-types/c-types.factor
basis/alien/fortran/fortran.factor
basis/alien/parser/parser-tests.factor
basis/alien/parser/parser.factor
basis/alien/prettyprint/prettyprint.factor
basis/alien/syntax/syntax.factor
basis/classes/struct/struct-tests.factor
basis/compiler/codegen/codegen.factor
basis/specialized-arrays/specialized-arrays.factor
basis/windows/types/types.factor
extra/alien/data/map/map.factor

index 7eed1a0664505f7a68bf026753a9bad612fa6c7c..cf6e8640f04ab580a86ca1dbcb5f3821a2d41163 100644 (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
index faee8955e934e20149b933d74d9dd5299e457437..5f903c9a3473eb4641c3cc0b6fb795035e3507be 100644 (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 ] [ 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 } <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
index a929cba954244573159b87bc449c7daf2091617f..4a7fd840ef395339dd33a2cf40ad326cfae3c833 100644 (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? ;
-
-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> 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 )
     {
index 65e927f85a50d00de4e3cc1602b276ec664db11e..9255c66c9f11afc38d358a23d8d56fc36de1a6bb 100644 (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 )
index e405f499959d5ba19a228d7d2bb6bc6daca1920a..b7f7b106282e6ce2300d0e02d1a7f2def911767b 100644 (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
index 0cf495fd25d4cd53592be9fdf989d50ad16f6995..09ee88c173c4130034afe76111d452b73df3b5fd 100644 (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 ;
index ded8f692cdf874da97dabefe3f57d2aab4c6eb19..6bfbf313a1f94ec9999b6ec961b207a72a08cac3 100644 (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*
index 295bcff089393c68f80dad36dd4102344164f3bb..9eb8ca6287291f8f55a1c3de932e5367abec5e44 100644 (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! ;
index cddca7118833e77a15557a78acad740deb9b9fe8..0316b1fae06263753d4b1e61f8de42a238552ea7 100644 (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 }
index 963ed0ab28c63967fed93efea1f7ff3d83496288..d6e58f7ac1ad8ceb7e043d7ddf8deb65282e2d6d 100755 (executable)
@@ -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.
index fe2a93844cf9ccf8f034fd8e78b7c2810bd160dc..67689998ab6ac30a9bff4dd9bd7e68c0ade826cf 100644 (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
index 9e322d9cde2bc2f89e6bb54541b9c284c0b48d8e..4f527513fc7197df50b4caae7d5dd40f1b9935f1 100644 (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
 
index 6c93e8f4b633d400df3f52ce4cceb0704e010440..06997bce56af5ed882514005f5207a112355be7c 100644 (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 ) )