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 diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 2eba6a2b9e..675bc56503 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,55 @@ 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 ; + +ERROR: specialized-array-vocab-not-loaded vocab word ; + +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>> 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-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>> dup word? + [ first2 specialized-array-vocab-not-loaded ] unless ; + +GENERIC: ( len c-type -- array ) +M: object + c-type-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 ) M: abstract-c-type c-type-class class>> ; @@ -293,6 +347,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 +399,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 +411,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer + "longlong" set-array-class "longlong" define-primitive-type @@ -337,6 +423,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer + "ulonglong" set-array-class "ulonglong" define-primitive-type @@ -348,6 +435,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer + "long" set-array-class "long" define-primitive-type @@ -359,6 +447,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer + "ulong" set-array-class "ulong" define-primitive-type @@ -370,6 +459,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer + "int" set-array-class "int" define-primitive-type @@ -381,6 +471,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer + "uint" set-array-class "uint" define-primitive-type @@ -392,6 +483,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer + "short" set-array-class "short" define-primitive-type @@ -403,6 +495,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer + "ushort" set-array-class "ushort" define-primitive-type @@ -414,6 +507,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer + "char" set-array-class "char" define-primitive-type @@ -425,6 +519,7 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer + "uchar" set-array-class "uchar" define-primitive-type @@ -434,6 +529,7 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer + "bool" set-array-class "bool" define-primitive-type @@ -447,6 +543,7 @@ CONSTANT: primitive-types "to_float" >>unboxer single-float-rep >>rep [ >float ] >>unboxer-quot + "float" set-array-class "float" define-primitive-type @@ -460,9 +557,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 b49dfa35e4..37978b6dfa 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'}{ @@ -31,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 ; @@ -38,5 +41,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 06b9aef17d..3341a909d2 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,6 +28,8 @@ SET-NTH [ T dup c-setter array-accessor ] WHERE +MIXIN: S + TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; @@ -73,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 08c44cd197..27bba3f9a6 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} @@ -32,5 +33,6 @@ M: V pprint* pprint-object ; SYNTAX: V{ \ } [ >V ] parse-literal ; INSTANCE: V growable +INSTANCE: V S ;FUNCTOR 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* 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 3945924a57..437685137c 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -9,8 +9,7 @@ C-LIBRARY: test C-INCLUDE: C-INCLUDE: - -C-TYPEDEF: char bool +C-INCLUDE: CM-FUNCTION: void outarg1 ( int* a ) *a += 2; 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 58ebf7a063..0000000000 --- a/extra/classes/c-types/c-types-docs.factor +++ /dev/null @@ -1,72 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien arrays classes help.markup help.syntax kernel math -specialized-arrays.direct ; -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" 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: single-complex -{ $class-description "A single-precision complex floating point quantity." } ; - -HELP: single-float -{ $class-description "A single-precision floating point quantity." } ; - -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." } ; - -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 single-float } -{ $subsection float } -{ $subsection single-complex } -{ $subsection complex } -{ $subsection pinned-c-ptr } -"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 e53a813825..0000000000 --- a/extra/classes/c-types/c-types.factor +++ /dev/null @@ -1,118 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien alien.c-types classes classes.predicate kernel -math 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 ; -IN: classes.c-types - -PREDICATE: char < fixnum - HEX: -80 HEX: 7f between? ; - -PREDICATE: uchar < fixnum - HEX: 0 HEX: ff between? ; - -PREDICATE: short < fixnum - HEX: -8000 HEX: 7fff between? ; - -PREDICATE: ushort < fixnum - HEX: 0 HEX: ffff between? ; - -PREDICATE: int < integer - HEX: -8000,0000 HEX: 7fff,ffff between? ; - -PREDICATE: uint < integer - HEX: 0 HEX: ffff,ffff between? ; - -PREDICATE: longlong < integer - HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ; - -PREDICATE: ulonglong < integer - HEX: 0 HEX: ffff,ffff,ffff,ffff between? ; - -UNION: single-float float ; -UNION: single-complex 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 - 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 - 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 -pinned-c-ptr f "void*" \ 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 "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 - -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 912d33c7bc..272b8eb129 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,19 +1,36 @@ ! (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.libraries +alien.structs.fields alien.syntax classes.struct combinators +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 +<< +: 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 } - { z boolean } ; + { z bool } ; STRUCT: struct-test-bar { w ushort initial: HEX: ffff } { 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 @@ -32,13 +49,24 @@ 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 [ 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 } }" ] [ @@ -54,18 +82,17 @@ 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 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 +100,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 +124,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..7d4eed80af 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 ) @@ -90,13 +94,17 @@ 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 ) field-spec new swap { [ name>> >>name ] [ offset>> >>offset ] - [ class>> c-type >>type ] + [ c-type>> >>type ] [ name>> reader-word >>reader ] [ name>> writer-word >>writer ] } cleave ; @@ -111,9 +119,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 +132,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 +164,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 ) @@ -168,6 +176,10 @@ M: struct-class direct-array-of 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 ] @@ -177,10 +189,10 @@ M: struct-class direct-array-of [ "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 -- ) - [ 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 +209,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 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 ;