Merge branch 'master' of git://factorcode.org/git/factor

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
@@ -35,10 +35,7 @@ M: array box-return drop void* box-return ;
 M: array stack-size drop void* stack-size ;
 
 M: array c-type-boxer-quot
-    unclip
+    unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
-    [ array-length ]
-    [ [ require-c-array ] keep ] bi*
-    [ <c-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
 
@@ -88,10 +85,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,8 +100,9 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
+{ char* utf8 } char <pointer> typedef
 { char* utf8 } char* typedef
-char* uchar* typedef
+{ char* utf8 } uchar <pointer> typedef
+{ char* binary } byte <pointer> typedef
+{ char* binary } ubyte <pointer> typedef
 
-char char* "pointer-c-type" set-word-prop
-uchar uchar* "pointer-c-type" set-word-prop

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,34 +16,44 @@ UNION-STRUCT: foo
     { a int }
     { b int } ;
 
-[ f ] [ char  resolve-pointer-type c-type void* c-type eq? ] unit-test
+[ t ] [ pointer: void c-type void* c-type = ] unit-test
-[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] 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 char* c-type = ] 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 ] [ int   c-type          MyInt c-type = ] unit-test
-[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ void* c-type pointer: MyInt c-type = ] 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
 
 [ 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 ] [ char* c-type MyString                      c-type eq? ] unit-test
+[ t ] [ char* c-type MyString          c-type = ] unit-test
-[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] 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: uchar* MyLPBYTE
+TYPEDEF: char* MyLPBYTE
 
 [ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
 
@@ -63,7 +73,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
 
 [ """

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 )
+PREDICATE: c-type-word < word
+    "c-type" word-prop ;
 
-<< \ void \ void* "pointer-c-type" set-word-prop >>
+TUPLE: pointer { to initial: void read-only } ;
+C: <pointer> pointer
 
-M: word resolve-pointer-type
+UNION: c-type-name
-    dup "pointer-c-type" word-prop
+    c-type-word pointer ;
-    [ ] [ drop void* ] ?if ;
-
-M: array resolve-pointer-type
-    first resolve-pointer-type ;
 
 : 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:
+: (pointer-c-type) ( void* type -- void*' )
-    ptrdiff_t intptr_t uintptr_t size_t
+    [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
-    char* uchar* ;
+
+<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 ;

basis/alien/fortran/fortran-tests.factor

@@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
 classes.struct arrays assocs byte-arrays combinators fry
 generalizations io.encodings.ascii kernel macros
 macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
+FROM: alien.syntax => pointer: ;
 QUALIFIED-WITH: alien.c-types c
 IN: alien.fortran.tests
 
@@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
 
     ! fortran-arg-type>c-type
 
-    [ c:void* { } ]
+    [ pointer: c:int { } ]
     [ "integer" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: { c:int 3 } { } ]
     [ "integer(3)" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: { c:int 0 } { } ]
     [ "integer(*)" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: fortran_test_record { } ]
     [
         [
             "alien.fortran.tests" use-vocab
@@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
         ] with-manifest
     ] unit-test
 
-    [ c:char* { } ]
+    [ pointer: c:char { } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:char* { } ]
+    [ pointer: c:char { } ]
     [ "character(1)" fortran-arg-type>c-type ] unit-test
 
-    [ c:char* { long } ]
+    [ pointer: { c:char 17 } { long } ]
     [ "character(17)" fortran-arg-type>c-type ] unit-test
 
     ! fortran-ret-type>c-type
@@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
     [ c:char { } ]
     [ "character(1)" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:char* long } ]
+    [ c:void { pointer: { c:char 17 } long } ]
     [ "character(17)" fortran-ret-type>c-type ] unit-test
 
     [ c:int { } ]
@@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
     [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ c:double { } ]
     [ "double-precision" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: complex-float } ]
     [ "complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: complex-double } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { c:int 0 } } ]
     [ "integer(*)" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: fortran_test_record } ]
     [
         [
             "alien.fortran.tests" use-vocab
@@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
 
     ! fortran-sig>c-sig
 
-    [ c:float { c:void* c:char* c:void* c:void* c:long } ]
+    [ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
     [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:char { c:char* c:char* c:void* c:long } ]
+    [ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
+    [ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:void { c:void* c:char* c:char* c:void* c:long } ]
+    [ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
@@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [ 
             c:void "funpack" "funtimes_"
-            { c:char* c:void* c:void* c:void* c:void* c:long }
+            { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
             alien-invoke
         ] 6 nkeep
         ! [fortran-results>]
@@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
             [ { [ drop ] } spread ]
         } 1 ncleave
         ! [fortran-invoke]
-        [ c:float "funpack" "fun_times_" { void* } alien-invoke ]
+        [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
         1 nkeep
         ! [fortran-results>]
         shuffle( reta aa -- reta aa ) 
@@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { void* void* } 
+            { pointer: complex-float pointer: { c:float 0 } } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { c:char* long } 
+            { pointer: { c:char 20 } long } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { c:char* long c:char* c:void* c:char* c:long c:long } 
+            { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long } 
             alien-invoke
         ] 7 nkeep
         ! [fortran-results>]
@@ -321,16 +322,16 @@ f2c-abi fortran-abi [
     [ { c:char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ c:char* { c:long } ]
+    [ pointer: c:char { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:void { c:char* c:long } ]
+    [ c:void { pointer: c:char c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
     [ c:double { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
     [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ complex-float { } ]
@@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
     [ { char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ c:char* { c:long } ]
+    [ pointer: c:char { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:void { c:char* c:long } ]
+    [ c:void { pointer: c:char c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
     [ complex-float { } ]
@@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
     [ complex-double { } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { complex-double 3 } } ]
     [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
 
 ] with-variable

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) <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 )

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
+    [ pointer: void ] [ "void*" parse-c-type ] unit-test
-    [ void* ] [ "int**" parse-c-type ] unit-test
+    [ pointer: int ] [ "int*" parse-c-type ] unit-test
-    [ void* ] [ "int***" parse-c-type ] unit-test
+    [ pointer: int* ] [ "int**" parse-c-type ] unit-test
-    [ void* ] [ "int****" parse-c-type ] unit-test
+    [ pointer: int** ] [ "int***" parse-c-type ] unit-test
-    [ char* ] [ "char*" parse-c-type ] unit-test
+    [ pointer: int*** ] [ "int****" parse-c-type ] unit-test
-    [ void* ] [ "char**" parse-c-type ] unit-test
+    [ pointer: char ] [ "char*" parse-c-type ] unit-test
-    [ void* ] [ "char***" parse-c-type ] unit-test
-    [ void* ] [ "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
 
 FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;

basis/alien/parser/parser.factor

@@ -18,22 +18,23 @@ IN: alien.parser
     {
         { [ dup "void" =         ] [ drop void ] }
         { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
+        { [ "*" ?tail            ] [ (parse-c-type) <pointer> ] }
         { [ dup search           ] [ parse-c-type-name ] }
-        { [ "**" ?tail           ] [ drop void* ] }
-        { [ "*" ?tail            ] [ parse-c-type-name resolve-pointer-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 ;
 
 : scan-c-type ( -- c-type )
-    scan dup "{" =
+    scan {
-    [ drop \ } parse-until >array ]
+        { [ dup "{" = ] [ drop \ } parse-until >array ] }
-    [ parse-c-type ] if ; 
+        { [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
+        [ parse-c-type ]
+    } cond ; 
 
 : reset-c-type ( word -- )
     dup "struct-size" word-prop
@@ -61,12 +62,20 @@ IN: alien.parser
     ] bi
     [ parse-c-type ] dip ;
 
+<PRIVATE
+GENERIC: return-type-name ( type -- name )
+
+M: object return-type-name drop "void" ;
+M: word return-type-name name>> ;
+M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
+PRIVATE>
+
 : parse-arglist ( parameters return -- types effect )
     [
         2 group [ first2 normalize-c-arg 2array ] map
         unzip [ "," ?tail drop ] map
     ]
-    [ [ { } ] [ name>> 1array ] if-void ]
+    [ [ { } ] [ return-type-name 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )

basis/alien/prettyprint/prettyprint.factor

@@ -19,12 +19,25 @@ M: c-type-word definer drop \ C-TYPE: f ;
 M: c-type-word definition drop f ;
 M: c-type-word declarations. drop ;
 
+<PRIVATE
+GENERIC: pointer-string ( pointer -- string/f )
+M: object pointer-string drop f ;
+M: word pointer-string name>> ;
+M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
+PRIVATE>
+
 GENERIC: pprint-c-type ( c-type -- )
 M: word pprint-c-type pprint-word ;
+M: pointer pprint-c-type
+    dup pointer-string
+    [ swap present-text ]
+    [ pprint* ] if* ;
 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*

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 <pointer> suffix! ;

basis/cairo/ffi/ffi.factor

@@ -38,7 +38,7 @@ TYPEDEF: void* cairo_pattern_t
 
 TYPEDEF: void* cairo_destroy_func_t
 : cairo-destroy-func ( quot -- callback )
-    [ void { void* } "cdecl" ] dip alien-callback ; inline
+    [ void { pointer: void } "cdecl" ] dip alien-callback ; inline
 
 ! See cairo.h for details
 STRUCT: cairo_user_data_key_t
@@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
 
 TYPEDEF: void* cairo_write_func_t
 : cairo-write-func ( quot -- callback )
-    [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
+    [ cairo_status_t { pointer: void pointer: uchar int } "cdecl" ] dip alien-callback ; inline
                           
 TYPEDEF: void* cairo_read_func_t
 : cairo-read-func ( quot -- callback )
-    [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
+    [ cairo_status_t { pointer: void pointer: uchar int } "cdecl" ] dip alien-callback ; inline
 
 ! Functions for manipulating state objects
 FUNCTION: cairo_t*

basis/calendar/unix/unix.factor

@@ -21,7 +21,7 @@ IN: calendar.unix
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <time_t> localtime tm memory>struct ;
+    f time <time_t> localtime ;
 
 : timezone-name ( -- string )
     get-time zone>> ;

basis/classes/struct/struct-tests.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data ascii
+USING: accessors alien alien.c-types alien.data alien.syntax ascii
 assocs byte-arrays classes.struct classes.tuple.private classes.tuple
 combinators compiler.tree.debugger compiler.units destructors
 io.encodings.utf8 io.pathnames io.streams.string kernel libc
@@ -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 }

basis/classes/struct/struct.factor

@@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
 locals macros make math math.order parser quotations sequences
 slots slots.private specialized-arrays vectors words summary
 namespaces assocs vocabs.parser math.functions
-classes.struct.bit-accessors bit-arrays ;
+classes.struct.bit-accessors bit-arrays
+stack-checker.dependencies ;
 QUALIFIED: math
 IN: classes.struct
 
@@ -124,6 +125,14 @@ M: struct-bit-slot-spec (writer-quot)
 
 : (unboxer-quot) ( class -- quot )
     drop [ >c-ptr ] ;
+
+MACRO: read-struct-slot ( slot -- )
+    dup type>> depends-on-c-type
+    (reader-quot) ;
+
+MACRO: write-struct-slot ( slot -- )
+    dup type>> depends-on-c-type
+    (writer-quot) ;
 PRIVATE>
 
 M: struct-class boa>object
@@ -138,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
 GENERIC: struct-slot-values ( struct -- sequence )
 
 M: struct-class reader-quot
-    nip (reader-quot) ;
+    dup array? [ dup first define-array-vocab drop ] when
+    nip '[ _ read-struct-slot ] ;
 
 M: struct-class writer-quot
-    nip (writer-quot) ;
+    nip '[ _ write-struct-slot ] ;
 
 : offset-of ( field struct -- offset )
     struct-slots slot-named offset>> ; inline

basis/db/sqlite/ffi/ffi.factor

@@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000
 CONSTANT: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000
 CONSTANT: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000
 
-TYPEDEF: void* sqlite3*
+C-TYPE: sqlite3
-TYPEDEF: void* sqlite3_stmt*
+C-TYPE: sqlite3_stmt
 TYPEDEF: longlong sqlite3_int64
 TYPEDEF: ulonglong sqlite3_uint64
 
@@ -121,7 +121,7 @@ FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64
 ! Bind the same function as above, but for unsigned 64bit integers
 : sqlite3-bind-uint64 ( pStmt index in64 -- int )
     int "sqlite" "sqlite3_bind_int64"
-    { sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
+    { pointer: sqlite3_stmt int sqlite3_uint64 } alien-invoke ;
 FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
 FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
 FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
@@ -135,7 +135,7 @@ FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
 ! Bind the same function as above, but for unsigned 64bit integers
 : sqlite3-column-uint64 ( pStmt col -- uint64 )
     sqlite3_uint64 "sqlite" "sqlite3_column_int64"
-    { sqlite3_stmt* int } alien-invoke ;
+    { pointer: sqlite3_stmt int } alien-invoke ;
 FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;

basis/game/input/dinput/dinput.factor

@@ -94,7 +94,6 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 
 : find-device-axes-callback ( -- alien )
     [ ! ( lpddoi pvRef -- BOOL )
-        [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
         +controller-devices+ get at
         swap guidType>> {
             { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
@@ -142,7 +141,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 
 : find-controller-callback ( -- alien )
     [ ! ( lpddi pvRef -- BOOL )
-        drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
+        drop guidInstance>> add-controller
         DIENUM_CONTINUE
     ] LPDIENUMDEVICESCALLBACKW ; inline
 

basis/io/sockets/sockets.factor

@@ -241,7 +241,7 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
     parse-sockaddr ;
 
 : parse-addrinfo-list ( addrinfo -- seq )
-    [ next>> dup [ addrinfo memory>struct ] when ] follow
+    [ next>> ] follow
     [ addrinfo>addrspec ] map
     sift ;
 

basis/opengl/gl/gl.factor

@@ -22,7 +22,7 @@ TYPEDEF: float   GLfloat
 TYPEDEF: float   GLclampf
 TYPEDEF: double  GLdouble
 TYPEDEF: double  GLclampd
-TYPEDEF: void*   GLvoid*
+C-TYPE: GLvoid
 
 ! Constants
 

basis/openssl/libcrypto/libcrypto.factor

@@ -103,7 +103,7 @@ FUNCTION: void* BIO_f_buffer (  ) ;
 
 CONSTANT: EVP_MAX_MD_SIZE 64
 
-TYPEDEF: void* EVP_MD*
+C-TYPE: EVP_MD
 C-TYPE: ENGINE
 
 STRUCT: EVP_MD_CTX

basis/openssl/libssl/libssl.factor

@@ -89,8 +89,8 @@ CONSTANT: SSL_ERROR_WANT_ACCEPT      8
     } ;
 
 TYPEDEF: void* ssl-method
-TYPEDEF: void* SSL_CTX*
+C-TYPE: SSL_CTX
-TYPEDEF: void* SSL_SESSION*
+C-TYPE: SSL_SESSION
 C-TYPE: SSL
 
 LIBRARY: libssl
@@ -99,8 +99,7 @@ LIBRARY: libssl
 ! x509.h
 ! ===============================================
 
-TYPEDEF: void* X509_NAME*
+C-TYPE: X509_NAME
-
 C-TYPE: X509
 
 FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;

basis/specialized-arrays/specialized-arrays.factor

@@ -116,15 +116,18 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
 
 ;FUNCTOR
 
-: (underlying-type) ( word -- c-type ) "c-type" word-prop ; inline
+GENERIC: underlying-type ( c-type -- c-type' )
-
+M: c-type-word underlying-type
-: underlying-type ( c-type -- c-type' )
+    dup "c-type" word-prop {
-    dup (underlying-type) {
         { [ dup not ] [ drop no-c-type ] }
-        { [ dup c-type-name? ] [ nip underlying-type ] }
+        { [ dup pointer? ] [ 2drop void* ] }
+        { [ dup c-type-word? ] [ nip underlying-type ] }
         [ drop ]
     } cond ;
 
+M: pointer underlying-type
+    drop void* ;
+
 : specialized-array-vocab ( c-type -- vocab )
     [
         "specialized-arrays.instances." %
@@ -140,24 +143,25 @@ PRIVATE>
     [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
     generate-vocab ;
 
-M: c-type-name 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: pointer c-array-constructor drop void* c-array-constructor ;
 
-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: pointer c-(array)-constructor drop void* c-(array)-constructor ;
 
-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
+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 ;

basis/stack-checker/dependencies/dependencies.factor

@@ -47,6 +47,9 @@ M: c-type-word depends-on-c-type depends-on-definition ;
 M: array depends-on-c-type
     [ word? ] filter [ depends-on-definition ] each ;
 
+M: pointer depends-on-c-type
+    to>> depends-on-c-type ;
+
 ! Generic words that the current quotation depends on
 SYMBOL: generic-dependencies
 

basis/ui/backend/x11/x11.factor

@@ -49,8 +49,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
 
 M: x11-ui-backend (make-pixel-format)
     [ drop dpy get scr get ] dip
-    >glx-visual-int-array glXChooseVisual
+    >glx-visual-int-array glXChooseVisual ;
-    XVisualInfo memory>struct ;
 
 M: x11-ui-backend (free-pixel-format)
     handle>> XFree ;

basis/unix/groups/groups.factor

@@ -83,7 +83,7 @@ M: integer user-groups ( id -- seq )
     user-name (user-groups) ;
     
 : all-groups ( -- seq )
-    [ unix.ffi:getgrent dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ;
+    [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
 
 : <group-cache> ( -- assoc )
     all-groups [ [ id>> ] keep ] H{ } map>assoc ;

basis/unix/users/users.factor

@@ -37,7 +37,7 @@ PRIVATE>
 
 : all-users ( -- seq )
     [
-        [ unix.ffi:getpwent dup ] [ unix.ffi:passwd memory>struct passwd>new-passwd ] produce nip
+        [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
     ] with-pwent ;
 
 SYMBOL: user-cache
@@ -52,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
 
 M: integer user-passwd ( id -- passwd/f )
     user-cache get
-    [ at ] [ unix.ffi:getpwuid [ unix.ffi:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
+    [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
 
 M: string user-passwd ( string -- passwd/f )
-    unix.ffi:getpwnam dup [ unix.ffi:passwd memory>struct passwd>new-passwd ] when ;
+    unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
 
 : user-name ( id -- string )
     dup user-passwd

basis/unix/utmpx/utmpx.factor

@@ -41,7 +41,7 @@ M: unix new-utmpx-record
     utmpx-record new ;
     
 M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
-    [ new-utmpx-record ] dip \ utmpx memory>struct
+    [ new-utmpx-record ] dip
     {
         [ ut_user>> _UTX_USERSIZE memory>string >>user ]
         [ ut_id>>   _UTX_IDSIZE memory>string >>id ]

basis/windows/com/wrapper/wrapper.factor

@@ -49,8 +49,7 @@ unless
 : (make-query-interface) ( interfaces -- quot )
     (query-interface-cases) 
     '[
-        swap GUID memory>struct
+        swap _ case
-        _ case
         [
             void* heap-size * rot <displaced-alien> com-add-ref
             swap 0 set-alien-cell S_OK

basis/windows/types/types.factor

@@ -11,11 +11,7 @@ TYPEDEF: uchar               UCHAR
 TYPEDEF: uchar               BYTE
 
 TYPEDEF: ushort              wchar_t
-SYMBOL: wchar_t*
+TYPEDEF: { char* utf16n }    wchar_t*
-<<
-{ char* utf16n } \ wchar_t* typedef
-\ wchar_t \ wchar_t* "pointer-c-type" set-word-prop
->>
 
 TYPEDEF: wchar_t             WCHAR
 

basis/windows/uniscribe/uniscribe.factor

@@ -82,7 +82,6 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
 : script-string-size ( script-string -- dim )
     ssa>> ScriptString_pSize
     dup win32-error=0/f
-    SIZE memory>struct
     [ cx>> ] [ cy>> ] bi 2array ;
 
 : dc-metrics ( dc -- metrics )

core/classes/tuple/tuple-tests.factor

@@ -267,7 +267,7 @@ test-server-slot-values
 ] unit-test
 
 [
-    "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
+    "IN: classes.tuple.tests TUPLE: invalid-superclass < word ;" eval( -- )
 ] must-fail
 
 ! Dynamically changing inheritance hierarchy

extra/chipmunk/chipmunk.factor

@@ -512,9 +512,9 @@ FUNCTION: void cpArbiterIgnore ( cpArbiter* arb ) ;
 
 TYPED: cpArbiterGetShapes ( arb: cpArbiter -- a: cpShape b: cpShape )
     dup swappedColl>> 0 = [
-        [ a>> cpShape memory>struct ] [ b>> cpShape memory>struct ] bi
+        [ a>> ] [ b>> ] bi
     ] [
-        [ b>> cpShape memory>struct ] [ a>> cpShape memory>struct ] bi
+        [ b>> ] [ a>> ] bi
     ] if ; inline
 
 TYPED: cpArbiterIsFirstContact ( arb: cpArbiter -- ? )

extra/chipmunk/demo/demo.factor

@@ -50,9 +50,9 @@ CONSTANT: image-bitmap B{
     x bitnot 7 bitand neg shift 1 bitand 1 = ;
 
 :: make-ball ( x y -- shape )
-    cpBodyAlloc 1.0 NAN: 0 cpBodyInit cpBody memory>struct
+    cpBodyAlloc 1.0 NAN: 0 cpBodyInit
     x y cpv >>p :> body
-    cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
+    cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit
     [ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
 
 TUPLE: chipmunk-world < game-world
@@ -76,7 +76,7 @@ M:: chipmunk-world draw-world* ( world -- )
     3 glPointSize
     0 0 0 glColor3f
     GL_POINTS glBegin
-    space bodies>> cpArray memory>struct
+    space bodies>>
     [ num>> ] [ arr>> swap <direct-void*-array> ] bi [
         cpBody memory>struct p>> [ x>> ] [ y>> ] bi glVertex2f
     ] each
@@ -85,7 +85,7 @@ M:: chipmunk-world draw-world* ( world -- )
     2 glPointSize
     1 0 0 glColor3f
     GL_POINTS glBegin
-    space arbiters>> cpArray memory>struct
+    space arbiters>>
     [ num>> ] [ arr>> swap <direct-void*-array> ] bi [
         cpArbiter memory>struct
         [ numContacts>> ] [ contacts>> swap <direct-cpContact-array> ] bi [
@@ -97,7 +97,7 @@ M:: chipmunk-world draw-world* ( world -- )
 M:: chipmunk-world begin-game-world ( world -- )
     cpInitChipmunk
 
-    cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
+    cpSpaceAlloc cpSpaceInit :> space
 
     world space >>space drop
     space 2.0 10000 cpSpaceResizeActiveHash
@@ -115,11 +115,11 @@ M:: chipmunk-world begin-game-world ( world -- )
         ] each
     ] each
     
-    space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody cpBody memory>struct :> body
+    space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody :> body
     body -1000 -10 cpv >>p drop
     body 400 0 cpv >>v drop
 
-    space cpCircleShapeAlloc body 8 0 0 cpv cpCircleShapeInit cpSpaceAddShape cpCircleShape memory>struct :> shape
+    space cpCircleShapeAlloc body 8 0 0 cpv cpCircleShapeInit cpSpaceAddShape :> shape
     shape
     [ shape>> 0 >>e drop ]
     [ shape>> 0 >>u drop ] bi ;