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

db4
Doug Coleman 2008-12-03 08:34:59 -06:00
commit c4a06d4a60
298 changed files with 1262 additions and 837 deletions

View File

@ -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" } "." ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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? [

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 )
[

View File

@ -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." } ;

View File

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

View File

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

View File

@ -1 +0,0 @@
Efficient fixed-length floating point number arrays

View File

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

View File

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

View File

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

View File

@ -1 +0,0 @@
Growable float arrays

View File

View File

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

View File

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

View File

@ -0,0 +1 @@
First-class syntax

1
basis/functors/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

View File

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

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.alien ;
IN: io.mmap.alien
<< "void*" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.bool ;
IN: io.mmap.bool
<< "bool" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.char ;
IN: io.mmap.char
<< "char" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.double ;
IN: io.mmap.double
<< "double" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.float ;
IN: io.mmap.float
<< "float" define-mapped-array >>

View File

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

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.int ;
IN: io.mmap.int
<< "int" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.long ;
IN: io.mmap.long
<< "long" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.longlong ;
IN: io.mmap.longlong
<< "longlong" define-mapped-array >>

View File

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

View File

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

View File

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

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.short ;
IN: io.mmap.short
<< "short" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.uchar ;
IN: io.mmap.uchar
<< "uchar" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.uint ;
IN: io.mmap.uint
<< "uint" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.ulong ;
IN: io.mmap.ulong
<< "ulong" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
IN: io.mmap.ulonglong
<< "ulonglong" define-mapped-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.ushort
<< "ushort" define-array >>

View File

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

View File

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

View File

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

15
basis/io/windows/nt/monitors/monitors.factor Normal file → Executable file
View File

@ -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 )
[

View File

@ -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." } ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.alien
<< "void*" define-array >>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.bool
<< "bool" define-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.char
<< "char" define-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.alien specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.alien
<< "void*" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.bool specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.bool
<< "bool" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.char specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.char
<< "char" define-direct-array >>

View File

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

View File

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

View File

@ -0,0 +1,3 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: specialized-arrays.direct

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.double specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.double
<< "double" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.float specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.float
<< "float" define-direct-array >>

View File

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

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.int specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.int
<< "int" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.long specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.long
<< "long" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.longlong
<< "longlong" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.short specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.short
<< "short" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.uchar
<< "uchar" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.uint specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.uint
<< "uint" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.ulong
<< "ulong" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.ulonglong
<< "ulonglong" define-direct-array >>

View File

@ -0,0 +1,4 @@
USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.ushort
<< "ushort" define-direct-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.double
<< "double" define-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.float
<< "float" define-array >>

View File

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

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.int
<< "int" define-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.long
<< "long" define-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.longlong
<< "longlong" define-array >>

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.short
<< "short" define-array >>

View File

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

View File

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

View File

@ -0,0 +1,3 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: specialized-arrays

View File

@ -0,0 +1 @@
Arrays of unboxed primitive C types

View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.uchar
<< "uchar" define-array >>

View File

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