more implementation of pointer c-types. make it so that { char* binary } acts like...

diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index cf6e8640f04ab580a86ca1dbcb5f3821a2d41163..c62800df363c8788777239467f506a92d9ab1580 100644 (file)
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -2,7 +2,7 @@
 ! 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
@@ -88,10 +88,14 @@ M: string-type c-type-unboxer
     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 ] ;
@@ -99,5 +103,8 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-TYPEDEF: { char* utf8 } char*
+{ char* utf8 } char <pointer> typedef
+{ char* utf8 } uchar <pointer> typedef
+{ char* binary } byte <pointer> typedef
+{ char* binary } ubyte <pointer> typedef
 

diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 5f903c9a3473eb4641c3cc0b6fb795035e3507be..13bdfa742ad89e1b7d6548f107cdd292dccea02f 100644 (file)
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -1,6 +1,6 @@
 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
 
@@ -16,13 +16,13 @@ UNION-STRUCT: foo
     { a int }
     { b int } ;
 
-[ 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: 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 c-string c-type eq? ] 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
 
@@ -30,32 +30,39 @@ UNION-STRUCT: foo
 
 TYPEDEF: int MyInt
 
-[ t ] [ int   c-type          MyInt c-type eq? ] unit-test
-[ t ] [ void* c-type pointer: MyInt 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 ] [ pointer: char c-type pointer: MyChar c-type = ] unit-test
+[ t ] [ char*         c-type pointer: MyChar c-type = ] 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 ] [ c-string c-type MyString          c-type eq? ] unit-test
-[ t ] [ void*    c-type pointer: MyString 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: c-string MyLPBYTE
+TYPEDEF: char* MyLPBYTE
 
-[ t ] [ { c-string utf8 } c-type MyLPBYTE c-type = ] unit-test
+[ t ] [ { char* 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
@@ -68,7 +75,7 @@ os windows? cpu x86.64? and [
 
 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
 
 [ """

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 4a7fd840ef395339dd33a2cf40ad326cfae3c833..b038244cdd26f5135fee2d4ed8a51e72bd916a2c 100644 (file)
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -45,21 +45,24 @@ stack-align? ;
 
 ERROR: no-c-type name ;
 
-PREDICATE: c-type-word < word
-    "c-type" word-prop ;
-
 ! C type protocol
 GENERIC: c-type ( name -- c-type ) foldable
 
 : void? ( c-type -- ? )
     void = ; inline
 
+PREDICATE: c-type-word < word
+    "c-type" word-prop ;
+
 TUPLE: pointer { to initial: void read-only } ;
 C: <pointer> pointer
 
+UNION: c-type-name
+    c-type-word pointer ;
+
 : resolve-typedef ( name -- c-type )
     dup void? [ no-c-type ] when
-    dup c-type-word? [ c-type ] when ;
+    dup c-type-name? [ c-type ] when ;
 
 <PRIVATE
 
@@ -77,7 +80,7 @@ GENERIC: c-struct? ( c-type -- ? )
 
 M: object c-struct? drop f ;
 
-M: c-type-word c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
+M: c-type-name 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
@@ -86,65 +89,65 @@ GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
 
-M: c-type-word c-type-class c-type c-type-class ;
+M: c-type-name 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-word c-type-boxed-class c-type c-type-boxed-class ;
+M: c-type-name 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-word c-type-boxer c-type c-type-boxer ;
+M: c-type-name 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-word c-type-boxer-quot c-type c-type-boxer-quot ;
+M: c-type-name 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-word c-type-unboxer c-type c-type-unboxer ;
+M: c-type-name 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-word c-type-unboxer-quot c-type c-type-unboxer-quot ;
+M: c-type-name 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-word c-type-rep c-type c-type-rep ;
+M: c-type-name c-type-rep c-type c-type-rep ;
 
 GENERIC: c-type-getter ( name -- quot )
 
 M: c-type c-type-getter getter>> ;
 
-M: c-type-word c-type-getter c-type c-type-getter ;
+M: c-type-name c-type-getter c-type c-type-getter ;
 
 GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
 
-M: c-type-word c-type-setter c-type c-type-setter ;
+M: c-type-name 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-word c-type-align c-type c-type-align ;
+M: c-type-name c-type-align c-type c-type-align ;
 
 GENERIC: c-type-align-first ( name -- n )
 
-M: c-type-word c-type-align-first c-type c-type-align-first ;
+M: c-type-name c-type-align-first c-type c-type-align-first ;
 
 M: abstract-c-type c-type-align-first align-first>> ;
 
@@ -152,7 +155,7 @@ GENERIC: c-type-stack-align? ( name -- ? )
 
 M: c-type c-type-stack-align? stack-align?>> ;
 
-M: c-type-word c-type-stack-align? c-type c-type-stack-align? ;
+M: c-type-name 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
@@ -166,37 +169,37 @@ GENERIC: box-parameter ( n c-type -- )
 
 M: c-type box-parameter c-type-box ;
 
-M: c-type-word box-parameter c-type box-parameter ;
+M: c-type-name box-parameter c-type box-parameter ;
 
 GENERIC: box-return ( c-type -- )
 
 M: c-type box-return f swap c-type-box ;
 
-M: c-type-word box-return c-type box-return ;
+M: c-type-name box-return c-type box-return ;
 
 GENERIC: unbox-parameter ( n c-type -- )
 
 M: c-type unbox-parameter c-type-unbox ;
 
-M: c-type-word unbox-parameter c-type unbox-parameter ;
+M: c-type-name unbox-parameter c-type unbox-parameter ;
 
 GENERIC: unbox-return ( c-type -- )
 
 M: c-type unbox-return f swap c-type-unbox ;
 
-M: c-type-word unbox-return c-type unbox-return ;
+M: c-type-name unbox-return c-type unbox-return ;
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 GENERIC: heap-size ( name -- size )
 
-M: c-type-word heap-size c-type heap-size ;
+M: c-type-name heap-size c-type heap-size ;
 
 M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( name -- size )
 
-M: c-type-word stack-size c-type stack-size ;
+M: c-type-name stack-size c-type stack-size ;
 
 M: c-type stack-size size>> cell align ;
 
@@ -233,7 +236,7 @@ MIXIN: value-type
 GENERIC: typedef ( old new -- )
 
 PREDICATE: typedef-word < c-type-word
-    "c-type" word-prop c-type-word? ;
+    "c-type" word-prop c-type-name? ;
 
 M: word typedef ( old new -- )
     {
@@ -243,7 +246,7 @@ M: word typedef ( old new -- )
 
 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 ;
@@ -278,6 +281,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
@@ -287,35 +294,37 @@ CONSTANT: primitive-types
         longlong ulonglong
         float double
         void* bool
+        char*
     }
 
-SYMBOLS:
-    ptrdiff_t intptr_t uintptr_t size_t
-    char* ;
+: (pointer-c-type) ( void* type -- void*' )
+    [ clone ] dip c-type-boxer-quot >>boxer-quot ;
 
 <PRIVATE
 
-: (pointer-c-type) ( void* type -- void*' )
-    [ clone ] dip c-type-boxer-quot >>boxer-quot ;
+: resolve-pointer-typedef ( type -- base-type )
+    dup "c-type" word-prop dup word?
+    [ nip resolve-pointer-typedef ] [ drop ] if ;
 
-: string-pointer-type? ( type -- ? )
-    dup pointer? [ drop f ]
-    [ resolve-typedef { char uchar } member? ] 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 pointer? [ drop t ] [
-        resolve-typedef [ void? ] [ primitive-types member? ] bi or
-    ] if ;
+    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 string-pointer-type? ] [ drop \ char* c-type ] }
-        { [ dup primitive-pointer-type? ] [ drop ] }
-        [ (pointer-c-type) ]
-    } cond ;
+    to>> dup special-pointer-type
+    [ nip ] [
+        dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if
+    ] ?if ;
 
 : 8-byte-alignment ( c-type -- c-type )
     {
@@ -528,6 +537,9 @@ M: pointer 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 ;

diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 09ee88c173c4130034afe76111d452b73df3b5fd..50d1bfd320ca9e4bcf3f12fb8776db3cb6e42586 100644 (file)
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -30,9 +30,11 @@ IN: alien.parser
     (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

diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor
index 6bfbf313a1f94ec9999b6ec961b207a72a08cac3..489ea0b10a9ffb1715f05261b62b203ab7147896 100644 (file)
--- a/basis/alien/prettyprint/prettyprint.factor
+++ b/basis/alien/prettyprint/prettyprint.factor
@@ -21,7 +21,7 @@ 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: pointer pprint-c-type pprint* ;
 M: wrapper pprint-c-type wrapped>> pprint-word ;
 M: string pprint-c-type text ;
 M: array pprint-c-type pprint* ;

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d6e58f7ac1ad8ceb7e043d7ddf8deb65282e2d6d..963ed0ab28c63967fed93efea1f7ff3d83496288 100755 (executable)
--- 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-word flatten-value-type c-type flatten-value-type ;
+M: c-type-name 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 67689998ab6ac30a9bff4dd9bd7e68c0ade826cf..992dbac6d6895cd81d0eedf44942f30b0ba39b4c 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -119,6 +119,7 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
 : underlying-type ( c-type -- c-type' )
     dup "c-type" word-prop {
         { [ dup not ] [ drop no-c-type ] }
+        { [ dup pointer? ] [ 2drop void* ] }
         { [ dup c-type-word? ] [ nip underlying-type ] }
         [ drop ]
     } cond ;
@@ -139,6 +140,7 @@ PRIVATE>
     generate-vocab ;
 
 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 ;
 
@@ -146,16 +148,19 @@ 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-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-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 ;

diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor
index 06997bce56af5ed882514005f5207a112355be7c..6c93e8f4b633d400df3f52ce4cceb0704e010440 100644 (file)
--- 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 '[ _ <sliced-groups> ] ;
 
 : [>param] ( type -- quot )
-    c-type-count over c-type-word?
+    c-type-count over c-type-name?
     [ [>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-word?
+    c-type-count over c-type-name?
     [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ; 
 
 MACRO: alloc-param ( out -- quot: ( len -- param ) )