From: Slava Pestov Date: Tue, 23 Feb 2010 07:26:41 +0000 (+1300) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.97~4841 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=7decccf8bb11874881d5d54a20a21c5430a64927;hp=32fe19148cde5b4c8d6f2bb36a7748aacad8e0f3 Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 7eed1a0664..f9a47f256c 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 @@ -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 ] ; @@ -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 typedef { char* utf8 } char* typedef -char* uchar* typedef +{ char* utf8 } uchar typedef +{ char* binary } byte typedef +{ char* binary } ubyte typedef -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..ad53dc487b 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,34 +16,44 @@ 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 = ] 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 ] [ void* c-type MyInt resolve-pointer-type 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 ] [ 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 ] [ pointer: char c-type pointer: MyChar c-type = ] unit-test +[ t ] [ char* c-type pointer: MyChar c-type = ] unit-test -[ 32 ] [ { int 8 } heap-size ] 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 ] [ void* c-type MyString resolve-pointer-type 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: 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 [ """ diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index fff49a4480..316377dc27 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -46,24 +46,17 @@ stack-align? ; ERROR: no-c-type name ; -PREDICATE: c-type-word < word - "c-type" word-prop ; - -UNION: c-type-name string c-type-word ; - ! C type protocol GENERIC: c-type ( name -- c-type ) foldable -GENERIC: resolve-pointer-type ( name -- c-type ) - -<< \ void \ void* "pointer-c-type" set-word-prop >> +PREDICATE: c-type-word < word + "c-type" word-prop ; -M: word resolve-pointer-type - dup "pointer-c-type" word-prop - [ ] [ drop void* ] ?if ; +TUPLE: pointer { to initial: void read-only } ; +C: pointer -M: array resolve-pointer-type - first resolve-pointer-type ; +UNION: c-type-name + c-type-word pointer ; : resolve-typedef ( name -- c-type ) dup void? [ no-c-type ] when @@ -239,14 +232,13 @@ M: word typedef ( old new -- ) { [ nip define-symbol ] [ swap "c-type" set-word-prop ] - [ - swap dup c-type-name? [ - resolve-pointer-type - "pointer-c-type" set-word-prop - ] [ 2drop ] if - ] } 2cleave ; +M: pointer typedef ( old new -- ) + to>> dup c-type-word? + [ swap "pointer-c-type" set-word-prop ] + [ 2drop ] if ; + TUPLE: long-long-type < c-type ; : ( -- c-type ) @@ -279,6 +271,10 @@ M: long-long-type box-return ( c-type -- ) : if-void ( c-type true false -- ) pick void? [ drop nip call ] [ nip call ] if ; inline +SYMBOLS: + ptrdiff_t intptr_t uintptr_t size_t + byte ubyte char* ; + CONSTANT: primitive-types { char uchar @@ -288,11 +284,39 @@ CONSTANT: primitive-types longlong ulonglong float double void* bool + char* } -SYMBOLS: - ptrdiff_t intptr_t uintptr_t size_t - char* uchar* ; +: (pointer-c-type) ( void* type -- void*' ) + [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ; + + + +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 ; 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 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 84eefe9df6..37f10722d1 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 FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 8385bfb97f..14078f3137 100644 --- a/basis/alien/parser/parser.factor +++ b/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) ] } { [ 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 "{" = - [ 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 @@ -61,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 ) diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index ded8f692cd..52e9978a5f 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/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 ; +> ; +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* 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/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* 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/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index cddca71188..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 @@ -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/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 4e7a565a5a..3b2fc875c4 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,11 @@ M: struct-class initial-value* ; 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 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 ) ; 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/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 ; 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 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 ) ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index fe2a93844c..2aca62cc77 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/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 - -: underlying-type ( c-type -- c-type' ) - dup (underlying-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 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>> "" 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/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 25fe12cbc5..e2f7c57593 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/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 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/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/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 ) 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 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 ;