IN: alien.arrays\r
USING: help.syntax help.markup byte-arrays alien.c-types ;\r
\r
-ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"\r
-"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:"\r
-{ $subsection >c-bool-array }\r
-{ $subsection >c-char-array }\r
-{ $subsection >c-double-array }\r
-{ $subsection >c-float-array }\r
-{ $subsection >c-int-array }\r
-{ $subsection >c-long-array }\r
-{ $subsection >c-longlong-array }\r
-{ $subsection >c-short-array }\r
-{ $subsection >c-uchar-array }\r
-{ $subsection >c-uint-array }\r
-{ $subsection >c-ulong-array }\r
-{ $subsection >c-ulonglong-array }\r
-{ $subsection >c-ushort-array }\r
-{ $subsection >c-void*-array }\r
-{ $subsection c-bool-array> }\r
-{ $subsection c-char-array> }\r
-{ $subsection c-double-array> }\r
-{ $subsection c-float-array> }\r
-{ $subsection c-int-array> }\r
-{ $subsection c-long-array> }\r
-{ $subsection c-longlong-array> }\r
-{ $subsection c-short-array> }\r
-{ $subsection c-uchar-array> }\r
-{ $subsection c-uint-array> }\r
-{ $subsection c-ulong-array> }\r
-{ $subsection c-ulonglong-array> }\r
-{ $subsection c-ushort-array> }\r
-{ $subsection c-void*-array> } ;\r
-\r
-ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"\r
-"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:"\r
-{ $subsection char-nth }\r
-{ $subsection set-char-nth }\r
-{ $subsection uchar-nth }\r
-{ $subsection set-uchar-nth }\r
-{ $subsection short-nth }\r
-{ $subsection set-short-nth }\r
-{ $subsection ushort-nth }\r
-{ $subsection set-ushort-nth }\r
-{ $subsection int-nth }\r
-{ $subsection set-int-nth }\r
-{ $subsection uint-nth }\r
-{ $subsection set-uint-nth }\r
-{ $subsection long-nth }\r
-{ $subsection set-long-nth }\r
-{ $subsection ulong-nth }\r
-{ $subsection set-ulong-nth }\r
-{ $subsection longlong-nth }\r
-{ $subsection set-longlong-nth }\r
-{ $subsection ulonglong-nth }\r
-{ $subsection set-ulonglong-nth }\r
-{ $subsection float-nth }\r
-{ $subsection set-float-nth }\r
-{ $subsection double-nth }\r
-{ $subsection set-double-nth }\r
-{ $subsection void*-nth }\r
-{ $subsection set-void*-nth } ;\r
-\r
ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
$nl\r
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
-{ $subsection "c-arrays-factor" }\r
-{ $subsection "c-arrays-get/set" } ;\r
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;\r
[
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
: new-c-type ( class -- type )
new
- int-regs >>reg-class ;
+ int-regs >>reg-class ; inline
: <c-type> ( -- type )
\ c-type new-c-type ;
: 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 )
: 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 )
- >r "-nth" append r> create ;
-
-: define-nth ( name vocab -- )
- dupd nth-word swap dup c-getter (define-nth) ;
-
-: set-nth-word ( name vocab -- word )
- >r "set-" swap "-nth" 3append r> 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 -- )
- >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
M: long-long-type box-return ( type -- )
f swap box-parameter ;
-: define-deref ( name vocab -- )
- >r dup CHAR: * prefix r> 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
- >r >r constructor-word r> r> prefix define-inline ;
+: define-out ( name -- )
+ [ "alien.c-types" constructor-word ]
+ [ [ [ <c-object> ] curry ] [ c-setter ] bi append ] 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 )
- >r ">c-" swap "-array" 3append r> 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 )
- >r "c-" swap "-array>" 3append r> 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? [
- unclip >r [
- dup word? [
- def>> { } swap with-datastack first
- ] when
- ] map r> prefix
+ unclip [
+ [
+ dup word? [
+ def>> { } swap with-datastack first
+ ] when
+ ] map
+ ] dip prefix
] when ;
: malloc-file-contents ( path -- alien len )
: 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>
[ alien-cell ] >>getter
: c-struct? ( type -- ? ) (c-type) struct-type? ;
-: (define-struct) ( name vocab size align fields -- )
+: (define-struct) ( name size align fields -- )
>r [ align ] keep r>
struct-type boa
- -rot define-c-type ;
+ swap typedef ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 <field-spec> ] 2curry map ;
-! 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 ;
NSOpenGLPFASamples , 8 ,
] when
0 ,
- ] { } make >c-int-array
+ ] int-array{ } make underlying>>
-> initWithAttributes:
-> autorelease ;
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
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" } ;
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 ;
+combinators vectors ;
IN: compiler.tests
! Originally, this file did black box testing of templating
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 )
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 ;
+specialized-arrays.double system sorting ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ { 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
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 )
} 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 ;
] 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 )
[
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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." } ;
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
-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 ;
-
-! Rice
-USING: hints math.vectors arrays ;
-
-HINTS: vneg { float-array } { array } ;
-HINTS: v*n { float-array float } { array object } ;
-HINTS: n*v { float float-array } { array object } ;
-HINTS: v/n { float-array float } { array object } ;
-HINTS: n/v { float float-array } { object array } ;
-HINTS: v+ { float-array float-array } { array array } ;
-HINTS: v- { float-array float-array } { array array } ;
-HINTS: v* { float-array float-array } { array array } ;
-HINTS: v/ { float-array float-array } { array array } ;
-HINTS: vmax { float-array float-array } { array array } ;
-HINTS: vmin { float-array float-array } { array array } ;
-HINTS: v. { float-array float-array } { array array } ;
-HINTS: norm-sq { float-array } { array } ;
-HINTS: norm { float-array } { array } ;
-HINTS: normalize { float-array } { array } ;
-
-! More rice. Experimental, currently causes a slowdown in raytracer
-! for some odd reason.
-
-USING: words classes.algebra compiler.tree.propagation.info ;
-
-{ 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 object ? <class-info>
-] "outputs" set-word-prop
-
-\ v. [
- [ class>> float-array class<= ] both?
- float object ? <class-info>
-] "outputs" set-word-prop
+++ /dev/null
-Efficient fixed-length floating point number arrays
+++ /dev/null
-collections
+++ /dev/null
-USING: arrays float-arrays help.markup help.syntax kernel\r
-combinators ;\r
-IN: float-vectors\r
-\r
-ARTICLE: "float-vectors" "Float vectors"\r
-"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."\r
-$nl\r
-"Float vectors form a class:"\r
-{ $subsection float-vector }\r
-{ $subsection float-vector? }\r
-"Creating float vectors:"\r
-{ $subsection >float-vector }\r
-{ $subsection <float-vector> }\r
-"Literal syntax:"\r
-{ $subsection POSTPONE: FV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"\r
-{ $code "FV{ } clone" } ;\r
-\r
-ABOUT: "float-vectors"\r
-\r
-HELP: float-vector\r
-{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;\r
-\r
-HELP: <float-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;\r
-\r
-HELP: >float-vector\r
-{ $values { "seq" "a sequence" } { "float-vector" float-vector } }\r
-{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;\r
-\r
-HELP: FV{\r
-{ $syntax "FV{ elements... }" }\r
-{ $values { "elements" "a list of real numbers" } }\r
-{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;\r
+++ /dev/null
-USING: tools.test float-vectors vectors sequences kernel math ;\r
-IN: float-vectors.tests\r
-\r
-[ 0 ] [ 123 <float-vector> length ] unit-test\r
-\r
-: do-it\r
- 12345 [ >float over push ] each ;\r
-\r
-[ t ] [\r
- 3 <float-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ FV{ } float-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable float-arrays prettyprint.backend\r
-parser accessors ;\r
-IN: float-vectors\r
-\r
-TUPLE: float-vector\r
-{ underlying float-array initial: F{ } }\r
-{ length array-capacity } ;\r
-\r
-: <float-vector> ( n -- float-vector )\r
- <float-array> 0 float-vector boa ; inline\r
-\r
-: >float-vector ( seq -- float-vector )\r
- T{ float-vector f F{ } 0 } clone-like ;\r
-\r
-M: float-vector like\r
- drop dup float-vector? [\r
- dup float-array?\r
- [ dup length float-vector boa ] [ >float-vector ] if\r
- ] unless ;\r
-\r
-M: float-vector new-sequence\r
- drop [ <float-array> ] [ >fixnum ] bi float-vector boa ;\r
-\r
-M: float-vector equal?\r
- over float-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: float-array new-resizable drop <float-vector> ;\r
-\r
-INSTANCE: float-vector growable\r
-\r
-: FV{ \ } [ >float-vector ] parse-literal ; parsing\r
-\r
-M: float-vector >pprint-sequence ;\r
-M: float-vector pprint-delims drop \ FV{ \ } ;\r
-M: float-vector pprint* pprint-object ;\r
+++ /dev/null
-Growable float arrays
+++ /dev/null
-collections
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel locals.private quotations classes.tuple
+classes.tuple.parser make lexer combinators generic words
+interpolate namespaces sequences io.streams.string fry
+classes.mixin ;
+IN: functors
+
+: scan-param ( -- obj )
+ scan-object dup special? [ literalize ] unless ;
+
+: define* ( word def -- ) over set-word define ;
+
+: `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:
+ scan-param parsed
+ scan-param parsed
+ \ create-method parsed
+ parse-definition parsed
+ \ define* parsed ; parsing
+
+: `C:
+ scan-param parsed
+ scan-param parsed
+ [ [ boa ] curry define* ] over push-all ; parsing
+
+: `:
+ scan-param parsed
+ parse-definition parsed
+ \ define* parsed ; parsing
+
+: `INSTANCE:
+ scan-param parsed
+ scan-param parsed
+ \ add-mixin-instance parsed ; parsing
+
+: `inline \ inline parsed ; parsing
+
+: `parsing \ parsing parsed ; parsing
+
+: (INTERPOLATE) ( accum quot -- accum )
+ [ scan interpolate-locals ] dip
+ '[ _ with-string-writer @ ] parsed ;
+
+: IS [ search ] (INTERPOLATE) ; parsing
+
+: DEFINES [ in get create ] (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 }
+ } ;
+
+: 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
+
+: APPLY: scan-word scan-word execute swap '[ _ execute ] each ; parsing
--- /dev/null
+First-class syntax
--- /dev/null
+extensions
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors accessors alien.c-types math kernel words ;
+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: mapped-array-functor ( T -- )
+
+C DEFINES <mapped-${T}-array>
+<A> IS <direct-${T}-array>
+
+WHERE
+
+: C mapped-file>direct <A> execute ; inline
+
+;FUNCTOR
! 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 ;
+sequences.private system vocabs.loader combinators
+specialized-arrays.direct functors alien.c-types
+io.mmap.functor ;
IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
: with-mapped-file ( path length quot -- )
>r <mapped-file> r> with-disposal ; inline
+APPLY: mapped-array-functor primitive-types
+
{
{ [ os unix? ] [ "io.unix.mmap" require ] }
{ [ os winnt? ] [ "io.windows.mmap" require ] }
! 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 ;
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>
+ dup underlying>> pipe io-error
+ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ;
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
over get-environment
[ swap % "=" % % "\0" % ] assoc-each
"\0" %
- ] "" make >c-ushort-array
+ ] ushort-array{ } make underlying>>
>>lpEnvironment
] when ;
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 ;
} 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 )
[
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
-
:: literal-identity-test ( -- a b )
{ } V{ } ;
"|" parse-tokens make-locals dup push-locals
\ ] (parse-lambda) <lambda> ;
-: parse-binding ( -- pair/f )
- scan dup "|" = [
+: parse-binding ( end -- pair/f )
+ scan tuck = [
drop f
] [
- scan {
- { "[" [ \ ] parse-until >quotation ] }
- { "[|" [ parse-lambda ] }
- } case 2array
+ scan-object 2array
] if ;
-: (parse-bindings) ( -- )
- parse-binding [
+: (parse-bindings) ( end -- )
+ dup parse-binding dup [
first2 >r make-local r> 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
] { } make-assoc
] { } make swap ;
-: (parse-wbindings) ( -- )
- parse-binding [
+: (parse-wbindings) ( end -- )
+ dup parse-binding dup [
first2 >r make-local-word r> 2array ,
(parse-wbindings)
- ] when* ;
+ ] [ 2drop ] if ;
-: parse-wbindings ( -- bindings vars )
+: parse-wbindings ( end -- bindings vars )
[
[ (parse-wbindings) ] H{ } make-assoc
dup push-locals
let-rewrite ;
: parse-locals ( -- vars assoc )
- ")" parse-effect
+ scan "(" assert= ")" 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 )
- scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
+ parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: [| parse-lambda parsed-lambda ; parsing
: [let
- scan "|" assert= parse-bindings
+ scan "|" assert= "|" parse-bindings
\ ] (parse-lambda) <let> parsed-lambda ; parsing
: [let*
- scan "|" assert= parse-bindings*
+ scan "|" assert= "|" parse-bindings*
\ ] (parse-lambda) <let*> parsed-lambda ; parsing
: [wlet
- scan "|" assert= parse-wbindings
+ scan "|" assert= "|" parse-wbindings
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing
: :: (::) define ; parsing
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 )
glMatrixMode glPopMatrix ; inline
: gl-material ( face pname params -- )
- >c-float-array glMaterialfv ;
+ >float-array underlying>> glMaterialfv ;
: gl-vertex-pointer ( seq -- )
[ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
- append >c-float-array gl-vertex-pointer ;
+ append >float-array underlying>> gl-vertex-pointer ;
: gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
[ first 1- 1 ]
[ [ first 1- ] [ second ] bi ]
[ second 0 swap ]
- } cleave 8 narray >c-float-array ;
+ } cleave 8 float-array{ } nsequence underlying>> ;
: rect-vertices ( dim -- )
(rect-vertices) gl-vertex-pointer ;
[ first 0 ]
[ first2 ]
[ second 0 swap ]
- } cleave 8 narray >c-float-array ;
+ } cleave 8 float-array{ } nsequence underlying>> ;
: fill-rect-vertices ( dim -- )
(fill-rect-vertices) gl-vertex-pointer ;
circle-steps unit-circle adjust-points scale-points ;
: circle-vertices ( loc dim steps -- vertices )
- circle-points concat >c-float-array ;
+ circle-points concat >float-array underlying>> ;
: (gen-gl-object) ( quot -- id )
>r 1 0 <uint> r> keep *uint ; inline
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 ;
: 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 [
! See http://factorcode.org/license.txt for BSD license.
!
USING: tools.test kernel serialize 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 ;
+alien arrays byte-arrays bit-arrays specialized-arrays.double
+sequences math prettyprint parser classes math.constants
+io.encodings.binary random assocs ;
IN: serialize.tests
: test-serialize-cell
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" } }
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.alien
+
+<< "void*" define-array >>
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.bool
+
+<< "bool" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.char
+
+<< "char" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.alien
+
+<< "void*" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.bool
+
+<< "bool" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.char
+
+<< "char" define-direct-array >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: specialized-arrays.direct
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.double
+
+<< "double" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.float
+
+<< "float" define-direct-array >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private kernel words classes
+math alien alien.c-types byte-arrays accessors
+specialized-arrays ;
+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> 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
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.int
+
+<< "int" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.long
+
+<< "long" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.longlong
+
+<< "longlong" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.short
+
+<< "short" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.uchar
+
+<< "uchar" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.uint
+
+<< "uint" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.ulong
+
+<< "ulong" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.ulonglong
+
+<< "ulonglong" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.direct.functor
+IN: specialized-arrays.direct.ushort
+
+<< "ushort" define-direct-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.double
+
+<< "double" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.float
+
+<< "float" define-array >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private
+prettyprint.backend kernel words classes math parser
+alien.c-types byte-arrays accessors ;
+IN: specialized-arrays.functor
+
+FUNCTOR: define-array ( T -- )
+
+A DEFINES ${T}-array
+<A> DEFINES <${A}>
+>A DEFINES >${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> dup T <c-array> 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 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
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.int
+
+<< "int" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.long
+
+<< "long" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.longlong
+
+<< "longlong" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.short
+
+<< "short" define-array >>
\ No newline at end of file
--- /dev/null
+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:"
+{ $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 "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" }
+}
+"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"
--- /dev/null
+IN: specialized-arrays.tests
+USING: tools.test specialized-arrays sequences
+specialized-arrays.int speicalized-arrays.bool ;
+
+[ 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: specialized-arrays
--- /dev/null
+Arrays of unboxed primitive C types
--- /dev/null
+collections
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.uchar
+
+<< "uchar" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.uint
+
+<< "uint" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.ulong
+
+<< "ulong" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.ulonglong
+
+<< "ulonglong" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.ushort
+
+<< "ushort" define-array >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.alien
+
+<< "void*" define-vector >>
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.bool
+
+<< "bool" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.char
+
+<< "char" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.double
+
+<< "double" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.float
+
+<< "float" define-vector >>
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private growable
+prettyprint.backend kernel words classes math parser ;
+IN: specialized-vectors.functor
+
+FUNCTOR: define-vector ( T -- )
+
+A IS ${T}-array
+<A> IS <A>
+
+V DEFINES ${T}-vector
+<V> DEFINES <${V}>
+>V DEFINES >${V}
+V{ DEFINES ${V}{
+
+WHERE
+
+TUPLE: V { underlying A } { length array-capacity } ;
+
+: <V> <A> execute 0 V boa ; inline
+
+M: V like
+ drop dup V instance? [
+ dup A instance? [ dup length V boa ] [ >V execute ] if
+ ] unless ;
+
+M: V new-sequence drop [ <A> execute ] [ >fixnum ] bi V boa ;
+
+M: A new-resizable drop <V> execute ;
+
+M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
+
+: >V V new clone-like ; inline
+
+M: V pprint-delims drop V{ \ } ;
+
+M: V >pprint-sequence ;
+
+M: V pprint* pprint-object ;
+
+: V{ [ >V execute ] parse-literal ; parsing
+
+INSTANCE: V growable
+
+;FUNCTOR
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.int
+
+<< "int" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.long
+
+<< "long" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.longlong
+
+<< "longlong" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.short
+
+<< "short" define-vector >>
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax byte-vectors ;
+IN: specialized-vectors
+
+ARTICLE: "specialized-vectors" "Specialized vectors"
+"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable 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:"
+{ $table
+ { { $snippet "T-vector" } { "The class of vectors with elements of type " { $snippet "T" } } }
+ { { $snippet "<T-vector>" } { "Constructor for vectors with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- vector )" } } }
+ { { $snippet ">T-vector" } { "Converts a sequence into a specialized vector of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- vector )" } } }
+ { { $snippet "T-vector{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
+}
+"The primitive C types for which specialized vectors 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" }
+}
+"Specialized vectors are generated with a functor in the " { $vocab-link "specialized-vectors.functor" } " vocabulary."
+$nl
+"The " { $vocab-link "specialized-arrays" } " vocabulary provides fixed-length versions of the above." ;
+
+ABOUT: "specialized-vectors"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: specialized-vectors
--- /dev/null
+Vectors of unboxed primitive C types
--- /dev/null
+collections
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.uchar
+
+<< "uchar" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.uint
+
+<< "uint" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.ulong
+
+<< "ulong" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.ulonglong
+
+<< "ulonglong" define-vector >>
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-vector.ushort
+
+<< "ushort" define-vector >>
\ No newline at end of file
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-ui.render math.geometry.rect locals alien.c-types ;
+ui.render math.geometry.rect locals alien.c-types
+specialized-arrays.float ;
IN: ui.gadgets.buttons
} cleave 4array ;
: checkmark-vertices ( dim -- vertices )
- checkmark-points concat >c-float-array ;
+ checkmark-points concat >float-array underlying>> ;
PRIVATE>
USING: accessors alien alien.c-types arrays hashtables io kernel
math namespaces opengl opengl.gl opengl.glu sequences strings
io.styles vectors combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect locals ;
+math.order math.geometry.rect locals specialized-arrays.float ;
IN: ui.render
SYMBOL: clip
direction dim v* dim over v- swap
colors length dup 1- v/n [ v*n ] with map
[ dup rot v+ 2array ] with map
- concat concat >c-float-array ;
+ concat concat >float-array underlying>> ;
: gradient-colors ( colors -- seq )
- [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+ [ color>raw 4array dup 2array ] map concat concat
+ >float-array underlying>> ;
M: gradient recompute-pen ( gadget gradient -- )
tuck
TUPLE: polygon color vertex-array count ;
: <polygon> ( color points -- polygon )
- [ concat >c-float-array ] [ length ] bi polygon boa ;
+ [ concat >float-array underlying>> ] [ length ] bi polygon boa ;
: draw-polygon ( polygon mode -- )
swap
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
-combinators.short-circuit fry kernel layouts sequences ;
+combinators.short-circuit fry kernel layouts sequences
+specialized-arrays.alien ;
IN: unix.utilities
: more? ( alien -- ? )
[ ] produce nip ;
: strings>alien ( strings encoding -- alien )
- '[ _ malloc-string ] map f suffix >c-void*-array ;
+ '[ _ malloc-string ] void*-array{ } map f suffix underlying>> ;
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit ;
-: byte-array>malloc ( byte-array -- alien )
- [ byte-length malloc ] [ over byte-array>memory ] bi ;
-
: (callback-word) ( function-name interface-name counter -- word )
[ "::" rot 3append "-callback-" ] dip number>string 3append
"windows.com.wrapper.callbacks" create ;
1 0 rot set-ulong-nth ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] map >c-void*-array byte-array>malloc ;
+ [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
+io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants
+specialized-arrays.int ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
- } [ x-atom ] map >c-int-array
+ } [ x-atom ] int-array{ } map-as underlying>>
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
>r "TIMESTAMP" x-atom 32 PropModeReplace r>
- XSelectionRequestEvent-time 1array >c-int-array
+ XSelectionRequestEvent-time <int>
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
!
! based on glx.h from xfree86, and some of glxtokens.h
USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib
-namespaces make kernel sequences parser words ;
+namespaces make kernel sequences parser words specialized-arrays.int ;
IN: x11.glx
LIBRARY: glx
GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
- ] { } make >c-int-array
+ ] int-array{ } make underlying>>
glXChooseVisual
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
SYMBOL: keysym
: prepare-lookup ( -- )
- buf-size "uint" <c-array> keybuf set
+ buf-size <uint-array> keybuf set
0 <KeySym> keysym set ;
: finish-lookup ( len -- string keysym )
- keybuf get swap c-uint-array> >string
+ keybuf get swap 2 * head utf16n decode
keysym get *KeySym ;
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
- swap keybuf get buf-size keysym get 0 <int>
+ swap keybuf get underlying>> buf-size keysym get 0 <int>
XwcLookupString
finish-lookup
] with-scope ;
"syntax" lookup t "delimiter" set-word-prop ;
: define-syntax ( name quot -- )
- >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
+ >r "syntax" lookup dup r> define make-parsing ;
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax
- "parsing" [ word t "parsing" set-word-prop ] define-syntax
+ "parsing" [ word make-parsing ] define-syntax
"SYMBOL:" [
CREATE-WORD define-symbol
PREDICATE: parsing-word < word "parsing" word-prop ;
+: make-parsing ( word -- ) t "parsing" set-word-prop ;
+
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
-USING: sequences alien.c-types math hints kernel byte-arrays ;
+USING: sequences hints kernel math specialized-arrays.int ;
IN: benchmark.dawes
! Phil Dawes's performance problem
-: int-length ( byte-array -- n ) length "int" heap-size /i ; inline
+: count-ones ( byte-array -- n ) [ 1 = ] sigma ;
-: count-ones ( byte-array -- n )
- 0 swap [ int-length ] keep [
- int-nth 1 = [ 1 + ] when
- ] curry each-integer ;
-
-HINTS: count-ones byte-array ;
+HINTS: count-ones int-array ;
: make-byte-array ( -- byte-array )
- 120000 [ 255 bitand ] map >c-int-array ;
+ 120000 [ 255 bitand ] int-array{ } map-as ;
: dawes-benchmark ( -- )
make-byte-array 200 swap [ count-ones ] curry replicate drop ;
USING: alien.c-types continuations destructors kernel
-opengl opengl.gl bunny.model ;
+opengl opengl.gl bunny.model specialized-arrays.float ;
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;
GL_LIGHTING glEnable
GL_LIGHT0 glEnable
GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_POSITION float-array{ 1.0 -1.0 1.0 1.0 } underlying>> glLightfv
GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
http.client io io.encodings.ascii io.files kernel math
math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
-sequences.lib splitting vectors words ;
+sequences.lib splitting vectors words
+specialized-arrays.double specialized-arrays.uint ;
IN: bunny.model
: numbers ( str -- seq )
{
[
[ first concat ] [ second concat ] bi
- append >c-float-array
+ append >double-array underlying>>
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[
- third concat >c-uint-array
+ third concat >uint-array underlying>>
GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[ first length 3 * ]
! http://cairographics.org/samples/
USING: cairo cairo.ffi locals math.constants math
io.backend kernel alien.c-types libc namespaces
-cairo.gadgets ui.gadgets accessors ;
+cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
IN: cairo.samples
TUPLE: dash-gadget < cairo-gadget ;
M:: dash-gadget render-cairo* ( gadget -- )
- [let | dashes [ { 50 10 10 10 } >c-double-array ]
+ [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
ndash [ 4 ] |
cr dashes ndash -50 cairo_set_dash
cr 10 cairo_set_line_width
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors
ui.gadgets.handler ui.gestures assocs ui.gadgets macros
- qualified ;
+ qualified speicalized-arrays.double ;
QUALIFIED: syntax
IN: cfdg
2 * sin , 2 * cos neg , 0 , 0 ,
0 , 0 , 1 , 0 ,
0 , 0 , 0 , 1 , ]
- { } make >c-double-array glMultMatrixd ;
+ double-array{ } make underlying>> glMultMatrixd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-name "Hello world (console)" }
- { deploy-threads? f }
+ { deploy-unicode? f }
+ { deploy-reflection 1 }
{ deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-io 2 }
{ deploy-math? f }
- { deploy-ui? f }
- { deploy-compiler? f }
- { "stop-after-last-window?" t }
+ { deploy-name "Hello world (console)" }
{ deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-compiler? t }
+ { deploy-ui? f }
+ { deploy-threads? f }
+ { deploy-io 2 }
+ { deploy-c-types? f }
}
USING: accessors alien.c-types jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences float-arrays ;
+opengl.demo-support sequences specialized-arrays.float ;
IN: jamshred.gl
: min-vertices 6 ; inline
GL_FOG_DENSITY 0.09 glFogf
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
: player-view ( player -- )
[ location>> ]
math math.blas.cblas math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order multi-methods qualified
sequences sequences.merged sequences.private generalizations
-shuffle symbols ;
+shuffle symbols speicalized-arrays.float specialized-arrays.double ;
QUALIFIED: syntax
IN: math.blas.matrices
PRIVATE>
: >float-blas-matrix ( arrays -- matrix )
- [ >c-float-array ] (>matrix) <float-blas-matrix> ;
+ [ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
: >double-blas-matrix ( arrays -- matrix )
- [ >c-double-array ] (>matrix) <double-blas-matrix> ;
+ [ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
: >float-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >c-float-array ] (>matrix)
+ [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
<float-complex-blas-matrix> ;
: >double-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >c-double-array ] (>matrix)
+ [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
<double-complex-blas-matrix> ;
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel macros math math.blas.cblas
math.complex math.functions math.order multi-methods qualified
-sequences sequences.private generalizations ;
+sequences sequences.private generalizations
+specialized-arrays.float specialized-arrays.double
+specialized-arrays.direct.float specialized-arrays.direct.double ;
QUALIFIED: syntax
IN: math.blas.vectors
[ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
: (>c-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi 2array >c-float-array ;
+ [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
: (>z-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi 2array >c-double-array ;
+ [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
: (c-complex>) ( alien -- complex )
- 2 c-float-array> first2 rect> ;
+ 2 <direct-float-array> first2 rect> ;
: (z-complex>) ( alien -- complex )
- 2 c-double-array> first2 rect> ;
+ 2 <direct-double-array> first2 rect> ;
: (prepare-nth) ( n v -- n*inc v-data )
[ inc>> ] [ data>> ] bi [ * ] dip ;
} 2&& ;
: >float-blas-vector ( seq -- v )
- [ >c-float-array ] [ length ] bi 1 <float-blas-vector> ;
+ [ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
: >double-blas-vector ( seq -- v )
- [ >c-double-array ] [ length ] bi 1 <double-blas-vector> ;
+ [ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
: >float-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >c-float-array ] [ length ] bi
+ [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
1 <float-complex-blas-vector> ;
: >double-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >c-double-array ] [ length ] bi
+ [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
1 <double-complex-blas-vector> ;
syntax:M: float-blas-vector clone
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
- openal.backend ;
+ openal.backend specialized-arrays.uint ;
IN: openal
<< "alut" {
: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
: gen-sources ( size -- seq )
- dup <uint-array> 2dup alGenSources swap c-uint-array> ;
+ dup <uint-array> 2dup underlying>> alGenSources swap ;
: gen-buffers ( size -- seq )
- dup <uint-array> 2dup alGenBuffers swap c-uint-array> ;
+ dup <uint-array> 2dup underlying>> alGenBuffers swap ;
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
[ alBufferData ] 4keep alutUnloadWAV ;
: queue-buffers ( source buffers -- )
- [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ;
+ [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
: queue-buffer ( source buffer -- )
1array queue-buffers ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length
- dup "GLuint" <c-array>
+ dup <uint-array>
0 <int> swap
- [ glGetAttachedShaders ] { 3 1 } multikeep
- c-uint-array> ;
+ [ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline
M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
: 8bit-buffer-data ( seq -- data size )
- [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi ;
+ [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
: 16bit-buffer-data ( seq -- data size )
- [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi ;
+ [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
: stereo-data ( stereo-buffer -- left right )
[ left-data>> ] [ right-data>> ] bi@ ;
projects / factor.git / commitdiff