steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

classes.c-types is kinda half-baked. get rid of it, and make classes.struct parse c types directly

db4
Joe Groff 2009-08-25 13:03:43 -05:00
parent a4aa0dddbe
commit 56ca6ceeef
6 changed files with 83 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
extra/classes/c-types/c-types-docs.factor
View File

@ -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"

127
extra/classes/c-types/c-types.factor
View File

@ -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 ;

18
extra/classes/struct/prettyprint/prettyprint.factor
View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors assocs classes classes.struct kernel math USING: accessors assocs classes classes.struct combinators
prettyprint.backend prettyprint.custom prettyprint.sections kernel math prettyprint.backend prettyprint.custom
see.private sequences words ; prettyprint.sections see.private sequences words ;
IN: classes.struct.prettyprint IN: classes.struct.prettyprint
<PRIVATE <PRIVATE
@ -14,11 +14,21 @@ IN: classes.struct.prettyprint
: struct>assoc ( struct -- assoc ) : struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-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> PRIVATE>
M: struct-class see-class* M: struct-class see-class*
<colon dup struct-definer-word pprint-word dup pprint-word <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> ; block> pprint-; block> ;
M: struct pprint-delims M: struct pprint-delims

2
extra/classes/struct/struct-docs.factor
View File

@ -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:" { $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 { $list
{ "Struct classes cannot have a superclass defined." } { "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." } { { $link read-only } " slots on structs are not enforced, though they may be declared." }
} } ; } } ;

41
extra/classes/struct/struct-tests.factor
View File

@ -1,11 +1,25 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien.c-types alien.structs.fields alien.syntax USING: accessors alien.c-types alien.libraries
classes.c-types classes.struct combinators io.streams.string kernel alien.structs.fields alien.syntax classes.struct combinators
libc literals math multiline namespaces prettyprint prettyprint.config io.pathnames io.streams.string kernel libc literals math
see tools.test ; multiline namespaces prettyprint prettyprint.config see system
FROM: classes.c-types => float ; tools.test ;
IN: classes.struct.tests 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 STRUCT: struct-test-foo
{ x char } { x char }
{ y int initial: 123 } { y int initial: 123 }
@ -56,15 +70,14 @@ UNION-STRUCT: struct-test-float-and-bits
with-variable with-variable
] unit-test ] unit-test
[ <" USING: classes.c-types classes.struct kernel ; [ <" USING: classes.struct ;
IN: classes.struct.tests IN: classes.struct.tests
STRUCT: struct-test-foo STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { x char initial: 0 } { y int initial: 123 } { z bool } ;
{ z boolean initial: f } ;
"> ] "> ]
[ [ struct-test-foo see ] with-string-writer ] unit-test [ [ struct-test-foo see ] with-string-writer ] unit-test
[ <" USING: classes.c-types classes.struct ; [ <" USING: classes.struct ;
IN: classes.struct.tests IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ; { f float initial: 0.0 } { bits uint initial: 0 } ;
@ -75,21 +88,21 @@ UNION-STRUCT: struct-test-float-and-bits
T{ field-spec T{ field-spec
{ name "x" } { name "x" }
{ offset 0 } { offset 0 }
{ type char } { type "char" }
{ reader x>> } { reader x>> }
{ writer (>>x) } { writer (>>x) }
} }
T{ field-spec T{ field-spec
{ name "y" } { name "y" }
{ offset 4 } { offset 4 }
{ type int } { type "int" }
{ reader y>> } { reader y>> }
{ writer (>>y) } { writer (>>y) }
} }
T{ field-spec T{ field-spec
{ name "z" } { name "z" }
{ offset 8 } { offset 8 }
{ type bool } { type "bool" }
{ reader z>> } { reader z>> }
{ writer (>>z) } { writer (>>z) }
} }
@ -99,14 +112,14 @@ UNION-STRUCT: struct-test-float-and-bits
T{ field-spec T{ field-spec
{ name "f" } { name "f" }
{ offset 0 } { offset 0 }
{ type float } { type "float" }
{ reader f>> } { reader f>> }
{ writer (>>f) } { writer (>>f) }
} }
T{ field-spec T{ field-spec
{ name "bits" } { name "bits" }
{ offset 0 } { offset 0 }
{ type uint } { type "uint" }
{ reader bits>> } { reader bits>> }
{ writer (>>bits) } { writer (>>bits) }
} }

55
extra/classes/struct/struct.factor
View File

@ -1,10 +1,11 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays 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 classes.tuple.parser classes.tuple.private combinators
combinators.smart fry generalizations generic.parser kernel combinators.smart fry generalizations generic.parser kernel
kernel.private libc macros make math math.order parser kernel.private lexer libc macros make math math.order parser
quotations sequences slots slots.private struct-arrays words ; quotations sequences slots slots.private struct-arrays
vectors words ;
FROM: slots => reader-word writer-word ; FROM: slots => reader-word writer-word ;
IN: classes.struct IN: classes.struct
@ -13,6 +14,9 @@ IN: classes.struct
TUPLE: struct TUPLE: struct
{ (underlying) c-ptr read-only } ; { (underlying) c-ptr read-only } ;
TUPLE: struct-slot-spec < slot-spec
c-type ;
PREDICATE: struct-class < tuple-class PREDICATE: struct-class < tuple-class
\ struct subclass-of? ; \ struct subclass-of? ;
@ -52,11 +56,11 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[ struct-slots [ initial>> ] map over length tail append ] keep ; [ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot ) : (reader-quot) ( slot -- quot )
[ class>> c-type-getter-boxer ] [ c-type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ; [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot ) : (writer-quot) ( slot -- quot )
[ class>> c-setter ] [ c-type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ; [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (boxer-quot) ( class -- quot ) : (boxer-quot) ( class -- quot )
@ -96,7 +100,7 @@ M: struct-class writer-quot
field-spec new swap { field-spec new swap {
[ name>> >>name ] [ name>> >>name ]
[ offset>> >>offset ] [ offset>> >>offset ]
[ class>> >>type ] [ c-type>> >>type ]
[ name>> reader-word >>reader ] [ name>> reader-word >>reader ]
[ name>> writer-word >>writer ] [ name>> writer-word >>writer ]
} cleave ; } cleave ;
@ -111,9 +115,12 @@ M: struct-class writer-quot
} cleave } cleave
(define-struct) (define-struct)
] [ ] [
{
[ name>> c-type ] [ name>> c-type ]
[ (unboxer-quot) >>unboxer-quot ] [ (unboxer-quot) >>unboxer-quot ]
[ (boxer-quot) >>boxer-quot ] tri drop [ (boxer-quot) >>boxer-quot ]
[ >>boxed-class ]
} cleave drop
] bi ; ] bi ;
: align-offset ( offset class -- offset' ) : align-offset ( offset class -- offset' )
@ -121,15 +128,15 @@ M: struct-class writer-quot
: struct-offsets ( slots -- size ) : struct-offsets ( slots -- size )
0 [ 0 [
[ class>> align-offset ] keep [ c-type>> align-offset ] keep
[ (>>offset) ] [ class>> heap-size + ] 2bi [ (>>offset) ] [ c-type>> heap-size + ] 2bi
] reduce ; ] reduce ;
: union-struct-offsets ( slots -- size ) : 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 ) : struct-align ( slots -- align )
[ class>> c-type-align ] [ max ] map-reduce ; [ c-type>> c-type-align ] [ max ] map-reduce ;
M: struct-class c-type M: struct-class c-type
name>> c-type ; name>> c-type ;
@ -153,9 +160,6 @@ M: struct-class c-type-unboxer-quot
M: struct-class heap-size M: struct-class heap-size
"struct-size" word-prop ; "struct-size" word-prop ;
M: struct-class direct-array-of
<direct-struct-array> ;
! class definition ! class definition
: struct-prototype ( class -- prototype ) : struct-prototype ( class -- prototype )
@ -180,7 +184,7 @@ M: struct-class direct-array-of
[ (define-struct-slot-values-method) ] tri ; [ (define-struct-slot-values-method) ] tri ;
: check-struct-slots ( slots -- ) : check-struct-slots ( slots -- )
[ class>> c-type drop ] each ; [ c-type>> c-type drop ] each ;
: (define-struct-class) ( class slots offsets-quot -- ) : (define-struct-class) ( class slots offsets-quot -- )
[ drop struct f define-tuple-class ] [ drop struct f define-tuple-class ]
@ -197,8 +201,27 @@ M: struct-class direct-array-of
: define-union-struct-class ( class slots -- ) : define-union-struct-class ( class slots -- )
[ union-struct-offsets ] (define-struct-class) ; [ 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 ) : parse-struct-definition ( -- class slots )
CREATE-CLASS [ parse-tuple-slots ] { } make ; CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
SYNTAX: STRUCT: SYNTAX: STRUCT:
parse-struct-definition define-struct-class ; parse-struct-definition define-struct-class ;