$nl\r
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
$nl\r
-"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:"\r
-{ $subsection require-c-arrays }\r
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
+{ $subsection require-c-array }\r
{ $subsection <c-array> }\r
{ $subsection <c-direct-array> } ;\r
M: array c-type-boxer-quot
unclip
[ array-length ]
- [ [ require-c-arrays ] keep ] bi*
+ [ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a 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-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
-{ $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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
}
} ;
-HELP: require-c-arrays
+HELP: require-c-array
{ $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-array> } " or " { $link <c-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." } ;
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ;
HELP: <c-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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+{ $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-array } " word. See the " { $vocab-link "specialized-arrays" } " 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."
array-class
array-constructor
(array)-constructor
-direct-array-class
-direct-array-constructor
-sequence-mixin-class ;
+direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
M: abstract-c-type heap-size size>> ;
-GENERIC: require-c-arrays ( c-type -- )
+GENERIC: require-c-array ( c-type -- )
-M: object require-c-arrays
+M: object require-c-array
drop ;
-M: c-type require-c-arrays
- [ array-class>> ?require-word ]
- [ sequence-mixin-class>> ?require-word ]
- [ direct-array-class>> ?require-word ] tri ;
+M: c-type require-c-array
+ array-class>> ?require-word ;
-M: string require-c-arrays
- c-type require-c-arrays ;
+M: string require-c-array
+ c-type require-c-array ;
-M: array require-c-arrays
- first c-type require-c-arrays ;
+M: array require-c-array
+ first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
]
[
[ "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 ;
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.char
-specialized-arrays.direct.int specialized-arrays.ushort
+specialized-arrays.int specialized-arrays.ushort
struct-arrays system tools.test ;
IN: classes.struct.tests
definitions functors.backend fry generalizations generic.parser
kernel kernel.private lexer libc locals macros make math math.order
parser quotations sequences slots slots.private struct-arrays vectors
-words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
+words compiler.tree.propagation.transforms specialized-arrays.uchar ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
TUPLE: struct-slot-spec < slot-spec
c-type ;
-PREDICATE: struct-class < tuple-class
- { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
-: (define-byte-length-method) ( class -- )
- [ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
- define-inline-method ;
-
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
M: struct-class heap-size
"struct-size" word-prop ;
+M: struct byte-length
+ class "struct-size" word-prop ; foldable
+
! class definition
<PRIVATE
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
- [ (define-byte-length-method) ]
[ (define-clone-method) ]
- tri ;
+ bi ;
: (struct-word-props) ( class slots size align -- )
[
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
-<< "id" require-c-arrays >>
+<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays.direct.alien ;
+generalizations specialized-arrays.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
-arrays specialized-arrays.direct.alien classes.struct
-specialized-arrays.direct.int specialized-arrays.direct.longlong
+arrays specialized-arrays.alien classes.struct
+specialized-arrays.int specialized-arrays.longlong
core-foundation core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
[ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
-:: (%boolean) ( dst temp word -- )
+:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f tag-number %load-immediate
- "end" get word execute
+ "end" get branch1 execute( label -- )
+ branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
"end" get resolve-label ; inline
:: %boolean ( dst temp cc -- )
cc negate-cc order-cc {
- { cc< [ dst temp \ BLT (%boolean) ] }
- { cc<= [ dst temp \ BLE (%boolean) ] }
- { cc> [ dst temp \ BGT (%boolean) ] }
- { cc>= [ dst temp \ BGE (%boolean) ] }
- { cc= [ dst temp \ BEQ (%boolean) ] }
- { cc/= [ dst temp \ BNE (%boolean) ] }
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
-: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+
+:: (%compare-float) ( cc src1 src2 -- branch1 branch2 )
+ cc {
+ { cc< [ src1 src2 (%compare-float-ordered) \ BLT f ] }
+ { cc<= [ src1 src2 (%compare-float-ordered) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 (%compare-float-ordered) \ BGT f ] }
+ { cc>= [ src1 src2 (%compare-float-ordered) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 (%compare-float-unordered) \ BEQ f ] }
+ { cc<> [ src1 src2 (%compare-float-ordered) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 (%compare-float-ordered) \ BNO f ] }
+ { cc/< [ src1 src2 (%compare-float-unordered) \ BGE f ] }
+ { cc/<= [ src1 src2 (%compare-float-unordered) \ BGT \ BO ] }
+ { cc/> [ src1 src2 (%compare-float-unordered) \ BLE f ] }
+ { cc/>= [ src1 src2 (%compare-float-unordered) \ BLT \ BO ] }
+ { cc/= [ src1 src2 (%compare-float-unordered) \ BNE f ] }
+ { cc/<> [ src1 src2 (%compare-float-unordered) \ BEQ \ BO ] }
+ { cc/<>= [ src1 src2 (%compare-float-unordered) \ BO f ] }
+ } case ; inline
M: ppc %compare (%compare) %boolean ;
M: ppc %compare-imm (%compare-imm) %boolean ;
-M: ppc %compare-float (%compare-float) %boolean ;
+M:: ppc %compare-float ( dst temp cc src1 src2 -- )
+ cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
:: %branch ( label cc -- )
cc order-cc {
M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M: ppc %compare-float-branch (%compare-float) %branch ;
+M:: ppc %compare-float-branch ( label cc src1 src2 -- )
+ cc src1 src2 (%compare-float) :> branch2 :> branch1
+ label branch1 execute( label -- )
+ branch2 [ label branch2 execute( label -- ) ] when ;
: load-from-frame ( dst n rep -- )
{
M:: x86 %compare-float ( dst temp cc src1 src2 -- )
cc {
- { cc< [ src2 src1 UCOMISD dst temp \ CMOVA %boolean ] }
- { cc<= [ src2 src1 UCOMISD dst temp \ CMOVAE %boolean ] }
- { cc> [ src1 src2 UCOMISD dst temp \ CMOVA %boolean ] }
- { cc>= [ src1 src2 UCOMISD dst temp \ CMOVAE %boolean ] }
- { cc= [ src1 src2 COMISD dst temp \ %cmov-float= %boolean ] }
- { cc<> [ src1 src2 UCOMISD dst temp \ CMOVNE %boolean ] }
- { cc<>= [ src1 src2 UCOMISD dst temp \ CMOVNP %boolean ] }
- { cc/< [ src2 src1 COMISD dst temp \ CMOVBE %boolean ] }
- { cc/<= [ src2 src1 COMISD dst temp \ CMOVB %boolean ] }
- { cc/> [ src1 src2 COMISD dst temp \ CMOVBE %boolean ] }
- { cc/>= [ src1 src2 COMISD dst temp \ CMOVB %boolean ] }
- { cc/= [ src1 src2 COMISD dst temp \ %cmov-float/= %boolean ] }
- { cc/<> [ src1 src2 COMISD dst temp \ CMOVE %boolean ] }
- { cc/<>= [ src1 src2 COMISD dst temp \ CMOVP %boolean ] }
+ { cc< [ src2 src1 COMISD dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 COMISD dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 COMISD dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 COMISD dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 UCOMISD dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 COMISD dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 COMISD dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 UCOMISD dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 UCOMISD dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 UCOMISD dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 UCOMISD dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 UCOMISD dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 UCOMISD dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP %boolean ] }
} case ;
M:: x86 %compare-branch ( label cc src1 src2 -- )
M:: x86 %compare-float-branch ( label cc src1 src2 -- )
cc {
- { cc< [ src2 src1 UCOMISD label JA ] }
- { cc<= [ src2 src1 UCOMISD label JAE ] }
- { cc> [ src1 src2 UCOMISD label JA ] }
- { cc>= [ src1 src2 UCOMISD label JAE ] }
- { cc= [ src1 src2 COMISD label %jump-float= ] }
- { cc<> [ src1 src2 UCOMISD label JNE ] }
- { cc<>= [ src1 src2 UCOMISD label JNP ] }
- { cc/< [ src2 src1 COMISD label JBE ] }
- { cc/<= [ src2 src1 COMISD label JB ] }
- { cc/> [ src1 src2 COMISD label JBE ] }
- { cc/>= [ src1 src2 COMISD label JB ] }
- { cc/= [ src1 src2 COMISD label %jump-float/= ] }
- { cc/<> [ src1 src2 COMISD label JE ] }
- { cc/<>= [ src1 src2 COMISD label JP ] }
+ { cc< [ src2 src1 COMISD label JA ] }
+ { cc<= [ src2 src1 COMISD label JAE ] }
+ { cc> [ src1 src2 COMISD label JA ] }
+ { cc>= [ src1 src2 COMISD label JAE ] }
+ { cc= [ src1 src2 UCOMISD label %jump-float= ] }
+ { cc<> [ src1 src2 COMISD label JNE ] }
+ { cc<>= [ src1 src2 COMISD label JNP ] }
+ { cc/< [ src2 src1 UCOMISD label JBE ] }
+ { cc/<= [ src2 src1 UCOMISD label JB ] }
+ { cc/> [ src1 src2 UCOMISD label JBE ] }
+ { cc/>= [ src1 src2 UCOMISD label JB ] }
+ { cc/= [ src1 src2 UCOMISD label %jump-float/= ] }
+ { cc/<> [ src1 src2 UCOMISD label JE ] }
+ { cc/<>= [ src1 src2 UCOMISD label JP ] }
} case ;
M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
io.encodings io ;
IN: environment.winnt
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
\r
: make-token-privileges ( name ? -- obj )\r
"TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
+ "LUID_AND_ATTRIBUTES" malloc-object &free\r
over set-TOKEN_PRIVILEGES-Privileges\r
\r
swap [\r
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
- dup class heap-size >>nLength ;
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
-system unix io.files.unix specialized-arrays.direct.uint arrays
+system unix io.files.unix specialized-arrays.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
io.files.info.unix io.files.info classes.struct struct-arrays ;
IN: io.files.info.unix.macosx
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
- ascii [ contents ] with-process-reader
+ ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
-USING: io.mmap.functor specialized-arrays.direct.alien ;
+USING: io.mmap.functor specialized-arrays.alien ;
IN: io.mmap.alien
<< "void*" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.bool ;
+USING: io.mmap.functor specialized-arrays.bool ;
IN: io.mmap.bool
<< "bool" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.char ;
+USING: io.mmap.functor specialized-arrays.char ;
IN: io.mmap.char
<< "char" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.double ;
+USING: io.mmap.functor specialized-arrays.double ;
IN: io.mmap.double
<< "double" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.float ;
+USING: io.mmap.functor specialized-arrays.float ;
IN: io.mmap.float
<< "float" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.int ;
+USING: io.mmap.functor specialized-arrays.int ;
IN: io.mmap.int
<< "int" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.long ;
+USING: io.mmap.functor specialized-arrays.long ;
IN: io.mmap.long
<< "long" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.longlong ;
+USING: io.mmap.functor specialized-arrays.longlong ;
IN: io.mmap.longlong
<< "longlong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.short ;
+USING: io.mmap.functor specialized-arrays.short ;
IN: io.mmap.short
<< "short" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uchar ;
+USING: io.mmap.functor specialized-arrays.uchar ;
IN: io.mmap.uchar
<< "uchar" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uint ;
+USING: io.mmap.functor specialized-arrays.uint ;
IN: io.mmap.uint
<< "uint" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulong ;
+USING: io.mmap.functor specialized-arrays.ulong ;
IN: io.mmap.ulong
<< "ulong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
+USING: io.mmap.functor specialized-arrays.ulonglong ;
IN: io.mmap.ulonglong
<< "ulonglong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ushort ;
+USING: io.mmap.functor specialized-arrays.ushort ;
IN: io.mmap.ushort
<< "ushort" define-mapped-array >>
\ No newline at end of file
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
-specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
specialized-arrays.complex-float specialized-arrays.complex-double
parser prettyprint.backend prettyprint.custom ascii ;
IN: math.blas.matrices
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.complex-float specialized-arrays.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.complex-double ;
+specialized-arrays.complex-float specialized-arrays.complex-double ;
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;
+++ /dev/null
-USING: specialized-arrays.alien specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.alien
-
-<< "void*" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.bool specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.bool
-
-<< "bool" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.char specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.char
-
-<< "char" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-double
-
-<< "complex-double" define-direct-array >>
+++ /dev/null
-USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-float
-
-<< "complex-float" define-direct-array >>
+++ /dev/null
-USING: help.markup help.syntax byte-arrays alien ;
-IN: specialized-arrays.direct
-
-ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays"
-"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
-{ $table
- { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } }
- { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
-}
-"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions."
-$nl
-"The primitive C types for which direct arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ;
-
-ABOUT: "specialized-arrays.direct"
+++ /dev/null
-IN: specialized-arrays.direct.tests
-USING: specialized-arrays.direct.ushort tools.test
-specialized-arrays.ushort alien.syntax sequences ;
-
-[ ushort-array{ 0 0 0 } ] [
- 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: specialized-arrays.direct
+++ /dev/null
-USING: specialized-arrays.double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.double
-
-<< "double" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.float
-
-<< "float" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private kernel words classes
-math alien alien.c-types byte-arrays accessors
-specialized-arrays parser
-prettyprint.backend prettyprint.custom prettyprint.sections ;
-IN: specialized-arrays.direct.functor
-
-<PRIVATE
-
-: pprint-direct-array ( direct-array tag -- )
- [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
-PRIVATE>
-
-FUNCTOR: define-direct-array ( T -- )
-
-A' IS ${T}-array
-S IS ${T}-sequence
->A' IS >${T}-array
-<A'> IS <${A'}>
-A'{ IS ${A'}{
-
-A DEFINES-CLASS direct-${T}-array
-<A> DEFINES <${A}>
-A'@ DEFINES ${A'}@
-
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
-
-WHERE
-
-TUPLE: A
-{ underlying c-ptr read-only }
-{ length fixnum read-only } ;
-
-: <A> ( alien len -- direct-array ) A boa ; inline
-M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-M: A like drop dup A instance? [ >A' ] unless ; inline
-M: A new-sequence drop <A'> ; inline
-
-M: A byte-length length>> T heap-size * ; inline
-
-SYNTAX: A'@
- scan-object scan-object <A> parsed ;
-
-M: A pprint-delims drop \ A'{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint*
- [ pprint-object ]
- [ \ A'@ pprint-direct-array ]
- pprint-c-object ;
-
-INSTANCE: A sequence
-INSTANCE: A S
-
-T c-type
- \ A >>direct-array-class
- \ <A> >>direct-array-constructor
- drop
-
-;FUNCTOR
+++ /dev/null
-Code generation for direct specialized arrays
+++ /dev/null
-USING: specialized-arrays.int specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.int
-
-<< "int" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.long specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.long
-
-<< "long" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.longlong
-
-<< "longlong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.short specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.short
-
-<< "short" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uchar
-
-<< "uchar" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uint specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uint
-
-<< "uint" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulong
-
-<< "ulong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulonglong
-
-<< "ulonglong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ushort
-
-<< "ushort" define-direct-array >>
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private prettyprint.custom
kernel words classes math math.vectors.specialization parser
-alien.c-types byte-arrays accessors summary ;
+alien.c-types byte-arrays accessors summary alien specialized-arrays ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}>
(A) DEFINES (${A})
+<direct-A> DEFINES <direct-${A}>
>A DEFINES >${A}
byte-array>A DEFINES byte-array>${A}
+
A{ DEFINES ${A}{
+A@ DEFINES ${A}@
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
MIXIN: S
TUPLE: A
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
+{ underlying c-ptr read-only }
+{ length array-capacity read-only } ;
+
+: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) dup T <underlying> A boa ; inline
+: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) dup T (underlying) A boa ; inline
+: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
- swap A boa ; inline
+ <direct-A> ; inline
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
+M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A length length>> ; inline
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
M: A resize
- [ drop ] [
+ [
[ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
- ] 2bi
- A boa ; inline
+ ] [ drop ] 2bi
+ <direct-A> ; inline
M: A byte-length underlying>> length ; inline
-
M: A pprint-delims drop \ A{ \ } ;
-
M: A >pprint-sequence ;
-M: A pprint* pprint-object ;
-
SYNTAX: A{ \ } [ >A ] parse-literal ;
+SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
-INSTANCE: A sequence
-INSTANCE: A S
+INSTANCE: A specialized-array
A T c-type-boxed-class specialize-vector-words
\ A >>array-class
\ <A> >>array-constructor
\ (A) >>(array)-constructor
- \ S >>sequence-mixin-class
+ \ <direct-A> >>direct-array-constructor
drop
;FUNCTOR
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel prettyprint.backend
+prettyprint.sections prettyprint.custom
+specialized-arrays ;
+IN: specialized-arrays.prettyprint
+
+: pprint-direct-array ( direct-array -- )
+ dup direct-array-syntax
+ [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+M: specialized-array pprint*
+ [ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
+
{ $table
{ { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
{ { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
- { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
+ { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
{ { $snippet "byte-array>T-array" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
+ { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
{ { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions."
IN: specialized-arrays.tests
-USING: tools.test specialized-arrays sequences
+USING: tools.test alien.syntax specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char
-specialized-arrays.uint arrays combinators ;
+specialized-arrays.char specialized-arrays.uint arrays combinators ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ { 3 1 3 3 7 } ] [
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
+] unit-test
+
+[ ushort-array{ 0 0 0 } ] [
+ 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
+ dup [ drop 0 ] change-each
] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs vocabs.loader ;
IN: specialized-arrays
+
+MIXIN: specialized-array
+INSTANCE: specialized-array sequence
+
+GENERIC: direct-array-syntax ( obj -- word )
+
+"prettyprint" vocab [
+ "specialized-arrays.prettyprint" require
+] when
"slots"
"special"
"specializer"
+ "struct-slots"
! UI needs this
! "superclass"
"transform-n"
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-M: x11-ui-backend (set-fullscreen) ( world ? -- )
+: make-fullscreen-msg ( world ? -- msg )
XClientMessageEvent <struct>
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
- swap handle>> window>> >>window
+ ClientMessage >>type
dpy get >>display
"_NET_WM_STATE" x-atom >>message_type
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap handle>> window>> >>window
32 >>format
- "_NET_WM_STATE_FULLSCREEN" x-atom >>data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+ "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+ [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+ make-fullscreen-msg XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: windows.com windows.kernel32 windows.ole32
+prettyprint.custom prettyprint.sections sequences ;
+IN: windows.com.prettyprint
+
+M: GUID pprint* guid>string "GUID: " prepend text ;
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
macros alien.syntax fry arrays layouts math classes.struct
-windows.kernel32 prettyprint.custom prettyprint.sections ;
+windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
SYNTAX: GUID: scan string>guid parsed ;
-M: GUID pprint* guid>string "GUID: " prepend text ;
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [
+ "windows.com.prettyprint" require
+] when
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien
-windows.kernel32 classes.struct ;
+specialized-arrays.alien windows.kernel32 classes.struct ;
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
alien.c-types alien sequences math ;\r
IN: windows.dragdrop-listener\r
\r
-<< "WCHAR" require-c-arrays >>\r
+<< "WCHAR" require-c-array >>\r
\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
arrays literals ;
IN: windows.errors
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar
+combinators locals specialized-arrays.uchar
literals splitting grouping classes.struct combinators.smart ;
IN: windows.ole32
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.syntax kernel math math.order
-specialized-arrays.direct.functor specialized-arrays.functor ;
+specialized-arrays.functor ;
IN: half-floats
: half>bits ( float -- bits )
drop
"half" define-array
-"half" define-direct-array
>>
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images
-half-floats ;
+USING: kernel accessors grouping sequences combinators math
+byte-arrays fry specialized-arrays.uint specialized-arrays.ushort
+specialized-arrays.float images half-floats ;
IN: images.normalization
<PRIVATE