--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors assocs classes classes.struct combinators
+kernel math prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+ struct-slots dup length 2 >=
+ [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+ [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+ [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+: pprint-struct-slot ( slot -- )
+ <flow \ { pprint-word
+ {
+ [ name>> 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*
+ <colon dup struct-definer-word pprint-word dup pprint-word
+ <block struct-slots [ pprint-struct-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+ [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+ [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+ { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: <struct>
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $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 a C type." }
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+ { "ptr" c-ptr } { "class" class }
+ { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien.c-types alien.libraries
+alien.structs.fields alien.syntax ascii classes.struct combinators
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math multiline namespaces prettyprint
+prettyprint.config see sequences specialized-arrays.ushort
+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 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 <struct> byte-length ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+ { f float }
+ { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] 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 <struct>
+ "hello world" utf8 malloc-string &free >>x
+ x>>
+ ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+ f boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+ t boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+ { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+ { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+ T{ field-spec
+ { name "x" }
+ { offset 0 }
+ { type "char" }
+ { reader x>> }
+ { writer (>>x) }
+ }
+ T{ field-spec
+ { name "y" }
+ { offset 4 }
+ { type "int" }
+ { reader y>> }
+ { writer (>>y) }
+ }
+ T{ field-spec
+ { name "z" }
+ { offset 8 }
+ { type "bool" }
+ { reader z>> }
+ { writer (>>z) }
+ }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+ T{ field-spec
+ { name "f" }
+ { offset 0 }
+ { type "float" }
+ { reader f>> }
+ { writer (>>f) }
+ }
+ T{ field-spec
+ { name "bits" }
+ { offset 0 }
+ { 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 <struct-boa> 4 ffi_test_11 ] unit-test
+
+STRUCT: struct-test-array-slots
+ { x int }
+ { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+ { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+ struct-test-array-slots <struct>
+ [ y>> [ 8 3 ] dip set-nth ]
+ [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
+] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
+byte-arrays classes classes.parser classes.tuple
+classes.tuple.parser classes.tuple.private combinators
+combinators.smart fry generalizations generic.parser kernel
+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
+
+! struct class
+
+TUPLE: struct
+ { (underlying) c-ptr read-only } ;
+
+TUPLE: struct-slot-spec < slot-spec
+ c-type ;
+
+PREDICATE: struct-class < tuple-class
+ \ struct subclass-of? ;
+
+: struct-slots ( struct -- slots )
+ "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+ 2 slot { c-ptr } declare ; inline
+
+: memory>struct ( ptr class -- struct )
+ over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
+ tuple-layout <tuple> [ 2 set-slot ] keep ;
+
+: malloc-struct ( class -- struct )
+ [ heap-size malloc ] keep memory>struct ; inline
+
+: (struct) ( class -- struct )
+ [ heap-size <byte-array> ] keep memory>struct ; inline
+
+: <struct> ( class -- struct )
+ dup "prototype" word-prop
+ [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+ [
+ [ <wrapper> \ (struct) [ ] 2sequence ]
+ [
+ struct-slots
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+: pad-struct-slots ( values class -- values' class )
+ [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+ [ c-type>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ c-type>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+ '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+ drop [ >c-ptr ] ;
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ (struct) ] [ struct-slots ] bi
+ [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+ nip (reader-quot) ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+: struct-slot-values-quot ( class -- quot )
+ struct-slots
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: (define-struct-slot-values-method) ( class -- )
+ [ \ 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 ]
+ [ c-type>> >>type ]
+ [ name>> reader-word >>reader ]
+ [ name>> writer-word >>writer ]
+ } cleave ;
+
+: define-struct-for-class ( class -- )
+ [
+ {
+ [ name>> ]
+ [ "struct-size" word-prop ]
+ [ "struct-align" word-prop ]
+ [ struct-slots [ slot>field ] map ]
+ } cleave
+ struct-type (define-struct)
+ ] [
+ {
+ [ name>> c-type ]
+ [ (unboxer-quot) >>unboxer-quot ]
+ [ (boxer-quot) >>boxer-quot ]
+ [ >>boxed-class ]
+ } cleave drop
+ ] bi ;
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ c-type>> align-offset ] keep
+ [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ c-type>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class c-type
+ name>> c-type ;
+
+M: struct-class c-type-align
+ "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+ (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+ (unboxer-quot) ;
+
+M: struct-class heap-size
+ "struct-size" word-prop ;
+
+! class definition
+
+: struct-prototype ( class -- prototype )
+ [ heap-size <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ 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 ]
+ [ define-accessors ] 2bi
+ ]
+ [ "struct-size" set-word-prop ]
+ [ "struct-align" set-word-prop ] tri-curry*
+ [ tri ] 3curry
+ [ dup struct-prototype "prototype" set-word-prop ]
+ [ (struct-methods) ] tri ;
+
+: check-struct-slots ( slots -- )
+ [ c-type>> c-type drop ] each ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+ [ drop struct f define-tuple-class ]
+ swap '[
+ make-slots dup
+ [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+ (struct-word-props)
+ ]
+ [ drop define-struct-for-class ] 2tri ; inline
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: 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 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+
+SYNTAX: STRUCT:
+ parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+ parse-struct-definition define-union-struct-class ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
+
+SYNTAX: S{
+ scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct combinators
-kernel math prettyprint.backend prettyprint.custom
-prettyprint.sections see.private sequences words ;
-IN: classes.struct.prettyprint
-
-<PRIVATE
-
-: struct-definer-word ( class -- word )
- struct-slots dup length 2 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
-
-: struct>assoc ( struct -- assoc )
- [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
-
-: pprint-struct-slot ( slot -- )
- <flow \ { pprint-word
- {
- [ name>> 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*
- <colon dup struct-definer-word pprint-word dup pprint-word
- <block struct-slots [ pprint-struct-slot ] each
- block> pprint-; block> ;
-
-M: struct pprint-delims
- drop \ S{ \ } ;
-
-M: struct >pprint-sequence
- [ class ] [ struct-slot-values ] bi class-slot-sequence ;
-
-M: struct pprint*
- [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien classes help.markup help.syntax kernel libc
-quotations slots ;
-IN: classes.struct
-
-HELP: <struct-boa>
-{ $values
- { "class" class }
-}
-{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
-
-HELP: <struct>
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
-
-{ <struct> <struct-boa> malloc-struct memory>struct } related-words
-
-HELP: STRUCT:
-{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $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 a C type." }
-{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
-
-HELP: S{
-{ $syntax "S{ class slots... }" }
-{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
-{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
-
-HELP: UNION-STRUCT:
-{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
-
-HELP: define-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
-
-HELP: define-union-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
-
-HELP: malloc-struct
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
-
-HELP: memory>struct
-{ $values
- { "ptr" c-ptr } { "class" class }
- { "struct" struct }
-}
-{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
-
-HELP: struct
-{ $class-description "The parent class of all struct types." } ;
-
-{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
-
-HELP: struct-class
-{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
-{ $subsection POSTPONE: STRUCT: }
-"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
-{ $subsection <struct> }
-{ $subsection <struct-boa> }
-{ $subsection malloc-struct }
-{ $subsection memory>struct }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
-
-ABOUT: "classes.struct"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.libraries
-alien.structs.fields alien.syntax ascii classes.struct combinators
-destructors io.encodings.utf8 io.pathnames io.streams.string
-kernel libc literals math multiline namespaces prettyprint
-prettyprint.config see sequences specialized-arrays.ushort
-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 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 <struct> byte-length ] unit-test
-[ 16 ] [ struct-test-bar heap-size ] unit-test
-[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
-[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
-
-[ 1 2 3 t ] [
- 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
- {
- [ w>> ]
- [ foo>> x>> ]
- [ foo>> y>> ]
- [ foo>> z>> ]
- } cleave
-] unit-test
-
-[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
-[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
-
-UNION-STRUCT: struct-test-float-and-bits
- { f float }
- { bits uint } ;
-
-[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
-[ 4 ] [ struct-test-float-and-bits heap-size ] 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 <struct>
- "hello world" utf8 malloc-string &free >>x
- x>>
- ] with-destructors
-] unit-test
-
-[ "S{ struct-test-foo { y 7654 } }" ]
-[
- f boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ "S{ struct-test-foo f 0 7654 f }" ]
-[
- t boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ <" USING: classes.struct ;
-IN: classes.struct.tests
-STRUCT: struct-test-foo
- { x char initial: 0 } { y int initial: 123 } { z bool } ;
-"> ]
-[ [ struct-test-foo see ] with-string-writer ] unit-test
-
-[ <" USING: classes.struct ;
-IN: classes.struct.tests
-UNION-STRUCT: struct-test-float-and-bits
- { f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
-[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
-
-[ {
- T{ field-spec
- { name "x" }
- { offset 0 }
- { type "char" }
- { reader x>> }
- { writer (>>x) }
- }
- T{ field-spec
- { name "y" }
- { offset 4 }
- { type "int" }
- { reader y>> }
- { writer (>>y) }
- }
- T{ field-spec
- { name "z" }
- { offset 8 }
- { type "bool" }
- { reader z>> }
- { writer (>>z) }
- }
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
-
-[ {
- T{ field-spec
- { name "f" }
- { offset 0 }
- { type "float" }
- { reader f>> }
- { writer (>>f) }
- }
- T{ field-spec
- { name "bits" }
- { offset 0 }
- { 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 <struct-boa> 4 ffi_test_11 ] unit-test
-
-STRUCT: struct-test-array-slots
- { x int }
- { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
- { z int } ;
-
-[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
-
-[ t ] [
- struct-test-array-slots <struct>
- [ y>> [ 8 3 ] dip set-nth ]
- [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
-] unit-test
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
-byte-arrays classes classes.parser classes.tuple
-classes.tuple.parser classes.tuple.private combinators
-combinators.smart fry generalizations generic.parser kernel
-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
-
-! struct class
-
-TUPLE: struct
- { (underlying) c-ptr read-only } ;
-
-TUPLE: struct-slot-spec < slot-spec
- c-type ;
-
-PREDICATE: struct-class < tuple-class
- \ struct subclass-of? ;
-
-: struct-slots ( struct -- slots )
- "struct-slots" word-prop ;
-
-! struct allocation
-
-M: struct >c-ptr
- 2 slot { c-ptr } declare ; inline
-
-: memory>struct ( ptr class -- struct )
- over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
- tuple-layout <tuple> [ 2 set-slot ] keep ;
-
-: malloc-struct ( class -- struct )
- [ heap-size malloc ] keep memory>struct ; inline
-
-: (struct) ( class -- struct )
- [ heap-size <byte-array> ] keep memory>struct ; inline
-
-: <struct> ( class -- struct )
- dup "prototype" word-prop
- [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
-
-MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
- [
- [ <wrapper> \ (struct) [ ] 2sequence ]
- [
- struct-slots
- [ length \ ndip ]
- [ [ name>> setter-word 1quotation ] map \ spread ] bi
- ] bi
- ] [ ] output>sequence ;
-
-: pad-struct-slots ( values class -- values' class )
- [ struct-slots [ initial>> ] map over length tail append ] keep ;
-
-: (reader-quot) ( slot -- quot )
- [ c-type>> c-type-getter-boxer ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (writer-quot) ( slot -- quot )
- [ c-type>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (boxer-quot) ( class -- quot )
- '[ _ memory>struct ] ;
-
-: (unboxer-quot) ( class -- quot )
- drop [ >c-ptr ] ;
-
-M: struct-class boa>object
- swap pad-struct-slots
- [ (struct) ] [ struct-slots ] bi
- [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
-
-! Struct slot accessors
-
-GENERIC: struct-slot-values ( struct -- sequence )
-
-M: struct-class reader-quot
- nip (reader-quot) ;
-
-M: struct-class writer-quot
- nip (writer-quot) ;
-
-: struct-slot-values-quot ( class -- quot )
- struct-slots
- [ name>> reader-word 1quotation ] map
- \ cleave [ ] 2sequence
- \ output>array [ ] 2sequence ;
-
-: (define-struct-slot-values-method) ( class -- )
- [ \ 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 ]
- [ c-type>> >>type ]
- [ name>> reader-word >>reader ]
- [ name>> writer-word >>writer ]
- } cleave ;
-
-: define-struct-for-class ( class -- )
- [
- {
- [ name>> ]
- [ "struct-size" word-prop ]
- [ "struct-align" word-prop ]
- [ struct-slots [ slot>field ] map ]
- } cleave
- struct-type (define-struct)
- ] [
- {
- [ name>> c-type ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ]
- [ >>boxed-class ]
- } cleave drop
- ] bi ;
-
-: align-offset ( offset class -- offset' )
- c-type-align align ;
-
-: struct-offsets ( slots -- size )
- 0 [
- [ c-type>> align-offset ] keep
- [ (>>offset) ] [ c-type>> heap-size + ] 2bi
- ] reduce ;
-
-: union-struct-offsets ( slots -- size )
- [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
-
-: struct-align ( slots -- align )
- [ c-type>> c-type-align ] [ max ] map-reduce ;
-
-M: struct-class c-type
- name>> c-type ;
-
-M: struct-class c-type-align
- "struct-align" word-prop ;
-
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
-
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
-
-M: struct-class heap-size
- "struct-size" word-prop ;
-
-! class definition
-
-: struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- 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 ]
- [ define-accessors ] 2bi
- ]
- [ "struct-size" set-word-prop ]
- [ "struct-align" set-word-prop ] tri-curry*
- [ tri ] 3curry
- [ dup struct-prototype "prototype" set-word-prop ]
- [ (struct-methods) ] tri ;
-
-: check-struct-slots ( slots -- )
- [ c-type>> c-type drop ] each ;
-
-: (define-struct-class) ( class slots offsets-quot -- )
- [ drop struct f define-tuple-class ]
- swap '[
- make-slots dup
- [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
- (struct-word-props)
- ]
- [ drop define-struct-for-class ] 2tri ; inline
-
-: define-struct-class ( class slots -- )
- [ struct-offsets ] (define-struct-class) ;
-
-: 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 8 <vector> [ parse-struct-slots ] [ ] while >array ;
-
-SYNTAX: STRUCT:
- parse-struct-definition define-struct-class ;
-SYNTAX: UNION-STRUCT:
- parse-struct-definition define-union-struct-class ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
-
-SYNTAX: S{
- scan-word dup struct-slots parse-tuple-literal-slots parsed ;
projects / factor.git / commitdiff