+++ /dev/null
-USING: arrays bit-arrays help.markup help.syntax kernel\r
-bit-vectors.private combinators ;\r
-IN: bit-vectors\r
-\r
-ARTICLE: "bit-vectors" "Bit vectors"\r
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
-$nl\r
-"Bit vectors form a class:"\r
-{ $subsection bit-vector }\r
-{ $subsection bit-vector? }\r
-"Creating bit vectors:"\r
-{ $subsection >bit-vector }\r
-{ $subsection <bit-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
-{ $code "?V{ } clone" } ;\r
-\r
-ABOUT: "bit-vectors"\r
-\r
-HELP: bit-vector\r
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;\r
-\r
-HELP: <bit-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
-\r
-HELP: >bit-vector\r
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
-{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
-\r
-HELP: bit-array>vector\r
-{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;\r
+++ /dev/null
-IN: bit-vectors.tests\r
-USING: tools.test bit-vectors vectors sequences kernel math ;\r
-\r
-[ 0 ] [ 123 <bit-vector> length ] unit-test\r
-\r
-: do-it\r
- 1234 swap [ >r even? r> push ] curry each ;\r
-\r
-[ t ] [\r
- 3 <bit-vector> dup do-it\r
- 3 <vector> dup do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ ?V{ } bit-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 bit-arrays ;\r
-IN: bit-vectors\r
-\r
-<PRIVATE\r
-\r
-: bit-array>vector ( bit-array length -- bit-vector )\r
- bit-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <bit-vector> ( n -- bit-vector )\r
- <bit-array> 0 bit-array>vector ; inline\r
-\r
-: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;\r
-\r
-M: bit-vector like\r
- drop dup bit-vector? [\r
- dup bit-array?\r
- [ dup length bit-array>vector ] [ >bit-vector ] if\r
- ] unless ;\r
-\r
-M: bit-vector new-sequence\r
- drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
-\r
-M: bit-vector equal?\r
- over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: bit-array new-resizable drop <bit-vector> ;\r
-\r
-INSTANCE: bit-vector growable\r
+++ /dev/null
-Growable bit arrays
+++ /dev/null
-collections
"alien.accessors"
"arrays"
"bit-arrays"
- "bit-vectors"
"byte-arrays"
- "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
- "float-vectors"
"generator"
"growable"
"hashtables"
}
} define-tuple-class
-"byte-vector" "byte-vectors" create
-tuple
-{
- {
- { "byte-array" "byte-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"bit-vector" "bit-vectors" create
-tuple
-{
- {
- { "bit-array" "bit-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"float-vector" "float-vectors" create
-tuple
-{
- {
- { "float-array" "float-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
"curry" "kernel" create
tuple
{
";"
"<PRIVATE"
"?{"
- "?V{"
"BIN:"
"B{"
- "BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
- "FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel\r
-byte-vectors.private combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: byte-array>vector\r
-{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-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 byte-arrays ;\r
-IN: byte-vectors\r
-\r
-<PRIVATE\r
-\r
-: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- <byte-array> 0 byte-array>vector ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-array>vector ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-INSTANCE: byte-vector growable\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
-alien arrays memory ;
+alien arrays memory vocabs parser ;
IN: compiler.tests
! Test empty word
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
+
+! Regression
+10 [
+ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
+ [ t ] [
+ "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+ ] unit-test
+] times
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
- "nursery" f pick %load-dlsym ;
+ >r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
- 11 12 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
- 0 11 12 CMPI ! is here >= end?
+ 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+ 11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
-M: x86.32 %gc ( -- )
+M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
+++ /dev/null
-USING: arrays float-arrays help.markup help.syntax kernel\r
-float-vectors.private combinators ;\r
-IN: float-vectors\r
-\r
-ARTICLE: "float-vectors" "Float vectors"\r
-"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". 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
-"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 "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general 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: float-array>vector\r
-{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;\r
+++ /dev/null
-IN: float-vectors.tests\r
-USING: tools.test float-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <float-vector> length ] unit-test\r
-\r
-: do-it\r
- 12345 [ 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 ;\r
-IN: float-vectors\r
-\r
-<PRIVATE\r
-\r
-: float-array>vector ( float-array length -- float-vector )\r
- float-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <float-vector> ( n -- float-vector )\r
- 0.0 <float-array> 0 float-array>vector ; inline\r
-\r
-: >float-vector ( seq -- float-vector ) FV{ } clone-like ;\r
-\r
-M: float-vector like\r
- drop dup float-vector? [\r
- dup float-array?\r
- [ dup length float-array>vector ] [ >float-vector ] if\r
- ] unless ;\r
-\r
-M: float-vector new-sequence\r
- drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\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
+++ /dev/null
-Growable float arrays
+++ /dev/null
-collections
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
- f compiling-word get compiled get set-at ;
+ f compiling-label get compiled get set-at ;
-: finish-compiling ( literals relocation labels code -- )
+: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
- finish-compiling
+ save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
nested-labels get length 0 > [
dup param>> nested-labels get peek param>> eq? [
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
- classes= [
- drop
- ] [
+ classes= not [
fixed-point? off
[ in-d>> value-classes get extract-keys ] keep
set-node-classes
- ] if
- ] [ drop ] if
- ] [ drop ] if ;
+ ] [ drop ] if
+ ] [ call-next-method ] if
+ ] [ call-next-method ] if ;
M: object infer-classes-around
{
: infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
- [ node-classes ] [ node-literals ] [ node-intervals ] tri
+ [ classes>> ] [ literals>> ] [ intervals>> ] tri
infer-classes-with ;
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
-combinators classes optimizer.def-use ;
+combinators classes optimizer.def-use accessors ;
IN: optimizer.backend
SYMBOL: class-substitutions
GENERIC: optimize-node* ( node -- node/t changed? )
-: ?union ( assoc/f assoc -- hash )
- over [ assoc-union ] [ nip ] if ;
+: ?union ( assoc assoc/f -- assoc' )
+ dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
-: add-node-literals ( assoc node -- )
- over assoc-empty? [
- 2drop
- ] [
- [ node-literals ?union ] keep set-node-literals
- ] if ;
+: add-node-literals ( node assoc -- )
+ [ ?union ] curry change-literals drop ;
-: add-node-classes ( assoc node -- )
- over assoc-empty? [
- 2drop
- ] [
- [ node-classes ?union ] keep set-node-classes
- ] if ;
+: add-node-classes ( node assoc -- )
+ [ ?union ] curry change-classes drop ;
-: substitute-values ( assoc node -- )
- over assoc-empty? [
+: substitute-values ( node assoc -- )
+ dup assoc-empty? [
2drop
] [
- 2dup node-in-d swap substitute-here
- 2dup node-in-r swap substitute-here
- 2dup node-out-d swap substitute-here
- node-out-r swap substitute-here
+ {
+ [ >r in-d>> r> substitute-here ]
+ [ >r in-r>> r> substitute-here ]
+ [ >r out-d>> r> substitute-here ]
+ [ >r out-r>> r> substitute-here ]
+ } 2cleave
] if ;
: perform-substitutions ( node -- )
- class-substitutions get over add-node-classes
- literal-substitutions get over add-node-literals
- value-substitutions get swap substitute-values ;
+ [ class-substitutions get add-node-classes ]
+ [ literal-substitutions get add-node-literals ]
+ [ value-substitutions get substitute-values ]
+ tri ;
DEFER: optimize-nodes
#! Not very efficient.
dupd union* update ;
-: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
- node-out-d swap node-in-d 2array unify-lengths flip
+: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
+ [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
- dup node-successor dup [
- class-substitutions get pick node-classes update
- literal-substitutions get pick node-literals update
- tuck compute-value-substitutions value-substitutions get swap update*
- node-successor t
+ dup node-successor [
+ [ node-successor ] keep
+ {
+ [ nip classes>> class-substitutions get swap update ]
+ [ nip literals>> literal-substitutions get swap update ]
+ [ compute-value-substitutions value-substitutions get swap update* ]
+ [ drop node-successor ]
+ } 2cleave t
] [
- 2drop t f
+ drop t f
] if ;
! #return
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
-! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
generic-inline-test
generic-inline-test ;
+! Inlining all of the above should only take two passes
[ { t f } ] [
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors bit-arrays bit-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 classes.tuple.private classes float-arrays
-float-vectors ;
+USING: arrays byte-arrays bit-arrays 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
+classes.tuple.private classes float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
-M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
-M: float-vector pprint-delims drop \ FV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
-M: bit-vector >pprint-sequence ;
-M: byte-vector >pprint-sequence ;
-M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
-{ $subsection flip }
-"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
-{ $subsection column }
-{ $subsection <column> } ;
+{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ <slice> subseq } related-words
-HELP: column
-{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
-
-HELP: <column> ( seq n -- column )
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
-{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
-{ $examples
- { $example
- "USING: arrays prettyprint sequences ;"
- "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
- "{ 1 4 7 }"
- }
-}
-{ $notes
- "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
-} ;
-
HELP: repetition
{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
-! Columns
-{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
-
-[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
-[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
INSTANCE: slice virtual-sequence
-! A column of a matrix
-TUPLE: column seq col ;
-
-C: <column> column
-
-M: column virtual-seq column-seq ;
-M: column virtual@
- dup column-col -rot column-seq nth bounds-check ;
-M: column length column-seq length ;
-
-INSTANCE: column virtual-sequence
-
! One element repeated many times
TUPLE: repetition len elt ;
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
- [ <column> dup like ] with map
+ swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
{ $subsection POSTPONE: B{ }
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
-ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
-{ $subsection POSTPONE: ?V{ }
-"Bit vectors are documented in " { $link "bit-vectors" } "." ;
-
-ARTICLE: "syntax-float-vectors" "Float vector syntax"
-{ $subsection POSTPONE: FV{ }
-"Float vectors are documented in " { $link "float-vectors" } "." ;
-
-ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
-{ $subsection POSTPONE: BV{ }
-"Byte vectors are documented in " { $link "byte-vectors" } "." ;
-
ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
"Pathnames are documented in " { $link "pathnames" } "." ;
{ $subsection "syntax-float-arrays" }
{ $subsection "syntax-vectors" }
{ $subsection "syntax-sbufs" }
-{ $subsection "syntax-bit-vectors" }
-{ $subsection "syntax-byte-vectors" }
-{ $subsection "syntax-float-vectors" }
{ $subsection "syntax-hashtables" }
{ $subsection "syntax-tuples" }
{ $subsection "syntax-pathnames" } ;
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "B{ 1 2 3 }" } } ;
-HELP: BV{
-{ $syntax "BV{ elements... }" }
-{ $values { "elements" "a list of bytes" } }
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;
-
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: ?V{
-{ $syntax "?V{ elements... }" }
-{ $values { "elements" "a list of booleans" } }
-{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "?V{ t f t }" } } ;
-
-HELP: FV{
-{ $syntax "FV{ elements... }" }
-{ $values { "elements" "a list of real numbers" } }
-{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
-
HELP: F{
{ $syntax "F{ elements... }" }
{ $values { "elements" "a list of real numbers" } }
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays bit-vectors byte-arrays
-byte-vectors definitions generic hashtables kernel math
+USING: alien arrays bit-arrays byte-arrays
+definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
-generic.math classes io.files vocabs float-arrays float-vectors
+generic.math classes io.files vocabs float-arrays
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"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
- "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
- "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
-USING: namespaces math sequences splitting kernel ;
+USING: namespaces math sequences splitting kernel columns ;
IN: benchmark.dispatch2
: sequences
USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax ;
+assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
pick 0.0 [
swap >r >r 2dup r> (eval-A-times-u) r> +
] reduce nip
- ] F{ } map-as 2nip ; inline
+ ] F{ } map-as { float-array } declare 2nip ; inline
: (eval-At-times-u) ( u i j -- x )
tuck swap eval-A >r swap nth-unsafe r> * ; inline
pick 0.0 [
swap >r >r 2dup r> (eval-At-times-u) r> +
] reduce nip
- ] F{ } map-as 2nip ; inline
+ ] F{ } map-as { float-array } declare 2nip ; inline
: eval-AtA-times-u ( n u -- seq )
dupd eval-A-times-u eval-At-times-u ; inline
--- /dev/null
+USING: arrays bit-arrays help.markup help.syntax kernel\r
+bit-vectors.private combinators ;\r
+IN: bit-vectors\r
+\r
+ARTICLE: "bit-vectors" "Bit vectors"\r
+"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
+$nl\r
+"Bit vectors form a class:"\r
+{ $subsection bit-vector }\r
+{ $subsection bit-vector? }\r
+"Creating bit vectors:"\r
+{ $subsection >bit-vector }\r
+{ $subsection <bit-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: ?V{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
+{ $code "?V{ } clone" } ;\r
+\r
+ABOUT: "bit-vectors"\r
+\r
+HELP: bit-vector\r
+{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;\r
+\r
+HELP: <bit-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
+\r
+HELP: >bit-vector\r
+{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
+{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
+\r
+HELP: bit-array>vector\r
+{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;\r
+\r
+HELP: ?V{\r
+{ $syntax "?V{ elements... }" }\r
+{ $values { "elements" "a list of booleans" } }\r
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "?V{ t f t }" } } ;\r
+\r
--- /dev/null
+IN: bit-vectors.tests\r
+USING: tools.test bit-vectors vectors sequences kernel math ;\r
+\r
+[ 0 ] [ 123 <bit-vector> length ] unit-test\r
+\r
+: do-it\r
+ 1234 swap [ >r even? r> push ] curry each ;\r
+\r
+[ t ] [\r
+ 3 <bit-vector> dup do-it\r
+ 3 <vector> dup do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ ?V{ } bit-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 bit-arrays prettyprint.backend\r
+parser ;\r
+IN: bit-vectors\r
+\r
+TUPLE: bit-vector underlying fill ;\r
+\r
+M: bit-vector underlying underlying>> { bit-array } declare ;\r
+\r
+M: bit-vector set-underlying (>>underlying) ;\r
+\r
+M: bit-vector length fill>> { array-capacity } declare ;\r
+\r
+M: bit-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: bit-array>vector ( bit-array length -- bit-vector )\r
+ bit-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <bit-vector> ( n -- bit-vector )\r
+ <bit-array> 0 bit-array>vector ; inline\r
+\r
+: >bit-vector ( seq -- bit-vector )\r
+ T{ bit-vector f ?{ } 0 } clone-like ;\r
+\r
+M: bit-vector like\r
+ drop dup bit-vector? [\r
+ dup bit-array?\r
+ [ dup length bit-array>vector ] [ >bit-vector ] if\r
+ ] unless ;\r
+\r
+M: bit-vector new-sequence\r
+ drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
+\r
+M: bit-vector equal?\r
+ over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: bit-array new-resizable drop <bit-vector> ;\r
+\r
+INSTANCE: bit-vector growable\r
+\r
+: ?V \ } [ >bit-vector ] parse-literal ; parsing\r
+\r
+M: bit-vector >pprint-sequence ;\r
+\r
+M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
--- /dev/null
+Growable bit arrays
--- /dev/null
+collections
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel\r
+byte-vectors.private combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: byte-array>vector\r
+{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-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 byte-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector underlying fill ;\r
+\r
+M: byte-vector underlying underlying>> { byte-array } declare ;\r
+\r
+M: byte-vector set-underlying (>>underlying) ;\r
+\r
+M: byte-vector length fill>> { array-capacity } declare ;\r
+\r
+M: byte-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: byte-array>vector ( byte-array length -- byte-vector )\r
+ byte-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ <byte-array> 0 byte-array>vector ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-array>vector ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
+\r
+: BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
+\r
+M: byte-vector >pprint-sequence ;\r
+\r
+M: byte-vector pprint-delims drop \ BV{ \ } ;\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: columns
+
+ARTICLE: "columns" "Column sequences"
+"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
+{ $subsection column }
+{ $subsection <column> } ;
+
+HELP: column
+{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
+
+HELP: <column> ( seq n -- column )
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
+{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
+{ $examples
+ { $example
+ "USING: arrays prettyprint sequences ;"
+ "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
+ "{ 1 4 7 }"
+ }
+}
+{ $notes
+ "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
+} ;
+
+ABOUT: "columns"
--- /dev/null
+IN: columns.tests
+USING: columns sequences kernel namespaces arrays tools.test math ;
+
+! Columns
+{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
+
+[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
+[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
+[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel accessors ;
+IN: columns
+
+! A column of a matrix
+TUPLE: column seq col ;
+
+C: <column> column
+
+M: column virtual-seq seq>> ;
+M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
+M: column length seq>> length ;
+
+INSTANCE: column virtual-sequence
--- /dev/null
+Virtual sequence view of a matrix column
--- /dev/null
+collections
--- /dev/null
+USING: arrays float-arrays help.markup help.syntax kernel\r
+float-vectors.private combinators ;\r
+IN: float-vectors\r
+\r
+ARTICLE: "float-vectors" "Float vectors"\r
+"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". 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 "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general 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: float-array>vector\r
+{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
+{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;\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
+IN: float-vectors.tests\r
+USING: tools.test float-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <float-vector> length ] unit-test\r
+\r
+: do-it\r
+ 12345 [ 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 ;\r
+IN: float-vectors\r
+\r
+TUPLE: float-vector underlying fill ;\r
+\r
+M: float-vector underlying underlying>> { float-array } declare ;\r
+\r
+M: float-vector set-underlying (>>underlying) ;\r
+\r
+M: float-vector length fill>> { array-capacity } declare ;\r
+\r
+M: float-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: float-array>vector ( float-array length -- float-vector )\r
+ float-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <float-vector> ( n -- float-vector )\r
+ 0.0 <float-array> 0 float-array>vector ; 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-array>vector ] [ >float-vector ] if\r
+ ] unless ;\r
+\r
+M: float-vector new-sequence\r
+ drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\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
+\r
+M: float-vector pprint-delims drop \ FV{ \ } ;\r
--- /dev/null
+Growable float arrays
--- /dev/null
+collections
{ $subsection "vectors" }
"Resizable specialized sequences:"
{ $subsection "sbufs" }
-{ $subsection "bit-vectors" }
-{ $subsection "byte-vectors" }
-{ $subsection "float-vectors" }
+{ $vocab-subsection "Bit vectors" "bit-vectors" }
+{ $vocab-subsection "Byte vectors" "byte-vectors" }
+{ $vocab-subsection "Float vectors" "float-vectors" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
{ $subsection "namespaces" }
\ $error-description swap word-help elements empty? not ;
: sort-articles ( seq -- newseq )
- [ dup article-title ] { } map>assoc sort-values 0 <column> ;
+ [ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
all-words [ error? ] subset sort-articles ;
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting ;
+math.functions kernel splitting columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting ;
+USING: sequences math kernel splitting columns ;
IN: math.haar
: averages ( seq -- seq )
! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
USING: sequences namespaces kernel math math.parser io
-io.styles combinators ;
+io.styles combinators columns ;
IN: sudoku
SYMBOL: solutions
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.deploy.backend system vocabs.loader kernel ;
+USING: tools.deploy.backend system vocabs.loader kernel
+combinators ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
-os macosx? [ "tools.deploy.macosx" require ] when
-os winnt? [ "tools.deploy.windows" require ] when
-os unix? [ "tools.deploy.unix" require ] when
\ No newline at end of file
+{
+ { [ os macosx? ] [ "tools.deploy.macosx" ] }
+ { [ os winnt? ] [ "tools.deploy.windows" ] }
+ { [ os unix? ] [ "tools.deploy.unix" ] }
+} cond require
\ No newline at end of file
write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
- dup "Frameworks" copy-bundle-dir
- dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
- dup "Contents/Resources/" copy-fonts
- 2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ;
+ [
+ nip
+ [ "Frameworks" copy-bundle-dir ]
+ [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
+ [ "Contents/Resources/" copy-fonts ] tri
+ ]
+ [ create-app-plist ]
+ [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
: deploy.app-image ( vocab bundle-name -- str )
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
deploy-name get ".app" append ;
: show-in-finder ( path -- )
- NSWorkspace
- -> sharedWorkspace
- over <NSString> rot parent-directory <NSString>
+ [ NSWorkspace -> sharedWorkspace ]
+ [ normalize-path [ <NSString> ] [ parent-directory <NSString> ] bi ] bi*
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx deploy* ( vocab -- )
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
- bundle-name normalize-path show-in-finder
+ bundle-name show-in-finder
] bind
] with-directory ;
USING: io io.files io.backend kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint ;
-IN: tools.deploy.linux
-
-: create-app-dir ( vocab bundle-name -- vm )
- dup "" copy-fonts
- "" copy-vm ;
-
-: bundle-name ( -- str )
- deploy-name get ;
+IN: tools.deploy.unix
-M: linux deploy* ( vocab -- )
- "." resource-path [
- dup deploy-config [
- [ bundle-name create-app-dir ] keep
- [ bundle-name image-name ] keep
- namespace make-deploy-image
- bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
- ] bind
- ] with-directory ;
\ No newline at end of file
+: create-app-dir ( vocab bundle-name -- vm )
+ dup "" copy-fonts
+ "" copy-vm ;
+
+: bundle-name ( -- str )
+ deploy-name get ;
+
+M: unix deploy* ( vocab -- )
+ "." resource-path [
+ dup deploy-config [
+ [ bundle-name create-app-dir ] keep
+ [ bundle-name image-name ] keep
+ namespace make-deploy-image
+ bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+ ] bind
+ ] with-directory ;
\ No newline at end of file
IN: tools.deploy.windows
: copy-dlls ( bundle-name -- )
- { "freetype6.dll" "zlib1.dll" "factor.dll" }
- [ resource-path ] map
+ { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
- (normalize-path) open-in-explorer
+ open-in-explorer
] bind
] with-directory ;
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- default-flags swap assoc-union >r word-props r> update ;
+ [ word-props ] [ default-flags swap assoc-union ] bi* update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets ;
+io.streams.string math.vectors ui.gadgets columns ;
IN: ui.gadgets.grids
TUPLE: grid children gap fill? ;
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators sets ;
+calendar alarms symbols combinators sets columns ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
USING: alien alien.c-types alien.syntax combinators
kernel windows windows.user32 windows.ole32
-windows.com windows.com.syntax ;
+windows.com windows.com.syntax io.files ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
: ShellExecute ShellExecuteW ; inline
: open-in-explorer ( dir -- )
- f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
+ f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
ole32-error ; inline
projects / factor.git / commitdiff