USING: byte-arrays arrays help.syntax help.markup
alien.syntax compiler definitions math libc
-debugger parser io io.backend system bit-arrays float-arrays
+debugger parser io io.backend system
alien.accessors ;
IN: alien
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
-kernel.private bit-arrays byte-arrays float-arrays arrays ;
+kernel.private byte-arrays arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
PREDICATE: simple-alien < alien underlying>> not ;
UNION: simple-c-ptr
-simple-alien POSTPONE: f byte-array bit-array float-array ;
+simple-alien POSTPONE: f byte-array ;
DEFER: pinned-c-ptr?
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax
-bit-arrays float-arrays debugger destructors ;
+debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
"Structure and union types are specified by the name of the structure or union." ;
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
-"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
+"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
$nl
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
{ $subsection <c-object> }
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays byte-arrays float-arrays arrays
-assocs kernel kernel.private libc math
+USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
GENERIC: byte-length ( seq -- n ) flushable
-M: bit-array byte-length length 7 + -3 shift ;
-
M: byte-array byte-length length ;
-M: float-array byte-length length "double" heap-size * ;
-
: c-getter ( name -- quot )
c-type c-type-getter [
[ "Cannot read struct fields with type" throw ]
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays generic assocs
-hashtables assocs hashtables.private io kernel kernel.private
-math namespaces parser prettyprint sequences sequences.private
-strings sbufs vectors words quotations assocs system layouts
-splitting grouping growable classes classes.builtin classes.tuple
+USING: alien arrays byte-arrays generic assocs hashtables assocs
+hashtables.private io kernel kernel.private math namespaces
+parser prettyprint sequences sequences.private strings sbufs
+vectors words quotations assocs system layouts splitting
+grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
-vocabs.loader source-files definitions debugger float-arrays
+vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order accessors ;
IN: bootstrap.image
pad-bytes emit-bytes
] emit-object ;
-M: bit-array ' bit-array emit-dummy-array ;
-
-M: float-array ' float-array emit-dummy-array ;
-
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array rest-slice ]
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
-hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts classes.tuple.private
+hashtables vectors strings sbufs arrays
+quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
-20 num-types set
+18 num-types set
H{
{ fixnum BIN: 000 }
tag-numbers get H{
{ array 8 }
{ wrapper 9 }
- { float-array 10 }
+ { byte-array 10 }
{ callstack 11 }
{ string 12 }
- { bit-array 13 }
+ { tuple-layout 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
{ word 17 }
- { byte-array 18 }
- { tuple-layout 19 }
} assoc-union type-numbers set
"alien"
"alien.accessors"
"arrays"
- "bit-arrays"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.predicate"
"compiler.units"
"continuations.private"
- "float-arrays"
"generator"
"growable"
"hashtables"
"f" "syntax" lookup register-builtin
"array" "arrays" create register-builtin
"wrapper" "kernel" create register-builtin
-"float-array" "float-arrays" create register-builtin
"callstack" "kernel" create register-builtin
"string" "strings" create register-builtin
-"bit-array" "bit-arrays" create register-builtin
"quotation" "quotations" create register-builtin
"dll" "alien" create register-builtin
"alien" "alien" create register-builtin
"alien" "alien" lookup ,
"f" "syntax" lookup ,
"byte-array" "byte-arrays" lookup ,
- "bit-array" "bit-arrays" lookup ,
- "float-array" "float-arrays" lookup ,
] { } make define-union-class
! A predicate class used for declarations
"byte-array" "byte-arrays" create { } define-builtin
-"bit-array" "bit-arrays" create { } define-builtin
-
-"float-array" "float-arrays" create { } define-builtin
-
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
{ "dlsym" "alien" }
{ "dlclose" "alien" }
{ "<byte-array>" "byte-arrays" }
- { "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien.accessors" }
{ "set-alien-signed-cell" "alien.accessors" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
- { "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
- { "resize-bit-array" "bit-arrays" }
- { "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
":"
";"
"<PRIVATE"
- "?{"
"BIN:"
"B{"
"BV{"
"CHAR:"
"DEFER:"
"ERROR:"
- "F{"
"FORGET:"
"GENERIC#"
"GENERIC:"
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
+
+TUPLE: boa-coercer-test { x array-capacity } ;
+
+[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions hashtables kernel
-kernel.private math namespaces sequences sequences.private
-strings vectors words quotations memory combinators generic
-classes classes.private slots.deprecated slots.private slots
+USING: arrays definitions hashtables kernel kernel.private math
+namespaces sequences sequences.private strings vectors words
+quotations memory combinators generic classes classes.algebra
+classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
\ unless ,
] [ ] make ;
+: (fixnum-check-quot) ( class -- quot )
+ (instance-check-quot) fixnum "coercer" word-prop prepend ;
+
: instance-check-quot ( class -- quot )
{
{ [ dup object bootstrap-word eq? ] [ drop [ ] ] }
{ [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
[ (instance-check-quot) ]
} cond ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
-byte-arrays bit-arrays float-arrays combinators words sets ;
+byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
sbufs vectors system layouts math.floats.private
classes classes.tuple classes.tuple.private sbufs.private
vectors.private strings.private slots.private combinators
-bit-arrays float-arrays compiler.constants ;
+compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
-words effects alien byte-arrays bit-arrays float-arrays
+words effects alien byte-arrays
accessors sets math.order ;
IN: generator.registers
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
- { [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
- { [ dup float-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays bit-arrays byte-arrays
-classes sequences.private continuations.private effects
-float-arrays generic hashtables hashtables.private
-inference.state inference.backend inference.dataflow io
-io.backend io.files io.files.private io.streams.c kernel
-kernel.private math math.private memory namespaces
-namespaces.private parser prettyprint quotations
+USING: accessors alien alien.accessors arrays byte-arrays
+classes sequences.private continuations.private effects generic
+hashtables hashtables.private inference.state inference.backend
+inference.dataflow io io.backend io.files io.files.private
+io.streams.c kernel kernel.private math math.private memory
+namespaces namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private classes.tuple classes.tuple.private vectors
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> make-flushable
-\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
-\ <bit-array> make-flushable
-
-\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
-\ <float-array> make-flushable
-
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
\ <displaced-alien> make-flushable
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
\ resize-byte-array make-flushable
-\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
-\ resize-bit-array make-flushable
-
-\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
-\ resize-float-array make-flushable
-
\ resize-string { integer string } { string } <effect> set-primitive-effect
\ resize-string make-flushable
math.intervals math.floats.private classes.tuple classes.predicate
classes.tuple.private classes classes.algebra optimizer.def-use
optimizer.backend optimizer.pattern-match optimizer.inlining
-float-arrays sequences.private combinators byte-arrays
-byte-vectors ;
+sequences.private combinators byte-arrays byte-vectors ;
{ <tuple> <tuple-boa> (tuple) } [
[
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors bit-arrays generic
+USING: accessors arrays byte-arrays byte-vectors generic
hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
-float-arrays combinators ;
+combinators ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
-M: bit-array pprint-delims drop \ ?{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
-M: float-array pprint-delims drop \ F{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
-USING: strings arrays byte-arrays bit-arrays help.markup
+USING: strings arrays byte-arrays help.markup
help.syntax kernel vectors ;
IN: sbufs
-USING: arrays bit-arrays help.markup help.syntax math
+USING: arrays help.markup help.syntax math
sequences.private vectors strings sbufs kernel math.order
layouts ;
IN: sequences
USING: arrays kernel math namespaces sequences kernel.private
-sequences.private strings sbufs tools.test vectors bit-arrays
+sequences.private strings sbufs tools.test vectors
generic vocabs.loader ;
IN: sequences.tests
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays bit-arrays byte-arrays float-arrays kernel
-kernel.private math namespaces sequences strings words effects
-generic generic.standard classes classes.algebra slots.private
-combinators accessors words sequences.private assocs alien ;
+USING: arrays byte-arrays kernel kernel.private math namespaces
+sequences strings words effects generic generic.standard classes
+classes.algebra slots.private combinators accessors words
+sequences.private assocs alien ;
IN: slots
TUPLE: slot-spec name offset class initial read-only reader writer ;
{ [ float bootstrap-word over class<= ] [ 0.0 ] }
{ [ string bootstrap-word over class<= ] [ "" ] }
{ [ array bootstrap-word over class<= ] [ { } ] }
- { [ bit-array bootstrap-word over class<= ] [ ?{ } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
- { [ float-array bootstrap-word over class<= ] [ F{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
[ no-initial-value ]
} cond nip ;
-USING: arrays byte-arrays bit-arrays help.markup help.syntax
+USING: arrays byte-arrays help.markup help.syntax
kernel kernel.private strings.private sequences vectors
sbufs math ;
IN: strings
{ $subsection POSTPONE: ] }
"Quotations are documented in " { $link "quotations" } "." ;
-ARTICLE: "syntax-bit-arrays" "Bit array syntax"
-{ $subsection POSTPONE: ?{ }
-"Bit arrays are documented in " { $link "bit-arrays" } "." ;
-
-ARTICLE: "syntax-float-arrays" "Float array syntax"
-{ $subsection POSTPONE: F{ }
-"Float arrays are documented in " { $link "float-arrays" } "." ;
-
ARTICLE: "syntax-byte-arrays" "Byte array syntax"
{ $subsection POSTPONE: B{ }
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
{ $subsection "syntax-quots" }
{ $subsection "syntax-arrays" }
{ $subsection "syntax-strings" }
-{ $subsection "syntax-bit-arrays" }
{ $subsection "syntax-byte-arrays" }
-{ $subsection "syntax-float-arrays" }
{ $subsection "syntax-vectors" }
{ $subsection "syntax-sbufs" }
{ $subsection "syntax-hashtables" }
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "B{ 1 2 3 }" } } ;
-HELP: ?{
-{ $syntax "?{ elements... }" }
-{ $values { "elements" "a list of booleans" } }
-{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "?{ t f t }" } } ;
-
-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: H{
{ $syntax "H{ { key value }... }" }
{ $values { "key" "an object" } { "value" "an object" } }
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays byte-vectors
+USING: alien arrays byte-arrays byte-vectors
definitions generic hashtables kernel math namespaces parser
lexer sequences strings strings.parser sbufs vectors
words quotations io assocs splitting classes.tuple
generic.standard generic.math generic.parser classes io.files
-vocabs float-arrays classes.parser classes.union
+vocabs classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
combinators debugger effects.parser slots ;
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
- "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
- "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
-USING: arrays byte-arrays bit-arrays help.markup
+USING: arrays byte-arrays help.markup
help.syntax kernel sbufs strings quotations sequences.private
vectors.private combinators ;
IN: vectors
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
sequences.private benchmark.reverse-complement hints io.encodings.ascii
-byte-arrays float-arrays ;
+byte-arrays ;
IN: benchmark.fasta
: IM 139968 ; inline
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
:: u/v ( n -- u v )
- n 1.0 <float-array> dup
+ n 1.0 <repetition> >float-array dup
10 [
drop
n eval-AtA-times-u
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: arrays help.markup help.syntax kernel
+kernel.private math prettyprint strings vectors sbufs ;
+IN: bit-arrays
+
+ARTICLE: "syntax-bit-arrays" "Bit array syntax"
+"Bit arrays are documented in " { $link "bit-arrays" } "." ;
+
+ARTICLE: "bit-arrays" "Bit arrays"
+"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name. The literal syntax is covered in " { $link "syntax-bit-arrays" } "."
+$nl
+"Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
+$nl
+"Bit 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
+"Bit arrays form a class of objects:"
+{ $subsection bit-array }
+{ $subsection bit-array? }
+"Creating new bit arrays:"
+{ $subsection >bit-array }
+{ $subsection <bit-array> }
+"Efficiently setting and clearing all bits in a bit array:"
+{ $subsection set-bits }
+{ $subsection clear-bits }
+"Converting between unsigned integers and their binary representation:"
+{ $subsection integer>bit-array }
+{ $subsection bit-array>integer }
+"Bit array literal syntax:"
+{ $subsection POSTPONE: ?{ } ;
+
+ABOUT: "bit-arrays"
+
+HELP: ?{
+{ $syntax "?{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
+{ $examples { $code "?{ t f t }" } } ;
+
+HELP: bit-array
+{ $description "The class of fixed-length bit arrays. See " { $link "syntax-bit-arrays" } " for syntax and " { $link "bit-arrays" } " for general information." } ;
+
+HELP: <bit-array> ( n -- bit-array )
+{ $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } }
+{ $description "Creates a new bit array with the given length and all elements initially set to " { $link f } "." } ;
+
+HELP: >bit-array
+{ $values { "seq" "a sequence" } { "bit-array" bit-array } }
+{ $description "Outputs a freshly-allocated bit array whose elements have the same boolean values as a given sequence." } ;
+
+HELP: clear-bits
+{ $values { "bit-array" bit-array } }
+{ $description "Sets all elements of the bit array to " { $link f } "." }
+{ $notes "Calling this word is more efficient than the following:"
+ { $code "[ drop f ] change-each" }
+}
+{ $side-effects "bit-array" } ;
+
+HELP: set-bits
+{ $values { "bit-array" bit-array } }
+{ $description "Sets all elements of the bit array to " { $link t } "." }
+{ $notes "Calling this word is more efficient than the following:"
+ { $code "[ drop t ] change-each" }
+}
+{ $side-effects "bit-array" } ;
+
+HELP: integer>bit-array
+{ $values { "integer" integer } { "bit-array" bit-array } }
+{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
+{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
+
+HELP: bit-array>integer
+{ $values { "bit-array" bit-array } { "integer" integer } }
+{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
+{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
--- /dev/null
+USING: sequences sequences.private arrays bit-arrays kernel
+tools.test math random ;
+IN: bit-arrays.tests
+
+[ 100 ] [ 100 <bit-array> length ] unit-test
+
+[
+ { t f t }
+] [
+ 3 <bit-array> t 0 pick set-nth t 2 pick set-nth
+ >array
+] unit-test
+
+[
+ { t f t }
+] [
+ { t f t } >bit-array >array
+] unit-test
+
+[
+ { t f t } { f t f }
+] [
+ { t f t } >bit-array dup clone dup [ not ] change-each
+ [ >array ] bi@
+] unit-test
+
+[
+ { f f f f f }
+] [
+ { t f t t f } >bit-array dup clear-bits >array
+] unit-test
+
+[
+ { t t t t t }
+] [
+ { t f t t f } >bit-array dup set-bits >array
+] unit-test
+
+[ t ] [
+ 100 [
+ drop 100 [ 2 random zero? ] replicate
+ dup >bit-array >array =
+ ] all?
+] unit-test
+
+[ ?{ f } ] [
+ 1 2 { t f t f } <slice> >bit-array
+] unit-test
+
+[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize ] unit-test
+
+[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize ] unit-test
+
+[ -10 ?{ } resize ] must-fail
+
+[ -1 integer>bit-array ] must-fail
+[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
+[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
+[ ?{
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+} ] [
+ HEX: ffffffffffffffffffffffffffffffff integer>bit-array
+] unit-test
+
+[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
+[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+} bit-array>integer ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types accessors math alien.accessors kernel
+kernel.private sequences sequences.private byte-arrays
+parser prettyprint.backend ;
+IN: bit-arrays
+
+TUPLE: bit-array
+{ length array-capacity read-only }
+{ underlying byte-array read-only } ;
+
+<PRIVATE
+
+: n>byte -3 shift ; inline
+
+: byte/bit ( n alien -- byte bit )
+ over n>byte alien-unsigned-1 swap 7 bitand ; inline
+
+: set-bit ( ? byte bit -- byte )
+ 2^ rot [ bitor ] [ bitnot bitand ] if ; inline
+
+: bits>cells 31 + -5 shift ; inline
+
+: bits>bytes 7 + n>byte ; inline
+
+: (set-bits) ( bit-array n -- )
+ [ [ length bits>cells ] keep ] dip
+ [ -rot underlying>> set-uint-nth ] 2curry
+ each ; inline
+
+PRIVATE>
+
+: <bit-array> ( n -- bit-array )
+ dup bits>bytes <byte-array> bit-array boa ; inline
+
+M: bit-array length length>> ;
+
+M: bit-array nth-unsafe
+ [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+
+M: bit-array set-nth-unsafe
+ [ >fixnum ] [ underlying>> ] bi*
+ [ byte/bit set-bit ] 2keep
+ swap n>byte set-alien-unsigned-1 ;
+
+: clear-bits ( bit-array -- ) 0 (set-bits) ;
+
+: set-bits ( bit-array -- ) -1 (set-bits) ;
+
+M: bit-array clone
+ [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+
+: >bit-array ( seq -- bit-array )
+ T{ bit-array f 0 B{ } } clone-like ; inline
+
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+
+M: bit-array new-sequence drop <bit-array> ;
+
+M: bit-array equal?
+ over bit-array? [ sequence= ] [ 2drop f ] if ;
+
+M: bit-array resize
+ [ drop ] [
+ [ bits>bytes ] [ underlying>> ] bi*
+ resize-byte-array
+ ] 2bi
+ bit-array boa ;
+
+M: bit-array byte-length length 7 + -3 shift ;
+
+: ?{ ( parsed -- parsed )
+ \ } [ >bit-array ] parse-literal ; parsing
+
+: integer>bit-array ( int -- bit-array )
+ [ log2 1+ <bit-array> 0 ] keep
+ [ dup zero? not ] [
+ [ -8 shift ] [ 255 bitand ] bi
+ -roll [ [ >r underlying>> r> set-alien-unsigned-1 ] 2keep 1+ ] dip
+ ] [ ] while
+ 2drop ;
+
+: bit-array>integer ( bit-array -- int )
+ 0 swap underlying>> [ length ] keep [
+ uchar-nth swap 8 shift bitor
+ ] curry each ;
+
+INSTANCE: bit-array sequence
+
+M: bit-array pprint-delims drop \ ?{ \ } ;
+
+M: bit-array >pprint-sequence ;
--- /dev/null
+Fixed-size bit arrays
--- /dev/null
+collections
IN: bit-vectors\r
\r
TUPLE: bit-vector\r
-{ underlying bit-array }\r
+{ underlying bit-array initial: ?{ } }\r
{ length array-capacity } ;\r
\r
: <bit-vector> ( n -- bit-vector )\r
--- /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. The literal syntax is covered in " { $link "syntax-float-arrays" } "."
+$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. See " { $link "syntax-float-arrays" } " for syntax and " { $link "float-arrays" } " for general information." } ;
+
+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 } ;
+
+<PRIVATE
+
+: floats>bytes 8 * ; inline
+
+: float-array@ underlying>> swap >fixnum floats>bytes ; inline
+
+PRIVATE>
+
+: <float-array> ( n -- float-array )
+ dup floats>bytes <byte-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
+ float-array@ alien-double ;
+
+M: float-array set-nth-unsafe
+ [ >float ] 2dip float-array@ set-alien-double ;
+
+: >float-array ( seq -- float-array )
+ T{ float-array f 0 B{ } } 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 ] [
+ [ floats>bytes ] [ 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 ; flushable
+
+: 2float-array ( x y -- array )
+ T{ float-array f 0 B{ } } 2sequence ; flushable
+
+: 3float-array ( x y z -- array )
+ T{ float-array f 0 B{ } } 3sequence ; flushable
+
+: 4float-array ( w x y z -- array )
+ T{ float-array f 0 B{ } } 4sequence ; flushable
+
+: F{ ( parsed -- parsed )
+ \ } [ >float-array ] parse-literal ; parsing
+
+M: float-array pprint-delims drop \ F{ \ } ;
+
+M: float-array >pprint-sequence ;
--- /dev/null
+Efficient fixed-length floating point number arrays
--- /dev/null
+collections
IN: float-vectors\r
\r
TUPLE: float-vector\r
-{ underlying float-array }\r
+{ underlying float-array initial: F{ } }\r
{ length array-capacity } ;\r
\r
: <float-vector> ( n -- float-vector )\r
- 0.0 <float-array> 0 float-vector boa ; inline\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
] unless ;\r
\r
M: float-vector new-sequence\r
- drop [ 0.0 <float-array> ] [ >fixnum ] bi float-vector boa ;\r
+ drop [ <float-array> ] [ >fixnum ] bi float-vector boa ;\r
\r
M: float-vector equal?\r
over float-vector? [ sequence= ] [ 2drop f ] if ;\r
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
- [ read-fdset/tasks [ init-fdset ] keep ]
- [ write-fdset/tasks [ init-fdset ] keep ] tri
+ [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
+ [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
f ;
M:: select-mx wait-for-events ( ms mx -- )
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions hints
-float-arrays math.order ;
+math.order ;
IN: math.vectors
: vneg ( u -- v ) [ neg ] map ;
: set-axis ( u v axis -- w )
dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ;
-HINTS: vneg { float-array } { array } ;
-HINTS: norm-sq { float-array } { array } ;
-HINTS: norm { float-array } { array } ;
-HINTS: normalize { float-array } { array } ;
-
-HINTS: n*v { object float-array } { object array } ;
-HINTS: v*n { float-array object } { array object } ;
-HINTS: n/v { object float-array } { array } ;
-HINTS: v/n { float-array object } { array object } ;
-
-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: vneg { array } ;
+HINTS: norm-sq { array } ;
+HINTS: norm { array } ;
+HINTS: normalize { array } ;
+
+HINTS: n*v { object array } ;
+HINTS: v*n { array object } ;
+HINTS: n/v { array } ;
+HINTS: v/n { array object } ;
+
+HINTS: v+ { array array } ;
+HINTS: v- { array array } ;
+HINTS: v* { array array } ;
+HINTS: v/ { array array } ;
+HINTS: vmax { array array } ;
+HINTS: vmin { array array } ;
+HINTS: v. { array array } ;
!
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays bit-arrays quotations hashtables assocs
-help.syntax help.markup float-arrays splitting
-io.streams.byte-array io.encodings.string io.encodings.utf8
-io.encodings.binary combinators accessors locals prettyprint
-compiler.units sequences.private classes.tuple.private ;
+vectors byte-arrays quotations hashtables assocs help.syntax
+help.markup splitting io.streams.byte-array io.encodings.string
+io.encodings.utf8 io.encodings.binary combinators accessors
+locals prettyprint compiler.units sequences.private
+classes.tuple.private ;
IN: serialize
! Variable holding a assoc of objects already serialized
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
-M: bit-array (serialize) ( obj -- )
- CHAR: b serialize-seq ;
-
M: byte-array (serialize) ( obj -- )
[
CHAR: A write1
[ write ] tri
] serialize-shared ;
-M: float-array (serialize) ( obj -- )
- [
- CHAR: f write1
- [ add-object ]
- [ length serialize-cell ]
- [ [ double>bits 8 >be write ] each ]
- tri
- ] serialize-shared ;
-
M: string (serialize) ( obj -- )
[
CHAR: s write1
switch(type_of(object))
{
case BYTE_ARRAY_TYPE:
- case BIT_ARRAY_TYPE:
- case FLOAT_ARRAY_TYPE:
byte_array = untag_object(object);
return byte_array + 1;
case ALIEN_TYPE:
switch(type_of(alien))
{
case BYTE_ARRAY_TYPE:
- case BIT_ARRAY_TYPE:
- case FLOAT_ARRAY_TYPE:
case ALIEN_TYPE:
case F_TYPE:
dpush(allot_alien(alien,displacement));
case BYTE_ARRAY_TYPE:
return byte_array_size(
byte_array_capacity((F_BYTE_ARRAY*)pointer));
- case BIT_ARRAY_TYPE:
- return bit_array_size(
- bit_array_capacity((F_BIT_ARRAY*)pointer));
- case FLOAT_ARRAY_TYPE:
- return float_array_size(
- float_array_capacity((F_FLOAT_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
case TUPLE_TYPE:
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
case BYTE_ARRAY_TYPE:
- case BIT_ARRAY_TYPE:
- case FLOAT_ARRAY_TYPE:
case BIGNUM_TYPE:
case CALLSTACK_TYPE:
return 0;
/*** Header types ***/
#define ARRAY_TYPE 8
#define WRAPPER_TYPE 9
-#define FLOAT_ARRAY_TYPE 10
+#define BYTE_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
-#define BIT_ARRAY_TYPE 13
+#define TUPLE_LAYOUT_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
#define WORD_TYPE 17
-#define BYTE_ARRAY_TYPE 18
-#define TUPLE_LAYOUT_TYPE 19
#define TYPE_COUNT 20
typedef F_ARRAY F_BYTE_ARRAY;
-typedef F_ARRAY F_BIT_ARRAY;
-
-typedef F_ARRAY F_FLOAT_ARRAY;
-
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
primitive_dlsym,
primitive_dlclose,
primitive_byte_array,
- primitive_bit_array,
primitive_displaced_alien,
primitive_alien_signed_cell,
primitive_set_alien_signed_cell,
primitive_profiling,
primitive_become,
primitive_sleep,
- primitive_float_array,
primitive_tuple_boa,
primitive_callstack_to_array,
primitive_innermost_stack_frame_quot,
primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
- primitive_resize_bit_array,
- primitive_resize_float_array,
primitive_dll_validp,
primitive_unimplemented,
primitive_gc_reset,
return result;
}
-/* Bit arrays */
-
-/* size is in bits */
-
-F_BIT_ARRAY *allot_bit_array_internal(CELL size)
-{
- F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size));
- array->capacity = tag_fixnum(size);
- return array;
-}
-
-F_BIT_ARRAY *allot_bit_array(CELL size)
-{
- F_BIT_ARRAY *array = allot_bit_array_internal(size);
- memset(array + 1,0,bit_array_size(size));
- return array;
-}
-
-/* push a new bit array on the stack */
-DEFINE_PRIMITIVE(bit_array)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_bit_array(size)));
-}
-
-F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity)
-{
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_BIT_ARRAY *new_array = allot_bit_array(capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,bit_array_size(to_copy));
-
- return new_array;
-}
-
-DEFINE_PRIMITIVE(resize_bit_array)
-{
- F_BYTE_ARRAY* array = untag_bit_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_bit_array(array,capacity)));
-}
-
-/* Float arrays */
-
-/* size is in 8-byte doubles */
-F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
-{
- F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
- float_array_size(size));
- array->capacity = tag_fixnum(size);
- return array;
-}
-
-F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
-{
- F_FLOAT_ARRAY *array = allot_float_array_internal(size);
-
- double *elements = (double *)AREF(array,0);
- int i;
- for(i = 0; i < size; i++)
- elements[i] = initial;
-
- return array;
-}
-
-/* push a new float array on the stack */
-DEFINE_PRIMITIVE(float_array)
-{
- double initial = untag_float(dpop());
- CELL size = unbox_array_size();
- dpush(tag_object(allot_float_array(size,initial)));
-}
-
-F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
-{
- F_FLOAT_ARRAY* new_array;
-
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- new_array = allot_float_array(capacity,0.0);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy * sizeof(double));
-
- return new_array;
-}
-
-DEFINE_PRIMITIVE(resize_float_array)
-{
- F_FLOAT_ARRAY* array = untag_float_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_float_array(array,capacity)));
-}
-
/* Tuple layouts */
DEFINE_PRIMITIVE(tuple_layout)
{
return sizeof(F_BYTE_ARRAY) + size;
}
-DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array)
-
-INLINE CELL bit_array_capacity(F_BIT_ARRAY *array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-INLINE CELL bit_array_size(CELL size)
-{
- return sizeof(F_BIT_ARRAY) + (size + 7) / 8;
-}
-
-DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array)
-
-INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-INLINE CELL float_array_size(CELL size)
-{
- return sizeof(F_FLOAT_ARRAY) + size * sizeof(double);
-}
-
INLINE CELL callstack_size(CELL size)
{
return sizeof(F_CALLSTACK) + size;
DECLARE_PRIMITIVE(tuple_boa);
DECLARE_PRIMITIVE(tuple_layout);
DECLARE_PRIMITIVE(byte_array);
-DECLARE_PRIMITIVE(bit_array);
-DECLARE_PRIMITIVE(float_array);
DECLARE_PRIMITIVE(clone);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(resize_byte_array);
-DECLARE_PRIMITIVE(resize_bit_array);
-DECLARE_PRIMITIVE(resize_float_array);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
projects / factor.git / commitdiff