From 93adf617c03f9b4b6faa01365d6bf8ce26736bc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Aug 2009 05:02:50 -0500 Subject: [PATCH 01/14] windows.com.wrapper: crash fix --- basis/windows/com/wrapper/wrapper.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 81ae923d26..afa3abf287 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -153,7 +153,7 @@ PRIVATE> [ +live-wrappers+ get adjoin ] bi ; : ( implementations -- wrapper ) - com-wrapper new-disposable swap (make-callbacks) >>vtbls + com-wrapper new-disposable swap (make-callbacks) >>callbacks dup allocate-wrapper ; M: com-wrapper dispose* From 6106eed185f934c682014130b8d3aaa79d0130d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Aug 2009 05:06:16 -0500 Subject: [PATCH 02/14] alien.marshall.syntax: don't clobber bool type in unit tests --- extra/alien/marshall/syntax/syntax-tests.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor index 3945924a57..68e6f7aff8 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -10,7 +10,8 @@ C-LIBRARY: test C-INCLUDE: C-INCLUDE: -C-TYPEDEF: char bool +! This used to typedef 'bool' but that's bad for PowerPC where its really an int +C-TYPEDEF: char mybool CM-FUNCTION: void outarg1 ( int* a ) *a += 2; @@ -38,7 +39,7 @@ CM-FUNCTION: void change_time ( double hours, sundial* d ) d->wedge.degrees = hours * 30; ; -CM-FUNCTION: bool c_not ( bool p ) +CM-FUNCTION: mybool c_not ( mybool p ) return !p; ; From 965e9ba3279e567899370fc4beb7a526a2480593 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Aug 2009 05:10:41 -0500 Subject: [PATCH 03/14] alien.marshall: fix unit tests --- extra/alien/marshall/marshall.factor | 4 ++-- extra/alien/marshall/syntax/syntax-tests.factor | 6 ++---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 547e37f78a..d861178fad 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -93,7 +93,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-marshaller ( type -- quot/f ) { - { "bool" [ [ marshall-bool ] ] } + { "bool" [ [ ] ] } { "boolean" [ [ marshall-bool ] ] } { "char" [ [ marshall-primitive ] ] } { "uchar" [ [ marshall-primitive ] ] } @@ -179,7 +179,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-unmarshaller ( type -- quot/f ) { - { "bool" [ [ unmarshall-bool ] ] } + { "bool" [ [ ] ] } { "boolean" [ [ unmarshall-bool ] ] } { "char" [ [ ] ] } { "uchar" [ [ ] ] } diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor index 68e6f7aff8..437685137c 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -9,9 +9,7 @@ C-LIBRARY: test C-INCLUDE: C-INCLUDE: - -! This used to typedef 'bool' but that's bad for PowerPC where its really an int -C-TYPEDEF: char mybool +C-INCLUDE: CM-FUNCTION: void outarg1 ( int* a ) *a += 2; @@ -39,7 +37,7 @@ CM-FUNCTION: void change_time ( double hours, sundial* d ) d->wedge.degrees = hours * 30; ; -CM-FUNCTION: mybool c_not ( mybool p ) +CM-FUNCTION: bool c_not ( bool p ) return !p; ; From d950e5a5dec3d7e8d817b43d9a3e07ac2472ba7e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 11:39:44 -0500 Subject: [PATCH 04/14] add aliases to classes.c-types to look more like FFI types --- extra/classes/c-types/c-types-docs.factor | 30 +++++++++++---- extra/classes/c-types/c-types.factor | 47 ++++++++++++++--------- 2 files changed, 50 insertions(+), 27 deletions(-) diff --git a/extra/classes/c-types/c-types-docs.factor b/extra/classes/c-types/c-types-docs.factor index 58ebf7a063..df21db0104 100644 --- a/extra/classes/c-types/c-types-docs.factor +++ b/extra/classes/c-types/c-types-docs.factor @@ -1,6 +1,7 @@ ! (c)Joe Groff bsd license -USING: alien arrays classes help.markup help.syntax kernel math +USING: alien arrays classes help.markup help.syntax kernel specialized-arrays.direct ; +QUALIFIED: math IN: classes.c-types HELP: c-type-class @@ -11,7 +12,7 @@ HELP: char HELP: direct-array-of { $values - { "alien" c-ptr } { "len" integer } { "class" c-type-class } + { "alien" c-ptr } { "len" math:integer } { "class" c-type-class } { "array" "a direct array" } } { $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ; @@ -28,12 +29,18 @@ HELP: longlong HELP: short { $class-description "A signed two-byte integer quantity." } ; -HELP: single-complex +HELP: complex-float { $class-description "A single-precision complex floating point quantity." } ; -HELP: single-float +HELP: complex-double +{ $class-description "A double-precision complex floating point quantity. This is an alias for the Factor " { $link math:complex } " type." } ; + +HELP: float { $class-description "A single-precision floating point quantity." } ; +HELP: double +{ $class-description "A double-precision floating point quantity. This is an alias for the Factor " { $link math:float } " type." } ; + HELP: uchar { $class-description "An unsigned one-byte integer quantity." } ; @@ -49,6 +56,12 @@ HELP: ulonglong HELP: ushort { $class-description "An unsigned two-byte integer quantity." } ; +HELP: bool +{ $class-description "A boolean value. This is an alias to the Factor " { $link boolean } " class." } ; + +HELP: void* +{ $class-description "A pointer to raw C memory. This is an alias to the Factor " { $link pinned-c-ptr } " class." } ; + ARTICLE: "classes.c-types" "C type classes" "The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI." { $subsection char } @@ -61,11 +74,12 @@ ARTICLE: "classes.c-types" "C type classes" { $subsection ulong } { $subsection longlong } { $subsection ulonglong } -{ $subsection single-float } { $subsection float } -{ $subsection single-complex } -{ $subsection complex } -{ $subsection pinned-c-ptr } +{ $subsection double } +{ $subsection complex-float } +{ $subsection complex-double } +{ $subsection bool } +{ $subsection void* } "The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:" { $subsection direct-array-of } ; diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor index e53a813825..97cf20d4fc 100644 --- a/extra/classes/c-types/c-types.factor +++ b/extra/classes/c-types/c-types.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license USING: alien alien.c-types classes classes.predicate kernel -math math.bitwise math.order namespaces sequences words +math.bitwise math.order namespaces sequences words specialized-arrays.direct.alien specialized-arrays.direct.bool specialized-arrays.direct.char @@ -17,46 +17,53 @@ specialized-arrays.direct.uint specialized-arrays.direct.ulong specialized-arrays.direct.ulonglong specialized-arrays.direct.ushort ; +QUALIFIED: math IN: classes.c-types -PREDICATE: char < fixnum +PREDICATE: char < math:fixnum HEX: -80 HEX: 7f between? ; -PREDICATE: uchar < fixnum +PREDICATE: uchar < math:fixnum HEX: 0 HEX: ff between? ; -PREDICATE: short < fixnum +PREDICATE: short < math:fixnum HEX: -8000 HEX: 7fff between? ; -PREDICATE: ushort < fixnum +PREDICATE: ushort < math:fixnum HEX: 0 HEX: ffff between? ; -PREDICATE: int < integer +PREDICATE: int < math:integer HEX: -8000,0000 HEX: 7fff,ffff between? ; -PREDICATE: uint < integer +PREDICATE: uint < math:integer HEX: 0 HEX: ffff,ffff between? ; -PREDICATE: longlong < integer +PREDICATE: longlong < math:integer HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ; -PREDICATE: ulonglong < integer +PREDICATE: ulonglong < math:integer HEX: 0 HEX: ffff,ffff,ffff,ffff between? ; -UNION: single-float float ; -UNION: single-complex complex ; +UNION: double math:float ; +UNION: complex-double math:complex ; + +UNION: bool boolean ; +UNION: void* pinned-c-ptr ; + +UNION: float math:float ; +UNION: complex-float math:complex ; SYMBOLS: long ulong long-bits ; << "long" heap-size 8 = [ - \ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class - \ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class + \ long math:integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class + \ ulong math:integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class 64 \ long-bits set-global ] [ - \ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class - \ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class + \ long math:integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class + \ ulong math:integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class 32 \ long-bits set-global ] if >> @@ -72,7 +79,9 @@ SYMBOLS: long ulong long-bits ; "class-direct-array" word-prop ; \ f f "void*" \ set-class-c-type +void* f "void*" \ set-class-c-type pinned-c-ptr f "void*" \ set-class-c-type +bool f "bool" \ set-class-c-type boolean f "bool" \ set-class-c-type char 0 "char" \ set-class-c-type uchar 0 "uchar" \ set-class-c-type @@ -84,10 +93,10 @@ long 0 "long" \ set ulong 0 "ulong" \ set-class-c-type longlong 0 "longlong" \ set-class-c-type ulonglong 0 "ulonglong" \ set-class-c-type -float 0.0 "double" \ set-class-c-type -single-float 0.0 "float" \ set-class-c-type -complex C{ 0.0 0.0 } "complex-double" \ set-class-c-type -single-complex C{ 0.0 0.0 } "complex-float" \ set-class-c-type +float 0.0 "float" \ set-class-c-type +double 0.0 "double" \ set-class-c-type +complex-float C{ 0.0 0.0 } "complex-float" \ set-class-c-type +complex-double C{ 0.0 0.0 } "complex-double" \ set-class-c-type char [ 8 bits 8 >signed ] "coercer" set-word-prop uchar [ 8 bits ] "coercer" set-word-prop From f430c9a3d55e01a40e8fbf0ccca8a0078b71f4b6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 11:40:05 -0500 Subject: [PATCH 05/14] fix classes.struct structs when used in FFI, add a test --- extra/classes/struct/struct-tests.factor | 32 ++++++++++++++++-------- extra/classes/struct/struct.factor | 2 +- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 912d33c7bc..467f9da67b 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,13 +1,15 @@ ! (c)Joe Groff bsd license -USING: accessors alien.c-types alien.structs.fields classes.c-types -classes.struct combinators io.streams.string kernel libc literals math -multiline namespaces prettyprint prettyprint.config see tools.test ; +USING: accessors alien.c-types alien.structs.fields alien.syntax +classes.c-types classes.struct combinators io.streams.string kernel +libc literals math multiline namespaces prettyprint prettyprint.config +see tools.test ; +FROM: classes.c-types => float ; IN: classes.struct.tests STRUCT: struct-test-foo { x char } { y int initial: 123 } - { z boolean } ; + { z bool } ; STRUCT: struct-test-bar { w ushort initial: HEX: ffff } @@ -32,7 +34,7 @@ STRUCT: struct-test-bar [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test UNION-STRUCT: struct-test-float-and-bits - { f single-float } + { f float } { bits uint } ; [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test @@ -65,7 +67,7 @@ STRUCT: struct-test-foo [ <" USING: classes.c-types classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits - { f single-float initial: 0.0 } { bits uint initial: 0 } ; + { f float initial: 0.0 } { bits uint initial: 0 } ; "> ] [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test @@ -73,21 +75,21 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "x" } { offset 0 } - { type $[ char c-type ] } + { type char } { reader x>> } { writer (>>x) } } T{ field-spec { name "y" } { offset 4 } - { type $[ int c-type ] } + { type int } { reader y>> } { writer (>>y) } } T{ field-spec { name "z" } { offset 8 } - { type $[ boolean c-type ] } + { type bool } { reader z>> } { writer (>>z) } } @@ -97,16 +99,24 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "f" } { offset 0 } - { type $[ single-float c-type ] } + { type float } { reader f>> } { writer (>>f) } } T{ field-spec { name "bits" } { offset 0 } - { type $[ uint c-type ] } + { type uint } { reader bits>> } { writer (>>bits) } } } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test +STRUCT: struct-test-ffi-foo + { x int } + { y int } ; + +LIBRARY: f-cdecl +FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; + +[ 14 ] [ 1 2 3 struct-test-ffi-foo 4 ffi_test_11 ] unit-test diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 3d4ffe138b..02d0a056a8 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -96,7 +96,7 @@ M: struct-class writer-quot field-spec new swap { [ name>> >>name ] [ offset>> >>offset ] - [ class>> c-type >>type ] + [ class>> >>type ] [ name>> reader-word >>reader ] [ name>> writer-word >>writer ] } cleave ; From 56ca6ceeefb7c11e82cee77528eb891884d79e31 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 13:03:43 -0500 Subject: [PATCH 06/14] classes.c-types is kinda half-baked. get rid of it, and make classes.struct parse c types directly --- extra/classes/c-types/c-types-docs.factor | 86 ------------ extra/classes/c-types/c-types.factor | 127 ------------------ .../struct/prettyprint/prettyprint.factor | 18 ++- extra/classes/struct/struct-docs.factor | 2 +- extra/classes/struct/struct-tests.factor | 41 ++++-- extra/classes/struct/struct.factor | 59 +++++--- 6 files changed, 83 insertions(+), 250 deletions(-) delete mode 100644 extra/classes/c-types/c-types-docs.factor delete mode 100644 extra/classes/c-types/c-types.factor diff --git a/extra/classes/c-types/c-types-docs.factor b/extra/classes/c-types/c-types-docs.factor deleted file mode 100644 index df21db0104..0000000000 --- a/extra/classes/c-types/c-types-docs.factor +++ /dev/null @@ -1,86 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien arrays classes help.markup help.syntax kernel -specialized-arrays.direct ; -QUALIFIED: math -IN: classes.c-types - -HELP: c-type-class -{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ; - -HELP: char -{ $class-description "A signed one-byte integer quantity." } ; - -HELP: direct-array-of -{ $values - { "alien" c-ptr } { "len" math:integer } { "class" c-type-class } - { "array" "a direct array" } -} -{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ; - -HELP: int -{ $class-description "A signed four-byte integer quantity." } ; - -HELP: long -{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; - -HELP: longlong -{ $class-description "A signed eight-byte integer quantity." } ; - -HELP: short -{ $class-description "A signed two-byte integer quantity." } ; - -HELP: complex-float -{ $class-description "A single-precision complex floating point quantity." } ; - -HELP: complex-double -{ $class-description "A double-precision complex floating point quantity. This is an alias for the Factor " { $link math:complex } " type." } ; - -HELP: float -{ $class-description "A single-precision floating point quantity." } ; - -HELP: double -{ $class-description "A double-precision floating point quantity. This is an alias for the Factor " { $link math:float } " type." } ; - -HELP: uchar -{ $class-description "An unsigned one-byte integer quantity." } ; - -HELP: uint -{ $class-description "An unsigned four-byte integer quantity." } ; - -HELP: ulong -{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; - -HELP: ulonglong -{ $class-description "An unsigned eight-byte integer quantity." } ; - -HELP: ushort -{ $class-description "An unsigned two-byte integer quantity." } ; - -HELP: bool -{ $class-description "A boolean value. This is an alias to the Factor " { $link boolean } " class." } ; - -HELP: void* -{ $class-description "A pointer to raw C memory. This is an alias to the Factor " { $link pinned-c-ptr } " class." } ; - -ARTICLE: "classes.c-types" "C type classes" -"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI." -{ $subsection char } -{ $subsection uchar } -{ $subsection short } -{ $subsection ushort } -{ $subsection int } -{ $subsection uint } -{ $subsection long } -{ $subsection ulong } -{ $subsection longlong } -{ $subsection ulonglong } -{ $subsection float } -{ $subsection double } -{ $subsection complex-float } -{ $subsection complex-double } -{ $subsection bool } -{ $subsection void* } -"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:" -{ $subsection direct-array-of } ; - -ABOUT: "classes.c-types" diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor deleted file mode 100644 index 97cf20d4fc..0000000000 --- a/extra/classes/c-types/c-types.factor +++ /dev/null @@ -1,127 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien alien.c-types classes classes.predicate kernel -math.bitwise math.order namespaces sequences words -specialized-arrays.direct.alien -specialized-arrays.direct.bool -specialized-arrays.direct.char -specialized-arrays.direct.complex-double -specialized-arrays.direct.complex-float -specialized-arrays.direct.double -specialized-arrays.direct.float -specialized-arrays.direct.int -specialized-arrays.direct.long -specialized-arrays.direct.longlong -specialized-arrays.direct.short -specialized-arrays.direct.uchar -specialized-arrays.direct.uint -specialized-arrays.direct.ulong -specialized-arrays.direct.ulonglong -specialized-arrays.direct.ushort ; -QUALIFIED: math -IN: classes.c-types - -PREDICATE: char < math:fixnum - HEX: -80 HEX: 7f between? ; - -PREDICATE: uchar < math:fixnum - HEX: 0 HEX: ff between? ; - -PREDICATE: short < math:fixnum - HEX: -8000 HEX: 7fff between? ; - -PREDICATE: ushort < math:fixnum - HEX: 0 HEX: ffff between? ; - -PREDICATE: int < math:integer - HEX: -8000,0000 HEX: 7fff,ffff between? ; - -PREDICATE: uint < math:integer - HEX: 0 HEX: ffff,ffff between? ; - -PREDICATE: longlong < math:integer - HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ; - -PREDICATE: ulonglong < math:integer - HEX: 0 HEX: ffff,ffff,ffff,ffff between? ; - -UNION: double math:float ; -UNION: complex-double math:complex ; - -UNION: bool boolean ; -UNION: void* pinned-c-ptr ; - -UNION: float math:float ; -UNION: complex-float math:complex ; - -SYMBOLS: long ulong long-bits ; - -<< - "long" heap-size 8 = - [ - \ long math:integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class - \ ulong math:integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class - 64 \ long-bits set-global - ] [ - \ long math:integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class - \ ulong math:integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class - 32 \ long-bits set-global - ] if ->> - -: set-class-c-type ( class initial c-type -- ) - [ "initial-value" set-word-prop ] - [ c-type "class-c-type" set-word-prop ] - [ "class-direct-array" set-word-prop ] tri-curry* tri ; - -: class-c-type ( class -- c-type ) - "class-c-type" word-prop ; -: class-direct-array ( class -- ) - "class-direct-array" word-prop ; - -\ f f "void*" \ set-class-c-type -void* f "void*" \ set-class-c-type -pinned-c-ptr f "void*" \ set-class-c-type -bool f "bool" \ set-class-c-type -boolean f "bool" \ set-class-c-type -char 0 "char" \ set-class-c-type -uchar 0 "uchar" \ set-class-c-type -short 0 "short" \ set-class-c-type -ushort 0 "ushort" \ set-class-c-type -int 0 "int" \ set-class-c-type -uint 0 "uint" \ set-class-c-type -long 0 "long" \ set-class-c-type -ulong 0 "ulong" \ set-class-c-type -longlong 0 "longlong" \ set-class-c-type -ulonglong 0 "ulonglong" \ set-class-c-type -float 0.0 "float" \ set-class-c-type -double 0.0 "double" \ set-class-c-type -complex-float C{ 0.0 0.0 } "complex-float" \ set-class-c-type -complex-double C{ 0.0 0.0 } "complex-double" \ set-class-c-type - -char [ 8 bits 8 >signed ] "coercer" set-word-prop -uchar [ 8 bits ] "coercer" set-word-prop -short [ 16 bits 16 >signed ] "coercer" set-word-prop -ushort [ 16 bits ] "coercer" set-word-prop -int [ 32 bits 32 >signed ] "coercer" set-word-prop -uint [ 32 bits ] "coercer" set-word-prop -long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop -ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop -longlong [ 64 bits 64 >signed ] "coercer" set-word-prop -ulonglong [ 64 bits ] "coercer" set-word-prop - -PREDICATE: c-type-class < class - "class-c-type" word-prop ; - -GENERIC: direct-array-of ( alien len class -- array ) inline - -M: c-type-class direct-array-of - class-direct-array execute( alien len -- array ) ; inline - -M: c-type-class c-type class-c-type ; -M: c-type-class c-type-align class-c-type c-type-align ; -M: c-type-class c-type-getter class-c-type c-type-getter ; -M: c-type-class c-type-setter class-c-type c-type-setter ; -M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ; -M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ; -M: c-type-class heap-size class-c-type heap-size ; - diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor index 6bf62f694c..feeecd881b 100644 --- a/extra/classes/struct/prettyprint/prettyprint.factor +++ b/extra/classes/struct/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license -USING: accessors assocs classes classes.struct kernel math -prettyprint.backend prettyprint.custom prettyprint.sections -see.private sequences words ; +USING: accessors assocs classes classes.struct combinators +kernel math prettyprint.backend prettyprint.custom +prettyprint.sections see.private sequences words ; IN: classes.struct.prettyprint assoc ( struct -- assoc ) [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ; +: pprint-struct-slot ( slot -- ) + > text ] + [ c-type>> text ] + [ read-only>> [ \ read-only pprint-word ] when ] + [ initial>> [ \ initial: pprint-word pprint* ] when* ] + } cleave + \ } pprint-word block> ; + PRIVATE> M: struct-class see-class* pprint-; block> ; M: struct pprint-delims diff --git a/extra/classes/struct/struct-docs.factor b/extra/classes/struct/struct-docs.factor index 83d5859f7c..2b27672018 100644 --- a/extra/classes/struct/struct-docs.factor +++ b/extra/classes/struct/struct-docs.factor @@ -24,7 +24,7 @@ HELP: STRUCT: { $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:" { $list { "Struct classes cannot have a superclass defined." } -{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." } +{ "The slots of a struct must all have a type declared. The type must be a C type." } { { $link read-only } " slots on structs are not enforced, though they may be declared." } } } ; diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 467f9da67b..536737d2d0 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,11 +1,25 @@ ! (c)Joe Groff bsd license -USING: accessors alien.c-types alien.structs.fields alien.syntax -classes.c-types classes.struct combinators io.streams.string kernel -libc literals math multiline namespaces prettyprint prettyprint.config -see tools.test ; -FROM: classes.c-types => float ; +USING: accessors alien.c-types alien.libraries +alien.structs.fields alien.syntax classes.struct combinators +io.pathnames io.streams.string kernel libc literals math +multiline namespaces prettyprint prettyprint.config see system +tools.test ; IN: classes.struct.tests +<< +: libfactor-ffi-tests-path ( -- string ) + "resource:" (normalize-path) + { + { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } + { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } + { [ os unix? ] [ "libfactor-ffi-test.so" ] } + } cond append-path ; + +"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library + +"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library +>> + STRUCT: struct-test-foo { x char } { y int initial: 123 } @@ -56,15 +70,14 @@ UNION-STRUCT: struct-test-float-and-bits with-variable ] unit-test -[ <" USING: classes.c-types classes.struct kernel ; +[ <" USING: classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo - { x char initial: 0 } { y int initial: 123 } - { z boolean initial: f } ; + { x char initial: 0 } { y int initial: 123 } { z bool } ; "> ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: classes.c-types classes.struct ; +[ <" USING: classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; @@ -75,21 +88,21 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "x" } { offset 0 } - { type char } + { type "char" } { reader x>> } { writer (>>x) } } T{ field-spec { name "y" } { offset 4 } - { type int } + { type "int" } { reader y>> } { writer (>>y) } } T{ field-spec { name "z" } { offset 8 } - { type bool } + { type "bool" } { reader z>> } { writer (>>z) } } @@ -99,14 +112,14 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "f" } { offset 0 } - { type float } + { type "float" } { reader f>> } { writer (>>f) } } T{ field-spec { name "bits" } { offset 0 } - { type uint } + { type "uint" } { reader bits>> } { writer (>>bits) } } diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 02d0a056a8..33e5ba89ae 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -1,10 +1,11 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays -byte-arrays classes classes.c-types classes.parser classes.tuple +byte-arrays classes classes.parser classes.tuple classes.tuple.parser classes.tuple.private combinators combinators.smart fry generalizations generic.parser kernel -kernel.private libc macros make math math.order parser -quotations sequences slots slots.private struct-arrays words ; +kernel.private lexer libc macros make math math.order parser +quotations sequences slots slots.private struct-arrays +vectors words ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -13,6 +14,9 @@ IN: classes.struct TUPLE: struct { (underlying) c-ptr read-only } ; +TUPLE: struct-slot-spec < slot-spec + c-type ; + PREDICATE: struct-class < tuple-class \ struct subclass-of? ; @@ -52,11 +56,11 @@ MACRO: ( class -- quot: ( ... -- struct ) ) [ struct-slots [ initial>> ] map over length tail append ] keep ; : (reader-quot) ( slot -- quot ) - [ class>> c-type-getter-boxer ] + [ c-type>> c-type-getter-boxer ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (writer-quot) ( slot -- quot ) - [ class>> c-setter ] + [ c-type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (boxer-quot) ( class -- quot ) @@ -96,7 +100,7 @@ M: struct-class writer-quot field-spec new swap { [ name>> >>name ] [ offset>> >>offset ] - [ class>> >>type ] + [ c-type>> >>type ] [ name>> reader-word >>reader ] [ name>> writer-word >>writer ] } cleave ; @@ -111,9 +115,12 @@ M: struct-class writer-quot } cleave (define-struct) ] [ - [ name>> c-type ] - [ (unboxer-quot) >>unboxer-quot ] - [ (boxer-quot) >>boxer-quot ] tri drop + { + [ name>> c-type ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] + [ >>boxed-class ] + } cleave drop ] bi ; : align-offset ( offset class -- offset' ) @@ -121,15 +128,15 @@ M: struct-class writer-quot : struct-offsets ( slots -- size ) 0 [ - [ class>> align-offset ] keep - [ (>>offset) ] [ class>> heap-size + ] 2bi + [ c-type>> align-offset ] keep + [ (>>offset) ] [ c-type>> heap-size + ] 2bi ] reduce ; : union-struct-offsets ( slots -- size ) - [ 0 >>offset class>> heap-size ] [ max ] map-reduce ; + [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ; : struct-align ( slots -- align ) - [ class>> c-type-align ] [ max ] map-reduce ; + [ c-type>> c-type-align ] [ max ] map-reduce ; M: struct-class c-type name>> c-type ; @@ -153,9 +160,6 @@ M: struct-class c-type-unboxer-quot M: struct-class heap-size "struct-size" word-prop ; -M: struct-class direct-array-of - ; - ! class definition : struct-prototype ( class -- prototype ) @@ -180,7 +184,7 @@ M: struct-class direct-array-of [ (define-struct-slot-values-method) ] tri ; : check-struct-slots ( slots -- ) - [ class>> c-type drop ] each ; + [ c-type>> c-type drop ] each ; : (define-struct-class) ( class slots offsets-quot -- ) [ drop struct f define-tuple-class ] @@ -197,8 +201,27 @@ M: struct-class direct-array-of : define-union-struct-class ( class slots -- ) [ union-struct-offsets ] (define-struct-class) ; +ERROR: invalid-struct-slot token ; + +: struct-slot-class ( c-type -- class' ) + c-type boxed-class>> + dup \ byte-array = [ drop \ c-ptr ] when ; + +: parse-struct-slot ( -- slot ) + struct-slot-spec new + scan >>name + scan [ >>c-type ] [ struct-slot-class >>class ] bi + \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ; + +: parse-struct-slots ( slots -- slots' more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot over push t ] } + [ invalid-struct-slot ] + } case ; + : parse-struct-definition ( -- class slots ) - CREATE-CLASS [ parse-tuple-slots ] { } make ; + CREATE-CLASS 8 [ parse-struct-slots ] [ ] while >array ; SYNTAX: STRUCT: parse-struct-definition define-struct-class ; From 847cd797bbbcde7072706e4ff3e2e575b0f48f67 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 13:18:20 -0500 Subject: [PATCH 07/14] make classes.struct work with string pointer slots --- extra/classes/struct/struct-tests.factor | 15 +++++++++++++-- extra/classes/struct/struct.factor | 2 +- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 536737d2d0..51df207003 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license USING: accessors alien.c-types alien.libraries alien.structs.fields alien.syntax classes.struct combinators -io.pathnames io.streams.string kernel libc literals math +destructors io.pathnames io.streams.string kernel libc literals math multiline namespaces prettyprint prettyprint.config see system tools.test ; IN: classes.struct.tests @@ -54,7 +54,18 @@ UNION-STRUCT: struct-test-float-and-bits [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test -[ ] [ struct-test-foo malloc-struct free ] unit-test +[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test + +STRUCT: struct-test-string-ptr + { x char* } ; + +[ "hello world" ] [ + [ + struct-test-string-ptr + "hello world" utf8 malloc-string &free >>x + x>> + ] with-destructors +] unit-test [ "S{ struct-test-foo { y 7654 } }" ] [ diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 33e5ba89ae..51df296f1a 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -204,7 +204,7 @@ M: struct-class heap-size ERROR: invalid-struct-slot token ; : struct-slot-class ( c-type -- class' ) - c-type boxed-class>> + c-type c-type-boxed-class dup \ byte-array = [ drop \ c-ptr ] when ; : parse-struct-slot ( -- slot ) From f56615cec0a0d44ab8450d5c811e3d474f9d9cf3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 15:58:18 -0500 Subject: [PATCH 08/14] add an X-sequence mixin class for each specialized array type to span X-array, X-vector, and direct-X-array --- basis/specialized-arrays/direct/functor/functor.factor | 3 +++ basis/specialized-arrays/functor/functor.factor | 5 +++++ basis/specialized-vectors/functor/functor.factor | 3 +++ 3 files changed, 11 insertions(+) diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index b49dfa35e4..89d1b5423d 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -8,6 +8,7 @@ IN: specialized-arrays.direct.functor FUNCTOR: define-direct-array ( T -- ) A' IS ${T}-array +S IS ${T}-sequence >A' IS >${T}-array IS <${A'}> A'{ IS ${A'}{ @@ -24,6 +25,8 @@ TUPLE: A { underlying c-ptr read-only } { length fixnum read-only } ; +INSTANCE: A S + : ( alien len -- direct-array ) A boa ; inline M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 06b9aef17d..a8d8d677ec 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -16,6 +16,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) A DEFINES-CLASS ${T}-array +S DEFINES-CLASS ${T}-sequence DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} @@ -27,10 +28,14 @@ SET-NTH [ T dup c-setter array-accessor ] WHERE +MIXIN: S + TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; +INSTANCE: A S + : ( n -- specialized-array ) dup T A boa ; inline : (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 08c44cd197..48c480b4d1 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- ) V DEFINES-CLASS ${T}-vector A IS ${T}-array +S IS ${T}-sequence IS <${A}> >V DEFERS >${V} @@ -19,6 +20,8 @@ WHERE V A vectors.functor:define-vector +INSTANCE: V S + M: V contract 2drop ; M: V byte-length underlying>> byte-length ; From 182963b9c49d2c0546c5a87e7d57b9bdb535d924 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 17:19:26 -0500 Subject: [PATCH 09/14] add missing use to classes.struct tests --- extra/classes/struct/struct-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 51df207003..5da1714803 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,9 +1,9 @@ ! (c)Joe Groff bsd license USING: accessors alien.c-types alien.libraries alien.structs.fields alien.syntax classes.struct combinators -destructors io.pathnames io.streams.string kernel libc literals math -multiline namespaces prettyprint prettyprint.config see system -tools.test ; +destructors io.encodings.utf8 io.pathnames io.streams.string +kernel libc literals math multiline namespaces prettyprint +prettyprint.config see system tools.test ; IN: classes.struct.tests << From 79787f6259a8861055ed1de71f28660781729956 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 17:56:01 -0500 Subject: [PATCH 10/14] associate specialized-arrays vocabs with c-types; add words for requiring vocabs and constructing arrays by C type --- basis/alien/c-types/c-types.factor | 96 ++++++++++++++++++- .../direct/functor/functor.factor | 8 +- .../specialized-arrays/functor/functor.factor | 9 +- .../functor/functor.factor | 3 +- 4 files changed, 108 insertions(+), 8 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 2eba6a2b9e..65f663e7b6 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes ; +classes vocabs vocabs.loader ; IN: alien.c-types DEFER: @@ -27,7 +27,12 @@ TUPLE: c-type < abstract-c-type boxer unboxer { rep initial: int-rep } -stack-align? ; +stack-align? +array-class +array-constructor +direct-array-class +direct-array-constructor +sequence-mixin-class ; : ( -- type ) \ c-type new ; @@ -71,6 +76,48 @@ M: string c-type ( name -- type ) ] ?if ] if ; +: ?require-word ( word/pair -- ) + dup word? [ drop ] [ first require ] ?if ; + +GENERIC: require-c-type-arrays ( c-type -- ) + +M: object require-c-type-arrays + drop ; + +M: c-type require-c-type-arrays + [ array-class>> ?require-word ] + [ sequence-mixin-class>> ?require-word ] + [ direct-array-class>> ?require-word ] tri ; + +M: string require-c-type-arrays + c-type require-c-type-arrays ; + +M: array require-c-type-arrays + first c-type require-c-type-arrays ; + +GENERIC: c-type-array-constructor ( c-type -- word ) foldable + +M: string c-type-array-constructor + c-type c-type-array-constructor ; +M: array c-type-array-constructor + first c-type c-type-array-constructor ; +M: c-type c-type-array-constructor + array-constructor>> ; + +GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable + +M: string c-type-direct-array-constructor + c-type c-type-array-constructor ; +M: array c-type-direct-array-constructor + first c-type c-type-direct-array-constructor ; +M: c-type c-type-direct-array-constructor + direct-array-constructor>> ; + +: ( len c-type -- array ) + c-type-array-constructor execute( len -- array ) ; inline +: ( len c-type -- array ) + c-type-direct-array-constructor execute( len -- array ) ; inline + GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; @@ -293,6 +340,36 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: ?lookup ( vocab word -- word/pair ) + over vocab [ swap lookup ] [ 2array ] if ; + +: set-array-class* ( c-type vocab-stem type-stem -- c-type ) + { + [ + [ "specialized-arrays." prepend ] + [ "-array" append ] bi* ?lookup >>array-class + ] + [ + [ "specialized-arrays." prepend ] + [ "<" "-array>" surround ] bi* ?lookup >>array-constructor + ] + [ + [ "specialized-arrays." prepend ] + [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "" surround ] bi* ?lookup >>direct-array-constructor + ] + } 2cleave ; + +: set-array-class ( c-type stem -- c-type ) + dup set-array-class* ; + CONSTANT: primitive-types { "char" "uchar" @@ -315,6 +392,7 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer + "alien" "void*" set-array-class* "void*" define-primitive-type @@ -326,6 +404,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer + "longlong" set-array-class "longlong" define-primitive-type @@ -337,6 +416,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer + "ulonglong" set-array-class "ulonglong" define-primitive-type @@ -348,6 +428,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer + "long" set-array-class "long" define-primitive-type @@ -359,6 +440,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer + "ulong" set-array-class "ulong" define-primitive-type @@ -370,6 +452,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer + "int" set-array-class "int" define-primitive-type @@ -381,6 +464,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer + "uint" set-array-class "uint" define-primitive-type @@ -392,6 +476,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer + "short" set-array-class "short" define-primitive-type @@ -403,6 +488,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer + "ushort" set-array-class "ushort" define-primitive-type @@ -414,6 +500,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer + "char" set-array-class "char" define-primitive-type @@ -425,6 +512,7 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer + "uchar" set-array-class "uchar" define-primitive-type @@ -434,6 +522,7 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer + "bool" set-array-class "bool" define-primitive-type @@ -447,6 +536,7 @@ CONSTANT: primitive-types "to_float" >>unboxer single-float-rep >>rep [ >float ] >>unboxer-quot + "float" set-array-class "float" define-primitive-type @@ -460,9 +550,11 @@ CONSTANT: primitive-types "to_double" >>unboxer double-float-rep >>rep [ >float ] >>unboxer-quot + "double" set-array-class "double" define-primitive-type "long" "ptrdiff_t" typedef "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit + diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 89d1b5423d..4b80940153 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -25,8 +25,6 @@ TUPLE: A { underlying c-ptr read-only } { length fixnum read-only } ; -INSTANCE: A S - : ( alien len -- direct-array ) A boa ; inline M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; @@ -41,5 +39,11 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; INSTANCE: A sequence +INSTANCE: A S + +T c-type + \ A >>direct-array-class + \ >>direct-array-constructor + drop ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index a8d8d677ec..3341a909d2 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -34,8 +34,6 @@ TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; -INSTANCE: A S - : ( n -- specialized-array ) dup T A boa ; inline : (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline @@ -78,7 +76,14 @@ M: A pprint* pprint-object ; SYNTAX: A{ \ } [ >A ] parse-literal ; INSTANCE: A sequence +INSTANCE: A S A T c-type-boxed-class specialize-vector-words +T c-type + \ A >>array-class + \ >>array-constructor + \ S >>sequence-mixin-class + drop + ;FUNCTOR diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 48c480b4d1..27bba3f9a6 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -20,8 +20,6 @@ WHERE V A vectors.functor:define-vector -INSTANCE: V S - M: V contract 2drop ; M: V byte-length underlying>> byte-length ; @@ -35,5 +33,6 @@ M: V pprint* pprint-object ; SYNTAX: V{ \ } [ >V ] parse-literal ; INSTANCE: V growable +INSTANCE: V S ;FUNCTOR From 59cdec755a298e454729fc28e653dc327b468c81 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 18:24:49 -0500 Subject: [PATCH 11/14] throw a better error if is called when specialized array vocab isn't loaded. fix --- basis/alien/c-types/c-types.factor | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 65f663e7b6..675bc56503 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -95,6 +95,8 @@ M: string require-c-type-arrays M: array require-c-type-arrays first c-type require-c-type-arrays ; +ERROR: specialized-array-vocab-not-loaded vocab word ; + GENERIC: c-type-array-constructor ( c-type -- word ) foldable M: string c-type-array-constructor @@ -102,21 +104,26 @@ M: string c-type-array-constructor M: array c-type-array-constructor first c-type c-type-array-constructor ; M: c-type c-type-array-constructor - array-constructor>> ; + array-constructor>> dup word? + [ first2 specialized-array-vocab-not-loaded ] unless ; GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable M: string c-type-direct-array-constructor - c-type c-type-array-constructor ; + c-type c-type-direct-array-constructor ; M: array c-type-direct-array-constructor first c-type c-type-direct-array-constructor ; M: c-type c-type-direct-array-constructor - direct-array-constructor>> ; + direct-array-constructor>> dup word? + [ first2 specialized-array-vocab-not-loaded ] unless ; -: ( len c-type -- array ) +GENERIC: ( len c-type -- array ) +M: object c-type-array-constructor execute( len -- array ) ; inline -: ( len c-type -- array ) - c-type-direct-array-constructor execute( len -- array ) ; inline + +GENERIC: ( alien len c-type -- array ) +M: object + c-type-direct-array-constructor execute( alien len -- array ) ; inline GENERIC: c-type-class ( name -- class ) From 005107973f43952b5b52173c2621ad4121dac064 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 18:51:56 -0500 Subject: [PATCH 12/14] docs for require-c-type-arrays, , --- basis/alien/arrays/arrays-docs.factor | 7 ++++++- basis/alien/c-types/c-types-docs.factor | 17 ++++++++++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index c5efe1e030..e8ebe1824d 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ; ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." $nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." +$nl +"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:" +{ $subsection require-c-type-arrays } +{ $subsection } +{ $subsection } ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index c9c1ecd0e5..f5f9e004c4 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors ; +io.encodings.string debugger destructors vocabs.loader ; HELP: { $values { "type" hashtable } } @@ -128,6 +128,21 @@ HELP: malloc-string } } ; +HELP: require-c-type-arrays +{ $values { "c-type" "a C type" } } +{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } +{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ; + +HELP: +{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } } +{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ; + +HELP: +{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } +{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; + ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl From f4acf22433091f159483488204b7a231c682fa3a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 18:54:15 -0500 Subject: [PATCH 13/14] specialized-arrays.direct: define byte-length on direct arrays --- basis/specialized-arrays/direct/functor/functor.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 4b80940153..37978b6dfa 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -32,6 +32,8 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; M: A like drop dup A instance? [ >A' ] unless ; M: A new-sequence drop ; +M: A byte-length length>> T heap-size * ; + M: A pprint-delims drop \ A'{ \ } ; M: A >pprint-sequence ; From d42edd4e3b016d2059d270152f041edfe10e66f2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 19:04:29 -0500 Subject: [PATCH 14/14] byte-length method for classes.struct STRUCTs --- extra/classes/struct/struct-tests.factor | 1 + extra/classes/struct/struct.factor | 10 +++++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 5da1714803..272b8eb129 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -30,6 +30,7 @@ STRUCT: struct-test-bar { foo struct-test-foo } ; [ 12 ] [ struct-test-foo heap-size ] unit-test +[ 12 ] [ struct-test-foo byte-length ] unit-test [ 16 ] [ struct-test-bar heap-size ] unit-test [ 123 ] [ struct-test-foo y>> ] unit-test [ 123 ] [ struct-test-bar foo>> y>> ] unit-test diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 51df296f1a..7d4eed80af 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -94,6 +94,10 @@ M: struct-class writer-quot [ \ struct-slot-values create-method-in ] [ struct-slot-values-quot ] bi define ; +: (define-byte-length-method) ( class -- ) + [ \ byte-length create-method-in ] + [ heap-size \ drop swap [ ] 2sequence ] bi define ; + ! Struct as c-type : slot>field ( slot -- field ) @@ -172,6 +176,10 @@ M: struct-class heap-size over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if ] each ; +: (struct-methods) ( class -- ) + [ (define-struct-slot-values-method) ] + [ (define-byte-length-method) ] bi ; + : (struct-word-props) ( class slots size align -- ) [ [ "struct-slots" set-word-prop ] @@ -181,7 +189,7 @@ M: struct-class heap-size [ "struct-align" set-word-prop ] tri-curry* [ tri ] 3curry [ dup struct-prototype "prototype" set-word-prop ] - [ (define-struct-slot-values-method) ] tri ; + [ (struct-methods) ] tri ; : check-struct-slots ( slots -- ) [ c-type>> c-type drop ] each ;