From 5955ba06df0505ae5a7f4335170f982e8645355b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 16:27:36 -0800 Subject: [PATCH 01/22] use a "pointer" wrapper tuple to indicate pointer types instead of the current slipshod approach --- basis/alien/arrays/arrays.factor | 5 +- basis/alien/c-types/c-types-tests.factor | 33 ++++--- basis/alien/c-types/c-types.factor | 97 +++++++++++-------- basis/alien/fortran/fortran.factor | 4 +- basis/alien/parser/parser-tests.factor | 18 ++-- basis/alien/parser/parser.factor | 5 +- basis/alien/prettyprint/prettyprint.factor | 3 + basis/alien/syntax/syntax.factor | 3 + basis/classes/struct/struct-tests.factor | 57 +++++++++++ basis/compiler/codegen/codegen.factor | 2 +- .../specialized-arrays.factor | 14 ++- basis/windows/types/types.factor | 6 +- extra/alien/data/map/map.factor | 4 +- 13 files changed, 159 insertions(+), 92 deletions(-) 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 ] [ pointer: char c-type c-string c-type eq? ] unit-test + +[ t ] [ pointer: foo c-type-boxer-quot foo c-type-boxer-quot = ] 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 ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] 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 +[ 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? ; + void = ; inline -M: word resolve-pointer-type - dup "pointer-c-type" word-prop - [ ] [ drop void* ] ?if ; - -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 ) ) From d5bf6e55cd5ab4a0d544bd541bd7c1229592337f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 19:23:47 -0800 Subject: [PATCH 02/22] more implementation of pointer c-types. make it so that { char* binary } acts like a real pointer to char instead of stringifying, and add byte* typedef for { char* binary } --- basis/alien/arrays/arrays.factor | 15 ++- basis/alien/c-types/c-types-tests.factor | 45 +++++---- basis/alien/c-types/c-types.factor | 96 +++++++++++-------- basis/alien/parser/parser.factor | 8 +- basis/alien/prettyprint/prettyprint.factor | 2 +- basis/compiler/codegen/codegen.factor | 2 +- .../specialized-arrays.factor | 5 + extra/alien/data/map/map.factor | 4 +- 8 files changed, 105 insertions(+), 72 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index cf6e8640f0..c62800df36 100644 --- 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 typedef +{ char* utf8 } uchar typedef +{ char* binary } byte typedef +{ char* binary } ubyte typedef diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 5f903c9a34..13bdfa742a 100644 --- 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 } ] 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 @@ -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 4a7fd840ef..b038244cdd 100644 --- 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 +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 ; > ; -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 *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* ; - ->boxer-quot ; -: string-pointer-type? ( type -- ? ) - dup pointer? [ drop f ] - [ resolve-typedef { char uchar } member? ] if ; + 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 09ee88c173..50d1bfd320 100644 --- 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 ] } + [ 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 6bfbf313a1..489ea0b10a 100644 --- 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 d6e58f7ac1..963ed0ab28 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-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 67689998ab..992dbac6d6 100644 --- 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>> "" 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 06997bce56..6c93e8f4b6 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-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 ) ) From 5faa97e42c5cd5f838ad9b26fd340b6b946930e2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 21:06:00 -0800 Subject: [PATCH 03/22] alien.parser: favor parsing "foo*" as pointer-to-foo now --- basis/alien/c-types/c-types.factor | 4 +++- basis/alien/parser/parser.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index b038244cdd..9db6ac7f4a 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -304,7 +304,9 @@ CONSTANT: primitive-types : resolve-pointer-typedef ( type -- base-type ) dup "c-type" word-prop dup word? - [ nip resolve-pointer-typedef ] [ drop ] if ; + [ nip resolve-pointer-typedef ] [ + pointer? [ drop void* ] when + ] if ; : special-pointer-type ( type -- special-type ) dup c-type-word? [ diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 50d1bfd320..dee5c6e1dd 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -18,8 +18,8 @@ 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 ] [ (parse-c-type) ] } + { [ dup search ] [ parse-c-type-name ] } [ dup search [ ] [ no-word ] ?if ] } cond ; From 04cc3052b67f3bc7a1d6a93aedca319610e68c84 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 21:32:34 -0800 Subject: [PATCH 04/22] alien.prettyprint: pprint pointer objects as "type*" in c-type contexts --- basis/alien/prettyprint/prettyprint.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index 489ea0b10a..52e9978a5f 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -19,9 +19,19 @@ M: c-type-word definer drop \ C-TYPE: f ; M: c-type-word definition drop f ; M: c-type-word declarations. drop ; +> ; +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 pprint* ; +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* ; From 5b726f0af9fef70236fe856dc455237f087d08cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 22:04:23 -0800 Subject: [PATCH 05/22] add missing using to classes.struct tests --- basis/classes/struct/struct-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 0316b1fae0..82530614bf 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/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 From 310b3df2ec5b32929093dbd6922e9fb5f9465806 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 22:31:32 -0800 Subject: [PATCH 06/22] stack-checker.dependencies: add method for pointers to depends-on-c-type --- basis/stack-checker/dependencies/dependencies.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 1bd7cdcd31..4c5529d424 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -45,6 +45,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 From c7acbda342115e0a8fb5aa287126b9595c934920 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 22:46:52 -0800 Subject: [PATCH 07/22] classes.struct: set dependency on slot types in slot accessors, so that accessors update when types change. enables pointers to make circular references between struct types --- basis/classes/struct/struct.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4e7a565a5a..af73be3aa4 100644 --- a/basis/classes/struct/struct.factor +++ b/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,10 @@ M: struct-class initial-value* ; inline GENERIC: struct-slot-values ( struct -- sequence ) M: struct-class reader-quot - nip (reader-quot) ; + 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 From 0bc8e8f40844179cee3e7df116915f5d7dd2a97c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 23:11:59 -0800 Subject: [PATCH 08/22] alien.arrays: typedef special char* symbol so it still works as expected --- basis/alien/arrays/arrays.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index c62800df36..4fddba1de6 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -104,6 +104,7 @@ M: string-type c-type-setter drop [ set-alien-cell ] ; { char* utf8 } char typedef +{ char* utf8 } char* typedef { char* utf8 } uchar typedef { char* binary } byte typedef { char* binary } ubyte typedef From d8432db49557fd20a5edee219ddc1211e442a7f8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 23:12:28 -0800 Subject: [PATCH 09/22] openssl: replace some TYPEDEF: void* foo* (which won't work anymore) with C-TYPE: foo --- basis/openssl/libcrypto/libcrypto.factor | 2 +- basis/openssl/libssl/libssl.factor | 7 +++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index dbc5b9e43c..fd5c757bc4 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/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 diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index 225d4b3da1..1c6fbec011 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -89,8 +89,8 @@ CONSTANT: SSL_ERROR_WANT_ACCEPT 8 } ; TYPEDEF: void* ssl-method -TYPEDEF: void* SSL_CTX* -TYPEDEF: void* SSL_SESSION* +C-TYPE: SSL_CTX +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 ) ; From c4cc70b92c041a3723c8c9b9e303f7701fc3384b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 23:13:12 -0800 Subject: [PATCH 10/22] stack-checker.dependencies: extend c-type-word method for depends-on-c-type to all words (so it works for non-c-types like void) --- basis/stack-checker/dependencies/dependencies.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 4c5529d424..ffa021c9f6 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -40,7 +40,7 @@ SYMBOLS: effect-dependency conditional-dependency definition-dependency ; GENERIC: depends-on-c-type ( c-type -- ) -M: c-type-word depends-on-c-type depends-on-definition ; +M: word depends-on-c-type depends-on-definition ; M: array depends-on-c-type [ word? ] filter [ depends-on-definition ] each ; From d64653ee9a86adc373e86cc2e4f84909de0823b5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 23:13:31 -0800 Subject: [PATCH 11/22] specialized-arrays: fix underlying-type so it always returns void* for pointer types --- basis/specialized-arrays/specialized-arrays.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 992dbac6d6..97ce2ed1ff 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -116,7 +116,8 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline ;FUNCTOR -: underlying-type ( c-type -- c-type' ) +GENERIC: underlying-type ( c-type -- c-type' ) +M: c-type-word underlying-type dup "c-type" word-prop { { [ dup not ] [ drop no-c-type ] } { [ dup pointer? ] [ 2drop void* ] } @@ -124,6 +125,9 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline [ drop ] } cond ; +M: pointer underlying-type + drop void* ; + : specialized-array-vocab ( c-type -- vocab ) [ "specialized-arrays.instances." % From cdde1aa92a4aa0b65201bdd6737ee11143bf117f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 21 Feb 2010 23:13:56 -0800 Subject: [PATCH 12/22] opengl.gl: TYPEDEF: void* GLvoid* => C-TYPE: GLvoid --- basis/opengl/gl/gl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index d89cee57d4..27d24718c2 100644 --- a/basis/opengl/gl/gl.factor +++ b/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 From 4d2ded634b081afc7e6f2d9a7f506f36678ec967 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 11:25:01 -0800 Subject: [PATCH 13/22] alien.parser: properly generate return type name for FUNCTION: stack effects --- basis/alien/parser/parser.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 474bb77dc6..14078f3137 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -62,12 +62,20 @@ IN: alien.parser ] bi [ parse-c-type ] dip ; +> ; +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* ; : function-quot ( return library function types -- quot ) From 1bf37f01e57d531fe37076a6a666933535dc8468 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 12:21:29 -0800 Subject: [PATCH 14/22] alien.arrays/classes.struct: ensure specialized array types for struct array slots get instantiated at parse time --- basis/alien/arrays/arrays.factor | 5 +---- basis/classes/struct/struct.factor | 1 + 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 4fddba1de6..f9a47f256c 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -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 - [ array-length ] - [ [ require-c-array ] keep ] bi* - [ ] 2curry ; + unclip [ array-length ] dip [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index af73be3aa4..3b2fc875c4 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -147,6 +147,7 @@ M: struct-class initial-value* ; inline GENERIC: struct-slot-values ( struct -- sequence ) M: struct-class reader-quot + dup array? [ dup first define-array-vocab drop ] when nip '[ _ read-struct-slot ] ; M: struct-class writer-quot From 6d4724a095fc81b30fdb3661d9fd24b07058df01 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 12:22:29 -0800 Subject: [PATCH 15/22] scrub memory>struct calls made redundant --- basis/calendar/unix/unix.factor | 2 +- basis/game/input/dinput/dinput.factor | 3 +-- basis/specialized-arrays/specialized-arrays.factor | 3 --- basis/ui/backend/x11/x11.factor | 3 +-- basis/unix/groups/groups.factor | 2 +- basis/unix/users/users.factor | 6 +++--- basis/unix/utmpx/utmpx.factor | 2 +- basis/windows/com/wrapper/wrapper.factor | 3 +-- basis/windows/uniscribe/uniscribe.factor | 1 - 9 files changed, 9 insertions(+), 16 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index ac72385d8c..fdc85c943a 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -21,7 +21,7 @@ IN: calendar.unix timespec>seconds since-1970 ; : get-time ( -- alien ) - f time localtime tm memory>struct ; + f time localtime ; : timezone-name ( -- string ) get-time zone>> ; diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor index e2c1fda759..a95dbd06c3 100755 --- a/basis/game/input/dinput/dinput.factor +++ b/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 diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 97ce2ed1ff..2aca62cc77 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -143,9 +143,6 @@ PRIVATE> [ specialized-array-vocab ] [ '[ _ define-array ] ] bi 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 ; M: c-type-word c-array-constructor diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 673dd8e9c3..74d911ef90 100644 --- a/basis/ui/backend/x11/x11.factor +++ b/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 - XVisualInfo memory>struct ; + >glx-visual-int-array glXChooseVisual ; M: x11-ui-backend (free-pixel-format) handle>> XFree ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index b009fe529f..7be124ced4 100644 --- a/basis/unix/groups/groups.factor +++ b/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 ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 5de176e242..0575538b87 100644 --- a/basis/unix/users/users.factor +++ b/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 diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor index 78556ab225..1d6dfdedec 100644 --- a/basis/unix/utmpx/utmpx.factor +++ b/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 ] diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 696902439c..623a9c8db3 100644 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -49,8 +49,7 @@ unless : (make-query-interface) ( interfaces -- quot ) (query-interface-cases) '[ - swap GUID memory>struct - _ case + swap _ case [ void* heap-size * rot com-add-ref swap 0 set-alien-cell S_OK diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 87540dc24f..2783840df0 100644 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/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 ) From 8628b6032738dd5612805db6c26f1e8273a47d26 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 12:34:38 -0800 Subject: [PATCH 16/22] remove unnecessary memory>structs from extra/ too --- extra/chipmunk/chipmunk.factor | 4 ++-- extra/chipmunk/demo/demo.factor | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/chipmunk/chipmunk.factor b/extra/chipmunk/chipmunk.factor index c56e15e12e..a7cd5e0fd2 100644 --- a/extra/chipmunk/chipmunk.factor +++ b/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 -- ? ) diff --git a/extra/chipmunk/demo/demo.factor b/extra/chipmunk/demo/demo.factor index 06f3c32dbe..38a8689bec 100644 --- a/extra/chipmunk/demo/demo.factor +++ b/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 ] 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 ] bi [ cpArbiter memory>struct [ numContacts>> ] [ contacts>> swap ] 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 ; From 829351f2f28f61ec1d5ec10ba93025401b38a8ca Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 19:08:43 -0800 Subject: [PATCH 17/22] don't box struct pointer values when they're null --- basis/alien/c-types/c-types-tests.factor | 2 -- basis/alien/c-types/c-types.factor | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 13bdfa742a..ad53dc487b 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -24,8 +24,6 @@ UNION-STRUCT: foo [ t ] [ pointer: char c-type char* c-type = ] unit-test -[ t ] [ pointer: foo c-type-boxer-quot foo c-type-boxer-quot = ] unit-test - [ t ] [ foo heap-size int heap-size = ] unit-test TYPEDEF: int MyInt diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a9392b03d7..316377dc27 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -288,7 +288,7 @@ CONSTANT: primitive-types } : (pointer-c-type) ( void* type -- void*' ) - [ clone ] dip c-type-boxer-quot >>boxer-quot ; + [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ; Date: Mon, 22 Feb 2010 19:09:03 -0800 Subject: [PATCH 18/22] missed a dead memory>struct in io.sockets --- basis/io/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 59d12f95bc..a1260e80be 100644 --- a/basis/io/sockets/sockets.factor +++ b/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 ; From 21ab2ef6e789c7602ec15e2b1b92bc82b983b1eb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 19:35:52 -0800 Subject: [PATCH 19/22] repeated runs of classes.tuple test would fail because partially defined classes.tuple.tests:bad-superclass type would shadow classes.tuple:bad-superclass --- core/classes/tuple/tuple-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 276c6b407c..1609c1eeca 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/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 From 33f1a7b03b674993b0c81d55a8e3bfdbfcfdcb16 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 19:36:14 -0800 Subject: [PATCH 20/22] db.sqlite.ffi: replace some TYPEDEF: void* foo* with C-TYPE: foo --- basis/db/sqlite/ffi/ffi.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index c180df9bf5..53562fd87e 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/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* -TYPEDEF: void* sqlite3_stmt* +C-TYPE: sqlite3 +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 ) ; From ff9fc2713b7f990620df243bc8d884005bbead73 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 21:57:56 -0800 Subject: [PATCH 21/22] cairo.ffi: update references to pointer types in alien-callbacks --- basis/cairo/ffi/ffi.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index 947869e357..49975afc61 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/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* From aef979b552924bf95ade129676c8452be1124005 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Feb 2010 21:58:18 -0800 Subject: [PATCH 22/22] alien.fortran: update tests to reflect new pointer c-type objects --- basis/alien/fortran/fortran-tests.factor | 59 ++++++++++++------------ 1 file changed, 30 insertions(+), 29 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 80a5ec8bae..dc0585cab8 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/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