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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-08-25 19:39:24 -05:00
parent 1afd001393 d42edd4e3b
commit fb1693bf1d
15 changed files with 264 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/alien/arrays/arrays-docs.factor
View File

@ -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 <c-type-array> }
{ $subsection <c-type-direct-array> } ;

17
basis/alien/c-types/c-types-docs.factor
View File

@ -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: <c-type>
{ $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 <c-type-array> } " or " { $link <c-type-direct-array> } " 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: <c-type-array>
{ $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: <c-type-direct-array>
{ $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

103
basis/alien/c-types/c-types.factor
View File

@ -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: <int>
@ -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 ;
: <c-type> ( -- 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: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
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 ]
[ "<direct-" "-array>" 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
<long-long-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
<long-long-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-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
<c-type>
@ -434,6 +529,7 @@ CONSTANT: primitive-types
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" set-array-class
"bool" define-primitive-type
<c-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
<c-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

9
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -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
<A'> 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 <A'> ;
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
\ <A> >>direct-array-constructor
drop
;FUNCTOR

10
basis/specialized-arrays/functor/functor.factor
View File

@ -16,6 +16,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
S DEFINES-CLASS ${T}-sequence
<A> 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
\ <A> >>array-constructor
\ S >>sequence-mixin-class
drop
;FUNCTOR

2
basis/specialized-vectors/functor/functor.factor
View File

@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
S IS ${T}-sequence
<A> 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

2
basis/windows/com/wrapper/wrapper.factor
View File

@ -153,7 +153,7 @@ PRIVATE>
[ +live-wrappers+ get adjoin ] bi ;
: <com-wrapper> ( 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*

4
extra/alien/marshall/marshall.factor
View File

@ -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" [ [ ] ] }

3
extra/alien/marshall/syntax/syntax-tests.factor
View File

@ -9,8 +9,7 @@ C-LIBRARY: test
C-INCLUDE: <stdlib.h>
C-INCLUDE: <string.h>
C-TYPEDEF: char bool
C-INCLUDE: <stdbool.h>
CM-FUNCTION: void outarg1 ( int* a )
*a += 2;

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

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

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

@ -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 <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
pinned-c-ptr f "void*" \ <direct-void*-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 "double" \ <direct-double-array> set-class-c-type
single-float 0.0 "float" \ <direct-float-array> set-class-c-type
complex C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
single-complex C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-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
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

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:"
{ $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." }
} } ;

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

@ -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 <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
@ -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 <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 ] 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 } }" ]
[
@ -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 <struct-boa> 4 ffi_test_11 ] unit-test

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

@ -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 )
@ -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
<direct-struct-array> ;
! 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 <vector> [ parse-struct-slots ] [ ] while >array ;
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;