classes.c-types is kinda half-baked. get rid of it, and make classes.struct parse c types directly
Joe Groff
parent
a4aa0dddbe
commit
56ca6ceeef
|
|
@ -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"
|
||||
|
|
@ -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 <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 ;
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -14,11 +14,21 @@ IN: classes.struct.prettyprint
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
} } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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) }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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: <struct-boa> ( 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
|
||||
<direct-struct-array> ;
|
||||
|
||||
! 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 <vector> [ parse-struct-slots ] [ ] while >array ;
|
||||
|
||||
SYNTAX: STRUCT:
|
||||
parse-struct-definition define-struct-class ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue