Merge branch 'master' into new-alien-pointers

[factor.git] / basis / alien / c-types / c-types.factor

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index fff49a44808831871d4c28bddaae6da67f17cc32..a9392b03d7489829d838eaf38c719283de7cf5bb 100644 (file)
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -46,24 +46,17 @@ stack-align? ;
 
 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 >>
+PREDICATE: c-type-word < word
+    "c-type" word-prop ;
 
-M: word resolve-pointer-type
-    dup "pointer-c-type" word-prop
-    [ ] [ drop void* ] ?if ;
+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
@@ -239,14 +232,13 @@ 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?
+    [ swap "pointer-c-type" set-word-prop ]
+    [ 2drop ] if ;
+
 TUPLE: long-long-type < c-type ;
 
 : <long-long-type> ( -- c-type )
@@ -279,6 +271,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
@@ -288,11 +284,39 @@ CONSTANT: primitive-types
         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 )
     {
@@ -505,6 +529,9 @@ SYMBOLS:
         \ 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 ;