Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
c4a06d4a60
|
|
@ -1,69 +1,7 @@
|
|||
IN: alien.arrays
|
||||
USING: help.syntax help.markup byte-arrays alien.c-types ;
|
||||
|
||||
ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
||||
"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
|
||||
{ $subsection >c-bool-array }
|
||||
{ $subsection >c-char-array }
|
||||
{ $subsection >c-double-array }
|
||||
{ $subsection >c-float-array }
|
||||
{ $subsection >c-int-array }
|
||||
{ $subsection >c-long-array }
|
||||
{ $subsection >c-longlong-array }
|
||||
{ $subsection >c-short-array }
|
||||
{ $subsection >c-uchar-array }
|
||||
{ $subsection >c-uint-array }
|
||||
{ $subsection >c-ulong-array }
|
||||
{ $subsection >c-ulonglong-array }
|
||||
{ $subsection >c-ushort-array }
|
||||
{ $subsection >c-void*-array }
|
||||
{ $subsection c-bool-array> }
|
||||
{ $subsection c-char-array> }
|
||||
{ $subsection c-double-array> }
|
||||
{ $subsection c-float-array> }
|
||||
{ $subsection c-int-array> }
|
||||
{ $subsection c-long-array> }
|
||||
{ $subsection c-longlong-array> }
|
||||
{ $subsection c-short-array> }
|
||||
{ $subsection c-uchar-array> }
|
||||
{ $subsection c-uint-array> }
|
||||
{ $subsection c-ulong-array> }
|
||||
{ $subsection c-ulonglong-array> }
|
||||
{ $subsection c-ushort-array> }
|
||||
{ $subsection c-void*-array> } ;
|
||||
|
||||
ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
|
||||
"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
|
||||
{ $subsection char-nth }
|
||||
{ $subsection set-char-nth }
|
||||
{ $subsection uchar-nth }
|
||||
{ $subsection set-uchar-nth }
|
||||
{ $subsection short-nth }
|
||||
{ $subsection set-short-nth }
|
||||
{ $subsection ushort-nth }
|
||||
{ $subsection set-ushort-nth }
|
||||
{ $subsection int-nth }
|
||||
{ $subsection set-int-nth }
|
||||
{ $subsection uint-nth }
|
||||
{ $subsection set-uint-nth }
|
||||
{ $subsection long-nth }
|
||||
{ $subsection set-long-nth }
|
||||
{ $subsection ulong-nth }
|
||||
{ $subsection set-ulong-nth }
|
||||
{ $subsection longlong-nth }
|
||||
{ $subsection set-longlong-nth }
|
||||
{ $subsection ulonglong-nth }
|
||||
{ $subsection set-ulonglong-nth }
|
||||
{ $subsection float-nth }
|
||||
{ $subsection set-float-nth }
|
||||
{ $subsection double-nth }
|
||||
{ $subsection set-double-nth }
|
||||
{ $subsection void*-nth }
|
||||
{ $subsection set-void*-nth } ;
|
||||
|
||||
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" } "."
|
||||
{ $subsection "c-arrays-factor" }
|
||||
{ $subsection "c-arrays-get/set" } ;
|
||||
"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
|
||||
|
|
|
|||
|
|
@ -89,16 +89,6 @@ HELP: malloc-byte-array
|
|||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
HELP: define-nth
|
||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
HELP: define-set-nth
|
||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||
{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
HELP: box-parameter
|
||||
{ $values { "n" integer } { "ctype" string } }
|
||||
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
|
||||
|
|
@ -115,12 +105,12 @@ HELP: unbox-return
|
|||
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
|
||||
|
||||
HELP: define-deref
|
||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||
{ $values { "name" "a word name" } }
|
||||
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
HELP: define-out
|
||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||
{ $values { "name" "a word name" } }
|
||||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
|
|
@ -230,9 +220,7 @@ $nl
|
|||
"You can copy a range of bytes from memory into a byte array:"
|
||||
{ $subsection memory>byte-array }
|
||||
"You can copy a byte array to memory unsafely:"
|
||||
{ $subsection byte-array>memory }
|
||||
"A wrapper for temporarily allocating a block of memory:"
|
||||
{ $subsection with-malloc } ;
|
||||
{ $subsection byte-array>memory } ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
|
|
|
|||
|
|
@ -55,8 +55,6 @@ TYPEDEF: uchar* MyLPBYTE
|
|||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
] must-fail
|
||||
|
||||
[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations ;
|
||||
accessors combinators effects continuations fry ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -21,7 +21,7 @@ reg-class size align stack-align? ;
|
|||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class
|
||||
object >>class ;
|
||||
object >>class ; inline
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
|
|
@ -180,12 +180,12 @@ M: byte-array byte-length length ;
|
|||
|
||||
: c-getter ( name -- quot )
|
||||
c-type-getter [
|
||||
[ "Cannot read struct fields with type" throw ]
|
||||
[ "Cannot read struct fields with this type" throw ]
|
||||
] unless* ;
|
||||
|
||||
: c-setter ( name -- quot )
|
||||
c-type-setter [
|
||||
[ "Cannot write struct fields with type" throw ]
|
||||
[ "Cannot write struct fields with this type" throw ]
|
||||
] unless* ;
|
||||
|
||||
: <c-array> ( n type -- array )
|
||||
|
|
@ -209,28 +209,13 @@ M: byte-array byte-length length ;
|
|||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup length memcpy ;
|
||||
|
||||
: (define-nth) ( word type quot -- )
|
||||
: array-accessor ( type quot -- def )
|
||||
[
|
||||
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
||||
] [ ] make define-inline ;
|
||||
|
||||
: nth-word ( name vocab -- word )
|
||||
[ "-nth" append ] dip create ;
|
||||
|
||||
: define-nth ( name vocab -- )
|
||||
dupd nth-word swap dup c-getter (define-nth) ;
|
||||
|
||||
: set-nth-word ( name vocab -- word )
|
||||
[ "set-" swap "-nth" 3append ] dip create ;
|
||||
|
||||
: define-set-nth ( name vocab -- )
|
||||
dupd set-nth-word swap dup c-setter (define-nth) ;
|
||||
] [ ] make ;
|
||||
|
||||
: typedef ( old new -- ) c-types get set-at ;
|
||||
|
||||
: define-c-type ( type name vocab -- )
|
||||
[ tuck typedef ] dip [ define-nth ] 2keep define-set-nth ;
|
||||
|
||||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
|
|
@ -248,54 +233,24 @@ M: long-long-type box-parameter ( n type -- )
|
|||
M: long-long-type box-return ( type -- )
|
||||
f swap box-parameter ;
|
||||
|
||||
: define-deref ( name vocab -- )
|
||||
[ dup CHAR: * prefix ] dip create
|
||||
swap c-getter 0 prefix define-inline ;
|
||||
: define-deref ( name -- )
|
||||
[ CHAR: * prefix "alien.c-types" create ]
|
||||
[ c-getter 0 prefix ] bi
|
||||
define-inline ;
|
||||
|
||||
: define-out ( name vocab -- )
|
||||
over [ <c-object> tuck 0 ] over c-setter append swap
|
||||
[ constructor-word ] 2dip prefix define-inline ;
|
||||
: define-out ( name -- )
|
||||
[ "alien.c-types" constructor-word ]
|
||||
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
|
||||
bi define-inline ;
|
||||
|
||||
: c-bool> ( int -- ? )
|
||||
zero? not ;
|
||||
|
||||
: >c-array ( seq type word -- byte-array )
|
||||
[ [ dup length ] dip <c-array> ] dip
|
||||
[ [ execute ] 2curry each-index ] 2keep drop ; inline
|
||||
|
||||
: >c-array-quot ( type vocab -- quot )
|
||||
dupd set-nth-word [ >c-array ] 2curry ;
|
||||
|
||||
: to-array-word ( name vocab -- word )
|
||||
[ ">c-" swap "-array" 3append ] dip create ;
|
||||
|
||||
: define-to-array ( type vocab -- )
|
||||
[ to-array-word ] 2keep >c-array-quot
|
||||
(( array -- byte-array )) define-declared ;
|
||||
|
||||
: c-array>quot ( type vocab -- quot )
|
||||
[
|
||||
\ swap ,
|
||||
nth-word 1quotation ,
|
||||
[ curry map ] %
|
||||
] [ ] make ;
|
||||
|
||||
: from-array-word ( name vocab -- word )
|
||||
[ "c-" swap "-array>" 3append ] dip create ;
|
||||
|
||||
: define-from-array ( type vocab -- )
|
||||
[ from-array-word ] 2keep c-array>quot
|
||||
(( c-ptr n -- array )) define-declared ;
|
||||
|
||||
: define-primitive-type ( type name -- )
|
||||
"alien.c-types"
|
||||
{
|
||||
[ define-c-type ]
|
||||
[ define-deref ]
|
||||
[ define-to-array ]
|
||||
[ define-from-array ]
|
||||
[ define-out ]
|
||||
} 2cleave ;
|
||||
[ typedef ]
|
||||
[ define-deref ]
|
||||
[ define-out ]
|
||||
tri ;
|
||||
|
||||
: expand-constants ( c-type -- c-type' )
|
||||
dup array? [
|
||||
|
|
@ -314,6 +269,17 @@ M: long-long-type box-return ( type -- )
|
|||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
: primitive-types
|
||||
{
|
||||
"char" "uchar"
|
||||
"short" "ushort"
|
||||
"int" "uint"
|
||||
"long" "ulong"
|
||||
"longlong" "ulonglong"
|
||||
"float" "double"
|
||||
"void*" "bool"
|
||||
} ;
|
||||
|
||||
[
|
||||
<c-type>
|
||||
c-ptr >>class
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays sequences kernel accessors math alien.accessors
|
||||
alien.c-types byte-arrays words io io.encodings
|
||||
io.streams.byte-array io.streams.memory io.encodings.utf8
|
||||
io.encodings.utf16 system alien strings cpu.architecture ;
|
||||
io.encodings.utf16 system alien strings cpu.architecture fry ;
|
||||
IN: alien.strings
|
||||
|
||||
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
|
||||
|
|
@ -77,10 +77,10 @@ M: string-type c-type-unboxer
|
|||
drop "void*" c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second [ alien>string ] curry [ ] like ;
|
||||
second '[ _ alien>string ] ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second [ string>alien ] curry [ ] like ;
|
||||
second '[ _ string>alien ] ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
|
|
|||
|
|
@ -38,25 +38,26 @@ M: struct-type stack-size
|
|||
|
||||
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
||||
|
||||
: (define-struct) ( name vocab size align fields -- )
|
||||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type boa
|
||||
-rot define-c-type ;
|
||||
swap typedef ;
|
||||
|
||||
: define-struct-early ( name vocab fields -- fields )
|
||||
: make-fields ( name vocab fields -- fields )
|
||||
[ first2 <field-spec> ] with with map ;
|
||||
|
||||
: compute-struct-align ( types -- n )
|
||||
[ c-type-align ] map supremum ;
|
||||
|
||||
: define-struct ( name vocab fields -- )
|
||||
pick [
|
||||
[
|
||||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
] dip [ swap define-field ] curry each ;
|
||||
] [ 2drop '[ _ swap define-field ] ] 3bi each ;
|
||||
|
||||
: define-union ( name vocab members -- )
|
||||
: define-union ( name members -- )
|
||||
[ expand-constants ] map
|
||||
[ [ heap-size ] map supremum ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
|
|
|
|||
|
|
@ -24,13 +24,10 @@ IN: alien.syntax
|
|||
scan scan typedef ; parsing
|
||||
|
||||
: C-STRUCT:
|
||||
scan in get
|
||||
parse-definition
|
||||
[ 2dup ] dip define-struct-early
|
||||
define-struct ; parsing
|
||||
scan in get parse-definition define-struct ; parsing
|
||||
|
||||
: C-UNION:
|
||||
scan in get parse-definition define-union ; parsing
|
||||
scan parse-definition define-union ; parsing
|
||||
|
||||
: C-ENUM:
|
||||
";" parse-tokens
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types accessors math alien.accessors kernel
|
||||
kernel.private locals sequences sequences.private byte-arrays
|
||||
parser prettyprint.backend ;
|
||||
parser prettyprint.backend fry ;
|
||||
IN: bit-arrays
|
||||
|
||||
TUPLE: bit-array
|
||||
|
|
@ -24,9 +24,8 @@ TUPLE: bit-array
|
|||
: bits>bytes 7 + n>byte ; inline
|
||||
|
||||
: (set-bits) ( bit-array n -- )
|
||||
[ [ length bits>cells ] keep ] dip
|
||||
[ -rot underlying>> set-uint-nth ] 2curry
|
||||
each ; inline
|
||||
[ [ length bits>cells ] keep ] dip swap underlying>>
|
||||
'[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
0 swap underlying>> [ length ] keep [
|
||||
uchar-nth swap 8 shift bitor
|
||||
] curry each ;
|
||||
0 swap underlying>> dup length [
|
||||
alien-unsigned-1 swap 8 shift bitor
|
||||
] with each ;
|
||||
|
||||
INSTANCE: bit-array sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -1,26 +1,31 @@
|
|||
USING: kernel cocoa cocoa.types alien.c-types locals math sequences
|
||||
vectors fry libc ;
|
||||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel cocoa cocoa.types alien.c-types locals math
|
||||
sequences vectors fry libc destructors
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.enumeration
|
||||
|
||||
: NS-EACH-BUFFER-SIZE 16 ; inline
|
||||
|
||||
: (with-enumeration-buffers) ( quot -- )
|
||||
"NSFastEnumerationState" heap-size swap '[
|
||||
NS-EACH-BUFFER-SIZE "id" heap-size * [
|
||||
NS-EACH-BUFFER-SIZE @
|
||||
] with-malloc
|
||||
] with-malloc ; inline
|
||||
: with-enumeration-buffers ( quot -- )
|
||||
[
|
||||
[
|
||||
"NSFastEnumerationState" malloc-object &free
|
||||
NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
|
||||
NS-EACH-BUFFER-SIZE
|
||||
] dip call
|
||||
] with-destructors ; inline
|
||||
|
||||
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
||||
object state stackbuf count -> countByEnumeratingWithState:objects:count:
|
||||
dup zero? [ drop ] [
|
||||
dup 0 = [ drop ] [
|
||||
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
|
||||
'[ _ void*-nth quot call ] each
|
||||
swap <direct-void*-array> quot each
|
||||
object quot state stackbuf count (NSFastEnumeration-each)
|
||||
] if ; inline recursive
|
||||
|
||||
: NSFastEnumeration-each ( object quot -- )
|
||||
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline
|
||||
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
|
||||
|
||||
: NSFastEnumeration-map ( object quot -- vector )
|
||||
NS-EACH-BUFFER-SIZE <vector>
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ combinators compiler compiler.alien kernel math namespaces make
|
|||
parser prettyprint prettyprint.sections quotations sequences
|
||||
strings words cocoa.runtime io macros memoize debugger
|
||||
io.encodings.ascii effects libc libc.private parser lexer init
|
||||
core-foundation fry generalizations ;
|
||||
core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -198,8 +199,11 @@ assoc-union alien>objc-types set-global
|
|||
objc-methods get set-at ;
|
||||
|
||||
: each-method-in-class ( class quot -- )
|
||||
[ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
|
||||
'[ _ void*-nth @ ] each (free) ; inline
|
||||
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
|
||||
over 0 = [ 3drop ] [
|
||||
[ <direct-void*-array> ] dip
|
||||
[ each ] [ drop underlying>> (free) ] 2bi
|
||||
] if ; inline
|
||||
|
||||
: register-objc-methods ( class -- )
|
||||
[ register-objc-method ] each-method-in-class ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays kernel cocoa.messages
|
||||
cocoa.classes cocoa.application cocoa core-foundation
|
||||
sequences ;
|
||||
USING: alien.accessors arrays kernel cocoa.messages
|
||||
cocoa.classes cocoa.application cocoa core-foundation sequences
|
||||
;
|
||||
IN: cocoa.pasteboard
|
||||
|
||||
: NSStringPboardType "NSStringPboardType" ;
|
||||
|
|
@ -24,7 +24,7 @@ IN: cocoa.pasteboard
|
|||
|
||||
: pasteboard-error ( error -- f )
|
||||
"Pasteboard does not hold a string" <NSString>
|
||||
0 spin set-void*-nth f ;
|
||||
0 set-alien-cell f ;
|
||||
|
||||
: ?pasteboard-string ( pboard error -- str/f )
|
||||
over pasteboard-string? [
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays kernel math namespaces make cocoa
|
||||
cocoa.messages cocoa.classes cocoa.types sequences
|
||||
continuations ;
|
||||
USING: specialized-arrays.int arrays kernel math namespaces make
|
||||
cocoa cocoa.messages cocoa.classes cocoa.types sequences
|
||||
continuations accessors ;
|
||||
IN: cocoa.views
|
||||
|
||||
: NSOpenGLPFAAllRenderers 1 ;
|
||||
|
|
@ -69,7 +69,7 @@ PRIVATE>
|
|||
NSOpenGLPFASamples , 8 ,
|
||||
] when
|
||||
0 ,
|
||||
] { } make >c-int-array
|
||||
] int-array{ } make underlying>>
|
||||
-> initWithAttributes:
|
||||
-> autorelease ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel
|
|||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math accessors combinators ;
|
||||
memory system threads tools.test math accessors combinators
|
||||
specialized-arrays.float ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
|
@ -196,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
|
|||
|
||||
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
|
||||
|
||||
[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
|
||||
[ 32.0 ] [
|
||||
{ 1.0 2.0 3.0 } >float-array underlying>>
|
||||
{ 4.0 5.0 6.0 } >float-array underlying>>
|
||||
ffi_test_23
|
||||
] unit-test
|
||||
|
||||
! Test odd-size structs
|
||||
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
|
|||
sequences sequences.private tools.test namespaces.private
|
||||
slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors float-arrays grouping make ;
|
||||
combinators vectors grouping make ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Originally, this file did black box testing of templating
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: math.private kernel combinators accessors arrays
|
||||
generalizations float-arrays tools.test ;
|
||||
generalizations tools.test ;
|
||||
IN: compiler.tests
|
||||
|
||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations
|
||||
words namespaces continuations classes fry
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.recursive
|
||||
|
|
@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
|
|||
M: word splicing-nodes
|
||||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||
|
||||
M: quotation splicing-nodes
|
||||
M: callable splicing-nodes
|
||||
build-sub-tree analyze-recursive normalize ;
|
||||
|
||||
: propagate-body ( #call -- )
|
||||
|
|
@ -140,18 +140,21 @@ SYMBOL: history
|
|||
: remember-inlining ( word -- )
|
||||
history [ swap suffix ] change ;
|
||||
|
||||
: inline-word ( #call word -- ? )
|
||||
dup history get memq? [
|
||||
2drop f
|
||||
: inline-word-def ( #call word quot -- ? )
|
||||
over history get memq? [
|
||||
3drop f
|
||||
] [
|
||||
[
|
||||
dup remember-inlining
|
||||
dupd def>> splicing-nodes >>body
|
||||
swap remember-inlining
|
||||
dupd splicing-nodes >>body
|
||||
propagate-body
|
||||
] with-scope
|
||||
t
|
||||
] if ;
|
||||
|
||||
: inline-word ( #call word -- ? )
|
||||
dup def>> inline-word-def ;
|
||||
|
||||
: inline-method-body ( #call word -- ? )
|
||||
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
||||
|
||||
|
|
@ -165,6 +168,10 @@ SYMBOL: history
|
|||
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
|
||||
first object swap eliminate-dispatch ;
|
||||
|
||||
: inline-instance-check ( #call word -- ? )
|
||||
over in-d>> second value-info literal>> dup class?
|
||||
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
|
||||
|
||||
: do-inlining ( #call word -- ? )
|
||||
#! If the generic was defined in an outer compilation unit,
|
||||
#! then it doesn't have a definition yet; the definition
|
||||
|
|
@ -177,6 +184,7 @@ SYMBOL: history
|
|||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup custom-inlining? ] [ inline-custom ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ math.functions math.private strings layouts
|
|||
compiler.tree.propagation.info compiler.tree.def-use
|
||||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
float-arrays system sorting math.libm ;
|
||||
specialized-arrays.double system sorting math.libm ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
|
@ -167,7 +167,8 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ V{ fixnum } ] [
|
||||
[
|
||||
[ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
|
||||
{ fixnum byte-array } declare
|
||||
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
|
||||
>r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
|
||||
255 min 0 max
|
||||
] final-classes
|
||||
|
|
@ -588,7 +589,7 @@ MIXIN: empty-mixin
|
|||
[ { fixnum integer } declare bitand ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
|
||||
[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
|||
CF>array [ CF>string ] map ;
|
||||
|
||||
: <CFStringArray> ( seq -- alien )
|
||||
[ <CFString> ] map dup <CFArray> swap [ CFRelease ] each ;
|
||||
[ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
|
||||
|
||||
: <CFFileSystemURL> ( string dir? -- url )
|
||||
[ <CFString> f over kCFURLPOSIXPathStyle ] dip
|
||||
|
|
|
|||
|
|
@ -4,7 +4,9 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
|
|||
math sequences namespaces make assocs init accessors
|
||||
continuations combinators core-foundation
|
||||
core-foundation.run-loop core-foundation.run-loop.thread
|
||||
io.encodings.utf8 destructors locals arrays ;
|
||||
io.encodings.utf8 destructors locals arrays
|
||||
specialized-arrays.direct.alien specialized-arrays.direct.int
|
||||
specialized-arrays.direct.longlong ;
|
||||
IN: core-foundation.fsevents
|
||||
|
||||
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
|
||||
|
|
@ -160,11 +162,12 @@ SYMBOL: event-stream-callbacks
|
|||
: remove-event-source-callback ( id -- )
|
||||
event-stream-callbacks get delete-at ;
|
||||
|
||||
:: >event-triple ( n eventPaths eventFlags eventIds -- triple )
|
||||
n eventPaths void*-nth utf8 alien>string
|
||||
n eventFlags int-nth
|
||||
n eventIds longlong-nth
|
||||
3array ;
|
||||
:: (master-event-source-callback) ( eventStream info numEvents eventPaths eventFlags eventIds -- )
|
||||
eventPaths numEvents <direct-void*-array> [ utf8 alien>string ] { } map-as
|
||||
eventFlags numEvents <direct-int-array>
|
||||
eventIds numEvents <direct-longlong-array>
|
||||
3array flip
|
||||
info event-stream-callbacks get at [ drop ] or call ;
|
||||
|
||||
: master-event-source-callback ( -- alien )
|
||||
"void"
|
||||
|
|
@ -176,19 +179,15 @@ SYMBOL: event-stream-callbacks
|
|||
"FSEventStreamEventFlags*"
|
||||
"FSEventStreamEventId*"
|
||||
}
|
||||
"cdecl" [
|
||||
[ >event-triple ] 3curry map
|
||||
swap event-stream-callbacks get at
|
||||
dup [ call drop ] [ 3drop ] if
|
||||
] alien-callback ;
|
||||
"cdecl" [ (master-event-source-callback) ] alien-callback ;
|
||||
|
||||
TUPLE: event-stream info handle disposed ;
|
||||
|
||||
: <event-stream> ( quot paths latency flags -- event-stream )
|
||||
>r >r >r
|
||||
add-event-source-callback dup
|
||||
>r master-event-source-callback r>
|
||||
r> r> r> <FSEventStream>
|
||||
[
|
||||
add-event-source-callback dup
|
||||
[ master-event-source-callback ] dip
|
||||
] 3dip <FSEventStream>
|
||||
dup enable-event-stream
|
||||
f event-stream boa ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ quotations sequences db.postgresql.ffi alien alien.c-types
|
|||
db.types tools.walker ascii splitting math.parser combinators
|
||||
libc shuffle calendar.format byte-arrays destructors prettyprint
|
||||
accessors strings serialize io.encodings.binary io.encodings.utf8
|
||||
alien.strings io.streams.byte-array summary present urls ;
|
||||
alien.strings io.streams.byte-array summary present urls
|
||||
specialized-arrays.uint specialized-arrays.alien ;
|
||||
IN: db.postgresql.lib
|
||||
|
||||
: postgresql-result-error-message ( res -- str/f )
|
||||
|
|
@ -64,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
} case ;
|
||||
|
||||
: param-types ( statement -- seq )
|
||||
in-params>> [ type>> type>oid ] map >c-uint-array ;
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
|
||||
|
||||
: malloc-byte-array/length ( byte-array -- alien length )
|
||||
[ malloc-byte-array &free ] [ length ] bi ;
|
||||
|
|
@ -90,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
] 2map flip [
|
||||
f f
|
||||
] [
|
||||
first2 [ >c-void*-array ] [ >c-uint-array ] bi*
|
||||
first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
|
||||
] if-empty ;
|
||||
|
||||
: param-formats ( statement -- seq )
|
||||
in-params>> [ type>> type>param-format ] map >c-uint-array ;
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
|
||||
|
||||
: do-postgresql-bound-statement ( statement -- res )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,62 +0,0 @@
|
|||
USING: arrays bit-arrays vectors strings sbufs
|
||||
kernel help.markup help.syntax math ;
|
||||
IN: float-arrays
|
||||
|
||||
ARTICLE: "float-arrays" "Float arrays"
|
||||
"Float arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are instances of " { $link float } ". Elements are unboxed, hence the memory usage is lower than an equivalent " { $link array } " of floats."
|
||||
$nl
|
||||
"Float array words are in the " { $vocab-link "float-arrays" } " vocabulary."
|
||||
$nl
|
||||
"Float arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
|
||||
$nl
|
||||
"Float arrays form a class of objects."
|
||||
{ $subsection float-array }
|
||||
{ $subsection float-array? }
|
||||
"There are several ways to construct float arrays."
|
||||
{ $subsection >float-array }
|
||||
{ $subsection <float-array> }
|
||||
"Creating a float array from several elements on the stack:"
|
||||
{ $subsection 1float-array }
|
||||
{ $subsection 2float-array }
|
||||
{ $subsection 3float-array }
|
||||
{ $subsection 4float-array }
|
||||
"Float array literal syntax:"
|
||||
{ $subsection POSTPONE: F{ } ;
|
||||
|
||||
ABOUT: "float-arrays"
|
||||
|
||||
HELP: F{
|
||||
{ $syntax "F{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
{ $description "Marks the beginning of a literal float array. Literal float arrays are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "F{ 1.0 2.0 3.0 }" } } ;
|
||||
|
||||
HELP: float-array
|
||||
{ $description "The class of float arrays." } ;
|
||||
|
||||
HELP: <float-array> ( n -- float-array )
|
||||
{ $values { "n" "a non-negative integer" } { "float-array" "a new float array" } }
|
||||
{ $description "Creates a new float array holding " { $snippet "n" } " floats with all elements initially set to " { $snippet "0.0" } "." } ;
|
||||
|
||||
HELP: >float-array
|
||||
{ $values { "seq" "a sequence" } { "float-array" float-array } }
|
||||
{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||
|
||||
HELP: 1float-array
|
||||
{ $values { "x" object } { "array" float-array } }
|
||||
{ $description "Create a new float array with one element." } ;
|
||||
|
||||
{ 1array 2array 3array 4array } related-words
|
||||
|
||||
HELP: 2float-array
|
||||
{ $values { "x" object } { "y" object } { "array" float-array } }
|
||||
{ $description "Create a new float array with two elements, with " { $snippet "x" } " appearing first." } ;
|
||||
|
||||
HELP: 3float-array
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "array" float-array } }
|
||||
{ $description "Create a new float array with three elements, with " { $snippet "x" } " appearing first." } ;
|
||||
|
||||
HELP: 4float-array
|
||||
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" float-array } }
|
||||
{ $description "Create a new float array with four elements, with " { $snippet "w" } " appearing first." } ;
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
IN: float-arrays.tests
|
||||
USING: float-arrays tools.test sequences.private ;
|
||||
|
||||
[ F{ 0.0 0.0 0.0 } ] [ 3 <float-array> ] unit-test
|
||||
|
||||
[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize ] unit-test
|
||||
|
||||
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize ] unit-test
|
||||
|
||||
[ -10 F{ } resize ] must-fail
|
||||
|
||||
[ F{ 1.3 } ] [ 1.3 1float-array ] unit-test
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private alien.accessors sequences
|
||||
sequences.private math math.private byte-arrays accessors
|
||||
alien.c-types parser prettyprint.backend combinators ;
|
||||
IN: float-arrays
|
||||
|
||||
TUPLE: float-array
|
||||
{ length array-capacity read-only }
|
||||
{ underlying byte-array read-only } ;
|
||||
|
||||
: <float-array> ( n -- float-array )
|
||||
dup "double" <c-array> float-array boa ; inline
|
||||
|
||||
M: float-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi float-array boa ;
|
||||
|
||||
M: float-array length length>> ;
|
||||
|
||||
M: float-array nth-unsafe
|
||||
underlying>> double-nth ;
|
||||
|
||||
M: float-array set-nth-unsafe
|
||||
[ >float ] 2dip underlying>> set-double-nth ;
|
||||
|
||||
: >float-array ( seq -- float-array )
|
||||
T{ float-array } clone-like ; inline
|
||||
|
||||
M: float-array like
|
||||
drop dup float-array? [ >float-array ] unless ;
|
||||
|
||||
M: float-array new-sequence
|
||||
drop <float-array> ;
|
||||
|
||||
M: float-array equal?
|
||||
over float-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: float-array resize
|
||||
[ drop ] [
|
||||
[ "double" heap-size * ] [ underlying>> ] bi*
|
||||
resize-byte-array
|
||||
] 2bi
|
||||
float-array boa ;
|
||||
|
||||
M: float-array byte-length length "double" heap-size * ;
|
||||
|
||||
INSTANCE: float-array sequence
|
||||
|
||||
: 1float-array ( x -- array )
|
||||
1 <float-array> [ set-first ] keep ; inline
|
||||
|
||||
: 2float-array ( x y -- array )
|
||||
T{ float-array } 2sequence ; inline
|
||||
|
||||
: 3float-array ( x y z -- array )
|
||||
T{ float-array } 3sequence ; inline
|
||||
|
||||
: 4float-array ( w x y z -- array )
|
||||
T{ float-array } 4sequence ; inline
|
||||
|
||||
: F{ \ } [ >float-array ] parse-literal ; parsing
|
||||
|
||||
M: float-array pprint-delims drop \ F{ \ } ;
|
||||
M: float-array >pprint-sequence ;
|
||||
M: float-array pprint* pprint-object ;
|
||||
|
||||
! Specializer hints
|
||||
USING: hints math.vectors arrays ;
|
||||
|
||||
HINTS: <float-array> { 2 } { 3 } ;
|
||||
|
||||
HINTS: vneg { array } { float-array } ;
|
||||
HINTS: v*n { array object } { float-array float } ;
|
||||
HINTS: n*v { array object } { float float-array } ;
|
||||
HINTS: v/n { array object } { float-array float } ;
|
||||
HINTS: n/v { object array } { float float-array } ;
|
||||
HINTS: v+ { array array } { float-array float-array } ;
|
||||
HINTS: v- { array array } { float-array float-array } ;
|
||||
HINTS: v* { array array } { float-array float-array } ;
|
||||
HINTS: v/ { array array } { float-array float-array } ;
|
||||
HINTS: vmax { array array } { float-array float-array } ;
|
||||
HINTS: vmin { array array } { float-array float-array } ;
|
||||
HINTS: v. { array array } { float-array float-array } ;
|
||||
HINTS: norm-sq { array } { float-array } ;
|
||||
HINTS: norm { array } { float-array } ;
|
||||
HINTS: normalize { array } { float-array } ;
|
||||
HINTS: distance { array array } { float-array float-array } ;
|
||||
|
||||
! Type functions
|
||||
USING: words classes.algebra compiler.tree.propagation.info
|
||||
math.intervals ;
|
||||
|
||||
{ v+ v- v* v/ vmax vmin } [
|
||||
[
|
||||
[ class>> float-array class<= ] both?
|
||||
float-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ n*v n/v } [
|
||||
[
|
||||
nip class>> float-array class<= float-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ v*n v/n } [
|
||||
[
|
||||
drop class>> float-array class<= float-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ vneg normalize } [
|
||||
[
|
||||
class>> float-array class<= float-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ norm-sq [
|
||||
class>> float-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ v. [
|
||||
[ class>> float-array class<= ] both?
|
||||
float object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ distance [
|
||||
[ class>> float-array class<= ] both?
|
||||
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
|
@ -1 +0,0 @@
|
|||
Efficient fixed-length floating point number arrays
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
USING: arrays float-arrays help.markup help.syntax kernel
|
||||
combinators ;
|
||||
IN: float-vectors
|
||||
|
||||
ARTICLE: "float-vectors" "Float vectors"
|
||||
"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
|
||||
$nl
|
||||
"Float vectors form a class:"
|
||||
{ $subsection float-vector }
|
||||
{ $subsection float-vector? }
|
||||
"Creating float vectors:"
|
||||
{ $subsection >float-vector }
|
||||
{ $subsection <float-vector> }
|
||||
"Literal syntax:"
|
||||
{ $subsection POSTPONE: FV{ }
|
||||
"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
|
||||
{ $code "FV{ } clone" } ;
|
||||
|
||||
ABOUT: "float-vectors"
|
||||
|
||||
HELP: float-vector
|
||||
{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;
|
||||
|
||||
HELP: <float-vector>
|
||||
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
|
||||
{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;
|
||||
|
||||
HELP: >float-vector
|
||||
{ $values { "seq" "a sequence" } { "float-vector" float-vector } }
|
||||
{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||
|
||||
HELP: FV{
|
||||
{ $syntax "FV{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
USING: tools.test float-vectors vectors sequences kernel math ;
|
||||
IN: float-vectors.tests
|
||||
|
||||
[ 0 ] [ 123 <float-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
12345 [ >float over push ] each ;
|
||||
|
||||
[ t ] [
|
||||
3 <float-vector> do-it
|
||||
3 <vector> do-it sequence=
|
||||
] unit-test
|
||||
|
||||
[ t ] [ FV{ } float-vector? ] unit-test
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable float-arrays prettyprint.backend
|
||||
parser accessors ;
|
||||
IN: float-vectors
|
||||
|
||||
TUPLE: float-vector
|
||||
{ underlying float-array initial: F{ } }
|
||||
{ length array-capacity } ;
|
||||
|
||||
: <float-vector> ( n -- float-vector )
|
||||
<float-array> 0 float-vector boa ; inline
|
||||
|
||||
: >float-vector ( seq -- float-vector )
|
||||
T{ float-vector f F{ } 0 } clone-like ;
|
||||
|
||||
M: float-vector like
|
||||
drop dup float-vector? [
|
||||
dup float-array?
|
||||
[ dup length float-vector boa ] [ >float-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: float-vector new-sequence
|
||||
drop [ <float-array> ] [ >fixnum ] bi float-vector boa ;
|
||||
|
||||
M: float-vector equal?
|
||||
over float-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: float-array new-resizable drop <float-vector> ;
|
||||
|
||||
INSTANCE: float-vector growable
|
||||
|
||||
: FV{ \ } [ >float-vector ] parse-literal ; parsing
|
||||
|
||||
M: float-vector >pprint-sequence ;
|
||||
M: float-vector pprint-delims drop \ FV{ \ } ;
|
||||
M: float-vector pprint* pprint-object ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Growable float arrays
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
IN: functors.tests
|
||||
USING: functors tools.test math words kernel ;
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: define-box ( T -- )
|
||||
|
||||
B DEFINES ${T}-box
|
||||
<B> DEFINES <${B}>
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: B { value T } ;
|
||||
|
||||
C: <B> B
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
\ float define-box
|
||||
|
||||
>>
|
||||
|
||||
{ 1 0 } [ define-box ] must-infer-as
|
||||
|
||||
[ T{ float-box f 5.0 } ] [ 5.0 <float-box> ] unit-test
|
||||
|
||||
: twice ( word -- )
|
||||
[ execute ] [ execute ] bi ; inline
|
||||
<<
|
||||
|
||||
FUNCTOR: wrapper-test ( W -- )
|
||||
|
||||
WW DEFINES ${W}${W}
|
||||
|
||||
WHERE
|
||||
|
||||
: WW W twice ; inline
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
\ sq wrapper-test
|
||||
|
||||
>>
|
||||
|
||||
\ sqsq must-infer
|
||||
|
||||
[ 16 ] [ 2 sqsq ] unit-test
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel locals.private quotations classes.tuple make
|
||||
combinators generic words interpolate namespaces sequences
|
||||
io.streams.string fry classes.mixin effects lexer parser
|
||||
classes.tuple.parser effects.parser ;
|
||||
IN: functors
|
||||
|
||||
: scan-param ( -- obj )
|
||||
scan-object dup special? [ literalize ] unless ;
|
||||
|
||||
: define* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
|
||||
|
||||
: `TUPLE:
|
||||
scan-param parsed
|
||||
scan {
|
||||
{ ";" [ tuple parsed f parsed ] }
|
||||
{ "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
|
||||
[
|
||||
[ tuple parsed ] dip
|
||||
[ parse-slot-name [ parse-tuple-slots ] when ] { }
|
||||
make parsed
|
||||
]
|
||||
} case
|
||||
\ define-tuple-class parsed ; parsing
|
||||
|
||||
: `M:
|
||||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method parsed
|
||||
parse-definition parsed
|
||||
DEFINE* ; parsing
|
||||
|
||||
: `C:
|
||||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
[ [ boa ] curry ] over push-all
|
||||
DEFINE* ; parsing
|
||||
|
||||
: `:
|
||||
effect off
|
||||
scan-param parsed
|
||||
parse-definition parsed
|
||||
DEFINE* ; parsing
|
||||
|
||||
: `INSTANCE:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ add-mixin-instance parsed ; parsing
|
||||
|
||||
: `inline \ inline parsed ; parsing
|
||||
|
||||
: `parsing \ parsing parsed ; parsing
|
||||
|
||||
: `(
|
||||
")" parse-effect effect set ; parsing
|
||||
|
||||
: (INTERPOLATE) ( accum quot -- accum )
|
||||
[ scan interpolate-locals ] dip
|
||||
'[ _ with-string-writer @ ] parsed ;
|
||||
|
||||
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
|
||||
|
||||
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
DEFER: ;FUNCTOR delimiter
|
||||
|
||||
: functor-words ( -- assoc )
|
||||
H{
|
||||
{ "TUPLE:" POSTPONE: `TUPLE: }
|
||||
{ "M:" POSTPONE: `M: }
|
||||
{ "C:" POSTPONE: `C: }
|
||||
{ ":" POSTPONE: `: }
|
||||
{ "INSTANCE:" POSTPONE: `INSTANCE: }
|
||||
{ "inline" POSTPONE: `inline }
|
||||
{ "parsing" POSTPONE: `parsing }
|
||||
{ "(" POSTPONE: `( }
|
||||
} ;
|
||||
|
||||
: push-functor-words ( -- )
|
||||
functor-words use get push ;
|
||||
|
||||
: pop-functor-words ( -- )
|
||||
functor-words use get delq ;
|
||||
|
||||
: parse-functor-body ( -- form )
|
||||
t in-lambda? [
|
||||
V{ } clone
|
||||
push-functor-words
|
||||
"WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
|
||||
<let*> parsed-lambda
|
||||
pop-functor-words
|
||||
>quotation
|
||||
] with-variable ;
|
||||
|
||||
: (FUNCTOR:) ( -- word def )
|
||||
CREATE
|
||||
parse-locals
|
||||
parse-functor-body swap pop-locals <lambda>
|
||||
lambda-rewrite first ;
|
||||
|
||||
: FUNCTOR: (FUNCTOR:) define ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
First-class syntax
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -205,10 +205,10 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"USING: accessors grouping io.files io.mmap kernel sequences ;"
|
||||
"\"mydata.dat\" dup file-info size>> ["
|
||||
"USING: accessors grouping io.files io.mmap.char kernel sequences ;"
|
||||
"\"mydata.dat\" ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
"] with-mapped-char-file"
|
||||
}
|
||||
"Send some bytes to a remote host:"
|
||||
{ $code
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.alien ;
|
||||
IN: io.mmap.alien
|
||||
|
||||
<< "void*" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.bool ;
|
||||
IN: io.mmap.bool
|
||||
|
||||
<< "bool" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.char ;
|
||||
IN: io.mmap.char
|
||||
|
||||
<< "char" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.double ;
|
||||
IN: io.mmap.double
|
||||
|
||||
<< "double" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.float ;
|
||||
IN: io.mmap.float
|
||||
|
||||
<< "float" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.mmap functors accessors alien.c-types math kernel
|
||||
words fry ;
|
||||
IN: io.mmap.functor
|
||||
|
||||
SLOT: address
|
||||
SLOT: length
|
||||
|
||||
: mapped-file>direct ( mapped-file type -- alien length )
|
||||
[ [ address>> ] [ length>> ] bi ] dip
|
||||
heap-size [ 1- + ] keep /i ;
|
||||
|
||||
FUNCTOR: define-mapped-array ( T -- )
|
||||
|
||||
<mapped-A> DEFINES <mapped-${T}-array>
|
||||
<A> IS <direct-${T}-array>
|
||||
with-mapped-A-file DEFINES with-mapped-${T}-file
|
||||
|
||||
WHERE
|
||||
|
||||
: <mapped-A> ( mapped-file -- direct-array )
|
||||
T mapped-file>direct <A> execute ; inline
|
||||
|
||||
: with-mapped-A-file ( path length quot -- )
|
||||
'[ <mapped-A> execute @ ] with-mapped-file ; inline
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.int ;
|
||||
IN: io.mmap.int
|
||||
|
||||
<< "int" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.long ;
|
||||
IN: io.mmap.long
|
||||
|
||||
<< "long" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.longlong ;
|
||||
IN: io.mmap.longlong
|
||||
|
||||
<< "longlong" define-mapped-array >>
|
||||
|
|
@ -11,13 +11,13 @@ HELP: mapped-file
|
|||
} ;
|
||||
|
||||
HELP: <mapped-file>
|
||||
{ $values { "path" "a pathname string" } { "length" integer } { "mmap" mapped-file } }
|
||||
{ $contract "Opens a file and maps the first " { $snippet "length" } " bytes into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
|
||||
{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $contract "Opens a file and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
|
||||
{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: with-mapped-file
|
||||
{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } }
|
||||
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
|
||||
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
|
|
@ -26,6 +26,33 @@ HELP: close-mapped-file
|
|||
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
|
||||
"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":"
|
||||
{ $table
|
||||
{ { $snippet "<mapped-T-array>" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } }
|
||||
{ { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "<mapped-T-array>" } "; stack effect " { $snippet "( path quot -- )" } } }
|
||||
}
|
||||
"The primitive C types for which mapped 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" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
|
||||
"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
|
||||
|
||||
ARTICLE: "io.mmap" "Memory-mapped files"
|
||||
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
|
||||
{ $subsection <mapped-file> }
|
||||
|
|
@ -33,7 +60,8 @@ ARTICLE: "io.mmap" "Memory-mapped files"
|
|||
$nl
|
||||
"A utility combinator which wraps the above:"
|
||||
{ $subsection with-mapped-file }
|
||||
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl
|
||||
"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
|
||||
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
|
||||
{ $subsection "io.mmap.arrays" }
|
||||
{ $subsection "io.mmap.low-level" } ;
|
||||
|
||||
ABOUT: "io.mmap"
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: io io.mmap io.files kernel tools.test continuations
|
||||
sequences io.encodings.ascii accessors ;
|
||||
USING: io io.mmap io.mmap.char io.files kernel tools.test
|
||||
continuations sequences io.encodings.ascii accessors ;
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
|
|
|
|||
|
|
@ -1,34 +1,24 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations destructors io.backend kernel quotations
|
||||
sequences system alien alien.accessors accessors
|
||||
sequences.private system vocabs.loader combinators ;
|
||||
USING: continuations destructors io.files io.backend kernel
|
||||
quotations system alien alien.accessors accessors system
|
||||
vocabs.loader combinators alien.c-types ;
|
||||
IN: io.mmap
|
||||
|
||||
TUPLE: mapped-file address handle length disposed ;
|
||||
|
||||
M: mapped-file length dup check-disposed length>> ;
|
||||
|
||||
M: mapped-file nth-unsafe
|
||||
dup check-disposed address>> swap alien-unsigned-1 ;
|
||||
|
||||
M: mapped-file set-nth-unsafe
|
||||
dup check-disposed address>> swap set-alien-unsigned-1 ;
|
||||
|
||||
INSTANCE: mapped-file sequence
|
||||
|
||||
HOOK: (mapped-file) io-backend ( path length -- address handle )
|
||||
|
||||
: <mapped-file> ( path length -- mmap )
|
||||
[ >r normalize-path r> (mapped-file) ] keep
|
||||
: <mapped-file> ( path -- mmap )
|
||||
[ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
|
||||
f mapped-file boa ;
|
||||
|
||||
HOOK: close-mapped-file io-backend ( mmap -- )
|
||||
|
||||
M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
|
||||
|
||||
: with-mapped-file ( path length quot -- )
|
||||
>r <mapped-file> r> with-disposal ; inline
|
||||
: with-mapped-file ( path quot -- )
|
||||
[ <mapped-file> ] dip with-disposal ; inline
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.unix.mmap" require ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.short ;
|
||||
IN: io.mmap.short
|
||||
|
||||
<< "short" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.uchar ;
|
||||
IN: io.mmap.uchar
|
||||
|
||||
<< "uchar" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.uint ;
|
||||
IN: io.mmap.uint
|
||||
|
||||
<< "uint" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.ulong ;
|
||||
IN: io.mmap.ulong
|
||||
|
||||
<< "ulong" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
|
||||
IN: io.mmap.ulonglong
|
||||
|
||||
<< "ulonglong" define-mapped-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.ushort
|
||||
|
||||
<< "ushort" define-array >>
|
||||
|
|
@ -80,7 +80,7 @@ TUPLE: unix-file-system-info < file-system-info
|
|||
block-size preferred-block-size
|
||||
blocks blocks-free blocks-available
|
||||
files files-free files-available
|
||||
name-max flags id id0 id1 ;
|
||||
name-max flags id ;
|
||||
|
||||
HOOK: new-file-system-info os ( -- file-system-info )
|
||||
|
||||
|
|
@ -108,8 +108,6 @@ M: unix statvfs>file-system-info drop ;
|
|||
[ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
|
||||
[ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
|
||||
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
|
||||
[ dup id>> 2 c-uint-array> first2 [ >>id0 ] [ >>id1 ] bi* drop ]
|
||||
[ f >>id drop ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
|
|
@ -316,8 +314,7 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: make-timeval-array ( array -- byte-array )
|
||||
[ length "timeval" <c-array> ] keep
|
||||
dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
|
||||
[ [ "timeval" <c-object> ] unless* ] map concat ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
unix-1970 time- duration>microseconds make-timeval ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system alien.c-types kernel unix math sequences
|
||||
qualified io.unix.backend io.ports ;
|
||||
USING: system kernel unix math sequences qualified
|
||||
io.unix.backend io.ports specialized-arrays.int accessors ;
|
||||
IN: io.unix.pipes
|
||||
QUALIFIED: io.pipes
|
||||
|
||||
M: unix io.pipes:(pipe) ( -- pair )
|
||||
2 "int" <c-array>
|
||||
dup pipe io-error
|
||||
2 c-int-array> first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ;
|
||||
2 <int-array>
|
||||
[ underlying>> pipe io-error ]
|
||||
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ windows.types math windows.kernel32
|
|||
namespaces make io.launcher kernel sequences windows.errors
|
||||
splitting system threads init strings combinators
|
||||
io.backend accessors concurrency.flags io.files assocs
|
||||
io.files.private windows destructors ;
|
||||
io.files.private windows destructors specialized-arrays.ushort
|
||||
specialized-arrays.alien ;
|
||||
IN: io.windows.launcher
|
||||
|
||||
TUPLE: CreateProcess-args
|
||||
|
|
@ -45,7 +46,7 @@ TUPLE: CreateProcess-args
|
|||
CreateProcess win32-error=0/f ;
|
||||
|
||||
: count-trailing-backslashes ( str n -- str n )
|
||||
>r "\\" ?tail r> swap [
|
||||
[ "\\" ?tail ] dip swap [
|
||||
1+ count-trailing-backslashes
|
||||
] when ;
|
||||
|
||||
|
|
@ -84,8 +85,7 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: fill-lpApplicationName ( process args -- process args )
|
||||
over app-name/cmd-line
|
||||
>r >>lpApplicationName
|
||||
r> >>lpCommandLine ;
|
||||
[ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
|
||||
|
||||
: fill-lpCommandLine ( process args -- process args )
|
||||
over cmd-line >>lpCommandLine ;
|
||||
|
|
@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
|
|||
over get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] "" make >c-ushort-array
|
||||
] ushort-array{ } make underlying>>
|
||||
>>lpEnvironment
|
||||
] when ;
|
||||
|
||||
|
|
@ -157,8 +157,8 @@ M: windows kill-process* ( handle -- )
|
|||
|
||||
M: windows wait-for-processes ( -- ? )
|
||||
processes get keys dup
|
||||
[ handle>> PROCESS_INFORMATION-hProcess ] map
|
||||
dup length swap >c-void*-array 0 0
|
||||
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
|
||||
[ length ] [ underlying>> ] bi 0 0
|
||||
WaitForMultipleObjects
|
||||
dup HEX: ffffffff = [ win32-error ] when
|
||||
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types libc destructors locals kernel math
|
||||
assocs namespaces make continuations sequences hashtables
|
||||
sorting arrays combinators math.bitwise strings system accessors
|
||||
threads splitting io.backend io.windows io.windows.nt.backend
|
||||
io.windows.nt.files io.monitors io.ports io.buffers io.files
|
||||
io.timeouts io windows windows.kernel32 windows.types ;
|
||||
USING: alien alien.c-types alien.strings libc destructors locals
|
||||
kernel math assocs namespaces make continuations sequences
|
||||
hashtables sorting arrays combinators math.bitwise strings
|
||||
system accessors threads splitting io.backend io.windows
|
||||
io.windows.nt.backend io.windows.nt.files io.monitors io.ports
|
||||
io.buffers io.files io.timeouts io.encodings.string io
|
||||
windows windows.kernel32 windows.types ;
|
||||
IN: io.windows.nt.monitors
|
||||
|
||||
: open-directory ( path -- handle )
|
||||
|
|
@ -50,7 +51,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
} case 1array ;
|
||||
|
||||
: memory>u16-string ( alien len -- string )
|
||||
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
|
||||
memory>byte-array utf16n decode ;
|
||||
|
||||
: parse-notify-record ( buffer -- path changed )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -32,10 +32,6 @@ HELP: free
|
|||
{ $values { "alien" c-ptr } }
|
||||
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
|
||||
|
||||
HELP: with-malloc
|
||||
{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } }
|
||||
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
|
||||
|
||||
HELP: &free
|
||||
{ $values { "alien" c-ptr } }
|
||||
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;
|
||||
|
|
|
|||
|
|
@ -87,9 +87,6 @@ PRIVATE>
|
|||
: memcpy ( dst src size -- )
|
||||
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
|
||||
|
||||
: with-malloc ( size quot -- )
|
||||
swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
|
||||
|
||||
: strlen ( alien -- len )
|
||||
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
|
||||
|
||||
|
|
|
|||
|
|
@ -316,27 +316,26 @@ SYMBOL: in-lambda?
|
|||
"|" parse-tokens make-locals dup push-locals
|
||||
\ ] (parse-lambda) <lambda> ;
|
||||
|
||||
: parse-binding ( -- pair/f )
|
||||
: parse-binding ( end -- pair/f )
|
||||
scan {
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup "|" = ] [ drop f ] }
|
||||
{ [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] }
|
||||
[ scan-object 2array ]
|
||||
{ [ 2dup = ] [ 2drop f ] }
|
||||
[ nip scan-object 2array ]
|
||||
} cond ;
|
||||
|
||||
: (parse-bindings) ( -- )
|
||||
parse-binding [
|
||||
: (parse-bindings) ( end -- )
|
||||
dup parse-binding dup [
|
||||
first2 [ make-local ] dip 2array ,
|
||||
(parse-bindings)
|
||||
] when* ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: parse-bindings ( -- bindings vars )
|
||||
: parse-bindings ( end -- bindings vars )
|
||||
[
|
||||
[ (parse-bindings) ] H{ } make-assoc
|
||||
dup push-locals
|
||||
] { } make swap ;
|
||||
|
||||
: parse-bindings* ( -- words assoc )
|
||||
: parse-bindings* ( end -- words assoc )
|
||||
[
|
||||
[
|
||||
namespace push-locals
|
||||
|
|
@ -345,13 +344,13 @@ SYMBOL: in-lambda?
|
|||
] { } make-assoc
|
||||
] { } make swap ;
|
||||
|
||||
: (parse-wbindings) ( -- )
|
||||
parse-binding [
|
||||
: (parse-wbindings) ( end -- )
|
||||
dup parse-binding dup [
|
||||
first2 [ make-local-word ] keep 2array ,
|
||||
(parse-wbindings)
|
||||
] when* ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: parse-wbindings ( -- bindings vars )
|
||||
: parse-wbindings ( end -- bindings vars )
|
||||
[
|
||||
[ (parse-wbindings) ] H{ } make-assoc
|
||||
dup push-locals
|
||||
|
|
@ -374,12 +373,12 @@ M: wlet local-rewrite*
|
|||
let-rewrite ;
|
||||
|
||||
: parse-locals ( -- vars assoc )
|
||||
")" parse-effect
|
||||
"(" expect ")" parse-effect
|
||||
word [ over "declared-effect" set-word-prop ] when*
|
||||
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
"(" expect parse-locals \ ; (parse-lambda) <lambda>
|
||||
parse-locals \ ; (parse-lambda) <lambda>
|
||||
2dup "lambda" set-word-prop
|
||||
lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
|
||||
|
||||
|
|
@ -397,15 +396,15 @@ PRIVATE>
|
|||
: [| parse-lambda parsed-lambda ; parsing
|
||||
|
||||
: [let
|
||||
"|" expect parse-bindings
|
||||
"|" expect "|" parse-bindings
|
||||
\ ] (parse-lambda) <let> parsed-lambda ; parsing
|
||||
|
||||
: [let*
|
||||
"|" expect parse-bindings*
|
||||
"|" expect "|" parse-bindings*
|
||||
\ ] (parse-lambda) <let*> parsed-lambda ; parsing
|
||||
|
||||
: [wlet
|
||||
"|" expect parse-wbindings
|
||||
"|" expect "|" parse-wbindings
|
||||
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing
|
||||
|
||||
: :: (::) define ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
USING: nibble-arrays tools.test sequences kernel math ;
|
||||
IN: nibble-arrays.tests
|
||||
|
||||
[ t ] [ 16 dup >nibble-array sequence= ] unit-test
|
||||
[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
|
||||
[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sequences.private byte-arrays
|
||||
alien.c-types prettyprint.backend parser accessors ;
|
||||
IN: nibble-arrays
|
||||
|
||||
TUPLE: nibble-array
|
||||
{ length array-capacity read-only }
|
||||
{ underlying byte-array read-only } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: nibble BIN: 1111 ; inline
|
||||
|
||||
: nibbles>bytes 1 + 2/ ; inline
|
||||
|
||||
: byte/nibble ( n -- shift n' )
|
||||
[ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
|
||||
|
||||
: get-nibble ( n byte -- nibble )
|
||||
swap neg shift nibble bitand ; inline
|
||||
|
||||
: set-nibble ( value n byte -- byte' )
|
||||
nibble pick shift bitnot bitand -rot shift bitor ; inline
|
||||
|
||||
: nibble@ ( n nibble-array -- shift n' byte-array )
|
||||
[ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <nibble-array> ( n -- nibble-array )
|
||||
dup nibbles>bytes <byte-array> nibble-array boa ; inline
|
||||
|
||||
M: nibble-array length length>> ;
|
||||
|
||||
M: nibble-array nth-unsafe
|
||||
nibble@ nth-unsafe get-nibble ;
|
||||
|
||||
M: nibble-array set-nth-unsafe
|
||||
nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
|
||||
|
||||
M: nibble-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi nibble-array boa ;
|
||||
|
||||
: >nibble-array ( seq -- nibble-array )
|
||||
T{ nibble-array } clone-like ; inline
|
||||
|
||||
M: nibble-array like
|
||||
drop dup nibble-array? [ >nibble-array ] unless ;
|
||||
|
||||
M: nibble-array new-sequence drop <nibble-array> ;
|
||||
|
||||
M: nibble-array equal?
|
||||
over nibble-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: nibble-array resize
|
||||
[ drop ] [
|
||||
[ nibbles>bytes ] [ underlying>> ] bi*
|
||||
resize-byte-array
|
||||
] 2bi
|
||||
nibble-array boa ;
|
||||
|
||||
M: nibble-array byte-length length nibbles>bytes ;
|
||||
|
||||
: N{ \ } [ >nibble-array ] parse-literal ; parsing
|
||||
|
||||
INSTANCE: nibble-array sequence
|
||||
|
||||
M: nibble-array pprint-delims drop \ N{ \ } ;
|
||||
M: nibble-array >pprint-sequence ;
|
||||
M: nibble-array pprint* pprint-object ;
|
||||
|
|
@ -6,7 +6,8 @@ USING: alien alien.c-types continuations kernel libc math macros
|
|||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays assocs colors accessors
|
||||
generalizations locals memoize ;
|
||||
generalizations locals specialized-arrays.float
|
||||
specialized-arrays.uint ;
|
||||
IN: opengl
|
||||
|
||||
: color>raw ( object -- r g b a )
|
||||
|
|
@ -52,20 +53,20 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
glMatrixMode glPopMatrix ; inline
|
||||
|
||||
: gl-material ( face pname params -- )
|
||||
>c-float-array glMaterialfv ;
|
||||
float-array{ } like underlying>> glMaterialfv ;
|
||||
|
||||
: gl-vertex-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
|
||||
[ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
|
||||
|
||||
: gl-color-pointer ( seq -- )
|
||||
[ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
|
||||
[ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
|
||||
|
||||
: gl-texture-coord-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
|
||||
[ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
|
||||
|
||||
: line-vertices ( a b -- )
|
||||
[ first2 [ 0.5 + ] bi@ ] bi@ 4 narray
|
||||
>c-float-array gl-vertex-pointer ;
|
||||
[ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
|
||||
gl-vertex-pointer ;
|
||||
|
||||
: gl-line ( a b -- )
|
||||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||
|
|
@ -80,7 +81,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
|
||||
[ second 0.3 - 0.5 swap ]
|
||||
[ drop 0.5 0.5 ]
|
||||
} cleave 10 narray >c-float-array ;
|
||||
} cleave 10 float-array{ } nsequence ;
|
||||
|
||||
: rect-vertices ( dim -- )
|
||||
(rect-vertices) gl-vertex-pointer ;
|
||||
|
|
@ -97,7 +98,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
[ first 0 ]
|
||||
[ first2 ]
|
||||
[ second 0 swap ]
|
||||
} cleave 8 narray >c-float-array ;
|
||||
} cleave 8 float-array{ } nsequence ;
|
||||
|
||||
: fill-rect-vertices ( dim -- )
|
||||
(fill-rect-vertices) gl-vertex-pointer ;
|
||||
|
|
@ -130,10 +131,10 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
#! X3100 driver.
|
||||
circle-points close-path concat >c-float-array ;
|
||||
circle-points close-path concat >float-array ;
|
||||
|
||||
: fill-circle-vertices ( loc dim steps -- vertices )
|
||||
circle-points concat >c-float-array ;
|
||||
circle-points concat >float-array ;
|
||||
|
||||
: (gen-gl-object) ( quot -- id )
|
||||
[ 1 0 <uint> ] dip keep *uint ; inline
|
||||
|
|
@ -174,7 +175,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
glActiveTexture swap glBindTexture gl-error ;
|
||||
|
||||
: (set-draw-buffers) ( buffers -- )
|
||||
dup length swap >c-uint-array glDrawBuffers ;
|
||||
[ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
|
||||
|
||||
MACRO: set-draw-buffers ( buffers -- )
|
||||
words>values [ (set-draw-buffers) ] curry ;
|
||||
|
|
@ -219,11 +220,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
|
||||
: gl-translate ( point -- ) first2 0.0 glTranslated ;
|
||||
|
||||
MEMO: (rect-texture-coords) ( -- seq )
|
||||
{ 0 0 1 0 1 1 0 1 } >c-float-array ;
|
||||
|
||||
: rect-texture-coords ( -- )
|
||||
(rect-texture-coords) gl-texture-coord-pointer ;
|
||||
float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
|
||||
|
||||
: draw-sprite ( sprite -- )
|
||||
GL_TEXTURE_COORD_ARRAY [
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! mersenne twister based on
|
||||
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
|
||||
USING: arrays kernel math namespaces sequences system init
|
||||
USING: kernel math namespaces sequences system init
|
||||
accessors math.ranges random circular math.bitwise
|
||||
combinators ;
|
||||
combinators specialized-arrays.uint ;
|
||||
IN: random.mersenne-twister
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -39,11 +39,11 @@ TUPLE: mersenne-twister seq i ;
|
|||
|
||||
: init-mt-rest ( seq -- )
|
||||
mt-n 1- swap [
|
||||
[ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
|
||||
[ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
|
||||
] curry each ;
|
||||
|
||||
: init-mt-seq ( seed -- seq )
|
||||
32 bits mt-n 0 <array> <circular>
|
||||
32 bits mt-n <uint-array> <circular>
|
||||
[ set-first ] [ init-mt-rest ] [ ] tri ;
|
||||
|
||||
: mt-temper ( y -- yt )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: tools.test kernel serialize serialize.private io
|
||||
io.streams.byte-array math alien arrays byte-arrays bit-arrays
|
||||
float-arrays sequences math prettyprint parser classes
|
||||
math.constants io.encodings.binary random assocs ;
|
||||
USING: tools.test kernel serialize io io.streams.byte-array math
|
||||
alien arrays byte-arrays bit-arrays specialized-arrays.double
|
||||
sequences math prettyprint parser classes math.constants
|
||||
io.encodings.binary random assocs serialize.private ;
|
||||
IN: serialize.tests
|
||||
|
||||
: test-serialize-cell
|
||||
|
|
@ -48,7 +48,7 @@ C: <serialize-test> serialize-test
|
|||
T{ serialize-test f "a" 2 }
|
||||
B{ 50 13 55 64 1 }
|
||||
?{ t f t f f t f }
|
||||
F{ 1.0 3.0 4.0 1.0 2.35 0.33 }
|
||||
double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 }
|
||||
<< 1 [ 2 ] curry parsed >>
|
||||
{ { "a" "bc" } { "de" "fg" } }
|
||||
H{ { "a" "bc" } { "de" "fg" } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.alien
|
||||
|
||||
<< "void*" define-array >>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.bool
|
||||
|
||||
<< "bool" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.char
|
||||
|
||||
<< "char" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.alien specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.alien
|
||||
|
||||
<< "void*" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.bool specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.bool
|
||||
|
||||
<< "bool" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.char specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.char
|
||||
|
||||
<< "char" define-direct-array >>
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
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"
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: specialized-arrays.direct
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.double specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.double
|
||||
|
||||
<< "double" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.float specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.float
|
||||
|
||||
<< "float" define-direct-array >>
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! 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 ;
|
||||
IN: specialized-arrays.direct.functor
|
||||
|
||||
FUNCTOR: define-direct-array ( T -- )
|
||||
|
||||
A' IS ${T}-array
|
||||
>A' IS >${T}-array
|
||||
<A'> IS <${A'}>
|
||||
|
||||
A DEFINES direct-${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
|
||||
NTH [ T dup c-getter array-accessor ]
|
||||
SET-NTH [ T dup c-setter array-accessor ]
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: A
|
||||
{ underlying alien read-only }
|
||||
{ length fixnum read-only } ;
|
||||
|
||||
: <A> ( alien len -- direct-array ) A boa ; inline
|
||||
M: A length length>> ;
|
||||
M: A nth-unsafe underlying>> NTH call ;
|
||||
M: A set-nth-unsafe underlying>> SET-NTH call ;
|
||||
M: A like drop dup A instance? [ >A' execute ] unless ;
|
||||
M: A new-sequence drop <A'> execute ;
|
||||
|
||||
INSTANCE: A sequence
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.int specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.int
|
||||
|
||||
<< "int" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.long specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.long
|
||||
|
||||
<< "long" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.longlong
|
||||
|
||||
<< "longlong" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.short specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.short
|
||||
|
||||
<< "short" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.uchar
|
||||
|
||||
<< "uchar" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.uint specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.uint
|
||||
|
||||
<< "uint" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.ulong
|
||||
|
||||
<< "ulong" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.ulonglong
|
||||
|
||||
<< "ulonglong" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
|
||||
IN: specialized-arrays.direct.ushort
|
||||
|
||||
<< "ushort" define-direct-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.double
|
||||
|
||||
<< "double" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.float
|
||||
|
||||
<< "float" define-array >>
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors sequences sequences.private prettyprint.backend
|
||||
kernel words classes math parser alien.c-types byte-arrays
|
||||
accessors summary ;
|
||||
IN: specialized-arrays.functor
|
||||
|
||||
ERROR: bad-byte-array-length byte-array type ;
|
||||
|
||||
M: bad-byte-array-length summary
|
||||
drop "Byte array length doesn't divide type width" ;
|
||||
|
||||
FUNCTOR: define-array ( T -- )
|
||||
|
||||
A DEFINES ${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
>A DEFINES >${A}
|
||||
byte-array>A DEFINES byte-array>${A}
|
||||
A{ DEFINES ${A}{
|
||||
|
||||
NTH [ T dup c-getter array-accessor ]
|
||||
SET-NTH [ T dup c-setter array-accessor ]
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: A
|
||||
{ length array-capacity read-only }
|
||||
{ underlying byte-array read-only } ;
|
||||
|
||||
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; 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
|
||||
|
||||
M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
|
||||
|
||||
M: A length length>> ;
|
||||
|
||||
M: A nth-unsafe underlying>> NTH call ;
|
||||
|
||||
M: A set-nth-unsafe underlying>> SET-NTH call ;
|
||||
|
||||
: >A ( seq -- specialized-array ) A new clone-like ; inline
|
||||
|
||||
M: A like drop dup A instance? [ >A execute ] unless ;
|
||||
|
||||
M: A new-sequence drop <A> execute ;
|
||||
|
||||
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 ;
|
||||
|
||||
M: A byte-length underlying>> length ;
|
||||
|
||||
M: A pprint-delims drop A{ \ } ;
|
||||
|
||||
M: A >pprint-sequence ;
|
||||
|
||||
M: A pprint* pprint-object ;
|
||||
|
||||
: A{ \ } [ >A execute ] parse-literal ; parsing
|
||||
|
||||
INSTANCE: A sequence
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.int
|
||||
|
||||
<< "int" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.long
|
||||
|
||||
<< "long" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.longlong
|
||||
|
||||
<< "longlong" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.short
|
||||
|
||||
<< "short" define-array >>
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
USING: help.markup help.syntax byte-arrays ;
|
||||
IN: specialized-arrays
|
||||
|
||||
ARTICLE: "specialized-arrays" "Specialized arrays"
|
||||
"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
|
||||
$nl
|
||||
"For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "specialized-arrays.T" } ":"
|
||||
{ $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 "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{" } { "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."
|
||||
$nl
|
||||
"The primitive C types for which specialized 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" }
|
||||
}
|
||||
"Note that " { $vocab-link "specialized-arrays.bool" } " behaves like a C " { $snippet "bool[]" } " array, and each element takes up 8 bits of space. For a more space-efficient boolean array, see " { $link "bit-arrays" } "."
|
||||
$nl
|
||||
"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary."
|
||||
$nl
|
||||
"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ;
|
||||
|
||||
ABOUT: "specialized-arrays"
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
IN: specialized-arrays.tests
|
||||
USING: tools.test specialized-arrays sequences
|
||||
specialized-arrays.int specialized-arrays.bool
|
||||
specialized-arrays.ushort alien.c-types accessors kernel ;
|
||||
|
||||
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
|
||||
|
||||
[ t ] [ int-array{ 1 2 3 } int-array? ] unit-test
|
||||
|
||||
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
|
||||
|
||||
[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
|
||||
|
||||
[ ushort-array{ 1234 } ] [
|
||||
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
|
||||
] unit-test
|
||||
|
||||
[ B{ 210 4 1 } byte-array>ushort-array ] must-fail
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: specialized-arrays
|
||||
|
|
@ -0,0 +1 @@
|
|||
Arrays of unboxed primitive C types
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.uchar
|
||||
|
||||
<< "uchar" define-array >>
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.uint
|
||||
|
||||
<< "uint" define-array >>
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue