+++ /dev/null
-! (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"
+++ /dev/null
-! (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 <direct-array> -- )
- [ "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 -- <direct-array> )
- "class-direct-array" word-prop ;
-
-\ f f "void*" \ <direct-void*-array> set-class-c-type
-void* f "void*" \ <direct-void*-array> set-class-c-type
-pinned-c-ptr f "void*" \ <direct-void*-array> set-class-c-type
-bool f "bool" \ <direct-bool-array> set-class-c-type
-boolean f "bool" \ <direct-bool-array> set-class-c-type
-char 0 "char" \ <direct-char-array> set-class-c-type
-uchar 0 "uchar" \ <direct-uchar-array> set-class-c-type
-short 0 "short" \ <direct-short-array> set-class-c-type
-ushort 0 "ushort" \ <direct-ushort-array> set-class-c-type
-int 0 "int" \ <direct-int-array> set-class-c-type
-uint 0 "uint" \ <direct-uint-array> set-class-c-type
-long 0 "long" \ <direct-long-array> set-class-c-type
-ulong 0 "ulong" \ <direct-ulong-array> set-class-c-type
-longlong 0 "longlong" \ <direct-longlong-array> set-class-c-type
-ulonglong 0 "ulonglong" \ <direct-ulonglong-array> set-class-c-type
-float 0.0 "float" \ <direct-float-array> set-class-c-type
-double 0.0 "double" \ <direct-double-array> set-class-c-type
-complex-float C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-array> set-class-c-type
-complex-double C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> 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 ;
-
! (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
<PRIVATE
: 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-slot ] each
+ <block struct-slots [ pprint-struct-slot ] each
block> pprint-; block> ;
M: struct pprint-delims
{ $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." }
} } ;
! (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 }
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 } ;
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) }
}
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) }
}
! (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
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 [ 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 )
field-spec new swap {
[ name>> >>name ]
[ offset>> >>offset ]
- [ class>> >>type ]
+ [ c-type>> >>type ]
[ name>> reader-word >>reader ]
[ name>> writer-word >>writer ]
} cleave ;
} 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' )
: 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 ;
M: struct-class heap-size
"struct-size" word-prop ;
-M: struct-class direct-array-of
- <direct-struct-array> ;
-
! class definition
: struct-prototype ( class -- prototype )
[ (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 ]
: 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 <vector> [ parse-struct-slots ] [ ] while >array ;
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
projects / factor.git / commitdiff