steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2008-09-12 20:01:42 -07:00
parent f6ac828f46 20cc730501
commit 466024c632
54 changed files with 638 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms-docs.factor
View File

@ -23,7 +23,7 @@ HELP: every
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
ARTICLE: "alarms" "Alarms"
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsection alarm }
{ $subsection add-alarm }
{ $subsection later }

9
basis/alias/alias-docs.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words help.markup help.syntax ;
IN: alias
@ -14,4 +16,11 @@ HELP: ALIAS:
}
} ;
ARTICLE: "alias" "Alias"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }
"Make an alias at parse-time:"
{ $subsection POSTPONE: ALIAS: } ;
ABOUT: "alias"

2
basis/ascii/ascii-docs.factor
View File

@ -38,7 +38,7 @@ HELP: quotable?
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
ARTICLE: "ascii" "ASCII character classes"
"Traditional ASCII character classes:"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }

18
basis/base64/base64-docs.factor
View File

@ -1,20 +1,28 @@
USING: help.markup help.syntax kernel math ;
USING: help.markup help.syntax kernel math sequences ;
IN: base64
HELP: >base64
{ $values { "seq" "a sequence" } { "base64" "a string of base64 characters" } }
{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." }
{ $examples
{ $unchecked-example "\"The monorail is a free service.\" >base64 ." "VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==" }
{ $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
}
{ $see-also base64> } ;
HELP: base64>
{ $values { "base64" "a string of base64 characters" } { "str" "a string" } }
{ $values { "base64" "a string of base64 characters" } { "seq" sequence } }
{ $description "Converts a string in base64 encoding back into its binary representation." }
{ $examples
{ $unchecked-example "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> ." "\"The monorail is a free service.\"" }
{ $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
}
{ $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
{ $see-also >base64 } ;
ARTICLE: "base64" "Base 64 conversions"
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
"Converting to base 64:"
{ $subsection >base64 }
"Converting back to binary:"
{ $subsection base64> } ;
ABOUT: "base64"

2
basis/base64/base64.factor
View File

@ -43,7 +43,7 @@ PRIVATE>
[ [ "" ] [ >base64-rem ] if-empty ]
bi* append ;
: base64> ( base64 -- str )
: base64> ( base64 -- seq )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = ] count-end ]

22
basis/binary-search/binary-search-docs.factor
View File

@ -1,17 +1,6 @@
IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsection search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsection sorted-index }
{ $subsection sorted-member? }
{ $subsection sorted-memq? }
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
@ -41,3 +30,14 @@ HELP: sorted-memq?
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
{ memq? sorted-memq? } related-words
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsection search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsection sorted-index }
{ $subsection sorted-member? }
{ $subsection sorted-memq? }
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"

16
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -13,10 +13,8 @@ compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.checker ;
: cleaned-up-tree ( quot -- nodes )
build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
compiler.tree.checker
compiler.tree.debugger ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@ -34,12 +32,6 @@ compiler.tree.checker ;
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
@ -498,3 +490,7 @@ cell-bits 32 = [
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test

8
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes )
] [ body>> cleanup ] bi ;
! Removing overflow checks
: no-overflow-variant ( op -- fast-op )
H{
{ fixnum+ fixnum+fast }
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
} at ;
: (remove-overflow-check?) ( #call -- ? )
node-output-infos first class>> fixnum class<= ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -36,7 +36,7 @@ M: #branch remove-dead-code*
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ nths ] 2bi
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;

45
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,13 +1,21 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs fry match accessors namespaces make effects
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints
combinators io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.cleanup
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators ;
compiler.tree.combinators
compiler.tree.checker ;
RENAME: _ match => __
IN: compiler.tree.debugger
! A simple tool for turning tree IR into quotations and
@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ { { ?a ?b } { ?b } } [ nip ] }
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
{ _ f }
{ __ f }
} match-choose ;
TUPLE: shuffle-node { effect effect } ;
@ -146,3 +154,32 @@ SYMBOL: node-count
: optimizer-report. ( word -- )
make-report report. ;
! More utilities
: final-info ( quot -- seq )
build-tree
analyze-recursive
normalize
propagate
compute-def-use
dup check-nodes
peek node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
: final-literals ( quot -- seq )
final-info [ literal>> ] map ;
: cleaned-up-tree ( quot -- nodes )
[
check-optimizer? on
build-tree optimize-tree
] with-scope ;
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;

10
basis/compiler/tree/def-use/simplified/simplified-tests.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel tools.test compiler.tree compiler.tree.builder
compiler.tree.def-use compiler.tree.def-use.simplified accessors
sequences sorting classes ;
IN: compiler.tree.def-use.simplified
[ { #call #return } ] [
[ 1 dup reverse ] build-tree compute-def-use
first out-d>> first actually-used-by
[ node>> class ] map natural-sort
] unit-test

40
basis/compiler/tree/def-use/simplified/simplified.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences sequences.deep kernel
compiler.tree compiler.tree.def-use ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.
! A 'real' usage is a usage of a value that is not a #renaming.
TUPLE: real-usage value node ;
GENERIC: actually-used-by* ( value node -- real-usages )
! Def
GENERIC: actually-defined-by* ( value node -- real-usage )
: actually-defined-by ( value -- real-usage )
dup defined-by actually-defined-by* ;
M: #renaming actually-defined-by*
inputs/outputs swap [ index ] dip nth actually-defined-by ;
M: #return-recursive actually-defined-by* real-usage boa ;
M: node actually-defined-by* real-usage boa ;
! Use
: (actually-used-by) ( value -- real-usages )
dup used-by [ actually-used-by* ] with map ;
M: #renaming actually-used-by*
inputs/outputs [ indices ] dip nths
[ (actually-used-by) ] map ;
M: #return-recursive actually-used-by* real-usage boa ;
M: node actually-used-by* real-usage boa ;
: actually-used-by ( value -- real-usages )
(actually-used-by) flatten ;

31
basis/compiler/tree/finalization/finalization.factor
View File

@ -6,27 +6,20 @@ classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.combinators
compiler.tree.propagation.info
compiler.tree.cleanup
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.combinators ;
compiler.tree.late-optimizations ;
IN: compiler.tree.finalization
! This is a late-stage optimization.
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
! tail call optimization in the code generator. After this pass
! runs, stack flow information is no longer accurate, since we
! punt in 'splice-quot' and don't update everything that we
! should; this simplifies the code, improves performance, and we
! don't need the stack flow information after this pass anyway.
! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
@ -37,18 +30,6 @@ M: #shuffle finalize*
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
: splice-quot ( quot -- nodes )
[
build-tree
analyze-recursive
normalize
propagate
cleanup
compute-def-use
remove-dead-code
but-last
] with-scope ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;

29
basis/compiler/tree/late-optimizations/late-optimizations.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.cleanup
compiler.tree.def-use
compiler.tree.dead-code ;
IN: compiler.tree.late-optimizations
! Late optimizations modify the tree such that stack flow
! information is no longer accurate, since we punt in
! 'splice-quot' and don't update everything that we should;
! this simplifies the code, improves performance, and we
! don't need the stack flow information after this pass anyway.
: splice-quot ( quot -- nodes )
[
build-tree
analyze-recursive
normalize
propagate
cleanup
compute-def-use
remove-dead-code
but-last
] with-scope ;

130
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor Normal file
View File

@ -0,0 +1,130 @@
IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[ { declared-fixnum } declare [ 1 + ] change-x ]
{ + fixnum+ >fixnum } inlined?
] unit-test
[ t ] [
[ { declared-fixnum } declare x>> drop ]
{ slot } inlined?
] unit-test
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ { integer } declare 127 bitand 3 + ]
{ + +-integer-fixnum bitand } inlined?
] unit-test
[ f ] [
[ { integer } declare 127 bitand 3 + ]
{ >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare
dup 0 >= [
615949 * 797807 + 20 2^ mod dup 19 2^ -
] [ dup ] if
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare
615949 * 797807 + 20 2^ mod dup 19 2^ -
] { >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare 256 rem
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test

108
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.partial-dispatch namespaces sequences sets
accessors assocs words kernel memoize fry combinators
compiler.tree
compiler.tree.combinators
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
IN: compiler.tree.modular-arithmetic
! This is a late-stage optimization.
! See the comment in compiler.tree.late-optimizations.
! Modular arithmetic optimization pass.
!
! { integer integer } declare + >fixnum
! ==>
! [ >fixnum ] bi@ fixnum+fast
{ + - * bitand bitor bitxor } [
[
t "modular-arithmetic" set-word-prop
] each-integer-derived-op
] each
{ bitand bitor bitxor bitnot }
[ t "modular-arithmetic" set-word-prop ] each
SYMBOL: modularize-values
: modular-value? ( value -- ? )
modularize-values get key? ;
: modularize-value ( value -- ) modularize-values get conjoin ;
GENERIC: maybe-modularize* ( value node -- )
: maybe-modularize ( value -- )
actually-defined-by [ value>> ] [ node>> ] bi
over actually-used-by length 1 = [
maybe-modularize*
] [ 2drop ] if ;
M: #call maybe-modularize*
dup word>> "modular-arithmetic" word-prop [
[ modularize-value ]
[ in-d>> [ maybe-modularize ] each ] bi*
] [ 2drop ] if ;
M: node maybe-modularize* 2drop ;
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
dup word>> {
{ [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
! { [
! {
! mod-integer-fixnum
! mod-integer-integer
! mod-fixnum-integer
! } memq?
! ] [ ] }
[ drop ]
} cond ;
M: node compute-modularized-values* drop ;
: compute-modularized-values ( nodes -- )
[ compute-modularized-values* ] each-node ;
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
: redundant->fixnum? ( #call -- ? )
in-d>> first actually-defined-by value>> modular-value? ;
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
MEMO: fixnum-coercion ( flags -- nodes )
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
: optimize-modular-op ( #call -- nodes )
dup out-d>> first modular-value? [
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
[
[
[ actually-defined-by value>> modular-value? ]
[ fixnum eq? ]
bi* or
] 2map fixnum-coercion
] [ [ modular-variant ] change-word ] bi* suffix
] when ;
M: #call optimize-modular-arithmetic*
dup word>> {
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
[ drop ]
} cond ;
M: node optimize-modular-arithmetic* ;
: optimize-modular-arithmetic ( nodes -- nodes' )
H{ } clone modularize-values set
dup compute-modularized-values
[ optimize-modular-arithmetic* ] map-nodes ;

5
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -10,7 +10,7 @@ compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@ -27,9 +27,10 @@ SYMBOL: check-optimizer?
apply-identities
compute-def-use
remove-dead-code
! strength-reduce
check-optimizer? get [
compute-def-use
dup check-nodes
] when
compute-def-use
optimize-modular-arithmetic
finalize ;

13
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces
words namespaces continuations
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@ -33,7 +33,7 @@ M: quotation splicing-nodes
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call class/f word/f -- ? )
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
@ -156,12 +156,19 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
: inline-custom ( #call word -- ? )
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
first object swap eliminate-dispatch ;
: do-inlining ( #call word -- ? )
{
{ [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;

26
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -230,6 +230,32 @@ generic-comparison-ops [
] "outputs" set-word-prop
] assoc-each
{
mod-integer-integer
mod-integer-fixnum
mod-fixnum-integer
fixnum-mod
rem
} [
[
in-d>> second value-info >literal<
[ power-of-2? [ 1- bitand ] f ? ] when
] "custom-inlining" set-word-prop
] each
{
bitand-integer-integer
bitand-integer-fixnum
bitand-fixnum-integer
} [
[
in-d>> second value-info >literal< [
0 most-positive-fixnum between?
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
] when
] "custom-inlining" set-word-prop
] each
{
alien-signed-1
alien-unsigned-1

27
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -6,27 +6,12 @@ alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.checker slots.private words hashtables
classes assocs ;
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
: final-info ( quot -- seq )
build-tree
analyze-recursive
normalize
propagate
compute-def-use
dup check-nodes
peek node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
: final-literals ( quot -- seq )
final-info [ literal>> ] map ;
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
@ -594,6 +579,14 @@ MIXIN: empty-mixin
[ { float } declare 0 eq? ] final-classes
] unit-test
[ V{ integer } ] [
[ { integer fixnum } declare mod ] final-classes
] unit-test
[ V{ integer } ] [
[ { fixnum integer } declare bitand ] final-classes
] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test

119
basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
View File

@ -1,119 +0,0 @@
! TUPLE: declared-fixnum { x fixnum } ;
!
! [ t ] [
! [ { declared-fixnum } declare [ 1 + ] change-x ]
! { + fixnum+ >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { declared-fixnum } declare x>> drop ]
! { slot } inlined?
! ] unit-test
!
! [ t ] [
! [ hashtable new ] \ new inlined?
! ] unit-test
!
! [ t ] [
! [ dup hashtable eq? [ new ] when ] \ new inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare -63 shift 4095 bitand ]
! \ shift inlined?
! ] unit-test
!
! [ t ] [
! [ { integer } declare 127 bitand 3 + ]
! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare 127 bitand 3 + ]
! { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare
! dup 0 >= [
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] [ dup ] if
! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
! ] unit-test
!
!
!
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
!
! [ f ] [
! [
! 256 mod
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ f ] [
! [
! dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 256 rem
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 256 rem ] map
! ] { mod fixnum-mod rem } inlined?
! ] unit-test

5
basis/compiler/tree/strength-reduction/strength-reduction.factor
View File

@ -1,5 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.strength-reduction
: strength-reduce ( nodes -- nodes' ) ;

2
basis/editors/editpadpro/editpadpro.factor
View File

@ -1,6 +1,6 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
io.paths strings unicode.case ;
io.paths strings unicode.case make ;
IN: editors.editpadpro
: editpadpro-path

2
basis/editors/editplus/editplus.factor
View File

@ -1,5 +1,5 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
namespaces sequences windows.shell32 make ;
IN: editors.editplus
: editplus-path ( -- path )

2
basis/editors/emacs/emacs.factor
View File

@ -1,5 +1,5 @@
USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors ;
math.parser namespaces editors make ;
IN: editors.emacs
: emacsclient ( file line -- )

3
basis/editors/emeditor/emeditor.factor
View File

@ -1,5 +1,6 @@
USING: editors hardware-info.windows io.files io.launcher
kernel math.parser namespaces sequences windows.shell32 ;
kernel math.parser namespaces sequences windows.shell32
make ;
IN: editors.emeditor
: emeditor-path ( -- path )

2
basis/editors/gvim/gvim.factor
View File

@ -1,6 +1,6 @@
USING: io.backend io.files kernel math math.parser
namespaces sequences system combinators
editors.vim vocabs.loader ;
editors.vim vocabs.loader make ;
IN: editors.gvim
SINGLETON: gvim

2
basis/editors/notepadpp/notepadpp.factor
View File

@ -1,5 +1,5 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
namespaces sequences windows.shell32 make ;
IN: editors.notepadpp
: notepadpp-path

2
basis/editors/scite/scite.factor
View File

@ -9,7 +9,7 @@
! if not on the path.
!
USING: io.files io.launcher kernel namespaces math
math.parser editors sequences windows.shell32 ;
math.parser editors sequences windows.shell32 make ;
IN: editors.scite
: scite-path ( -- path )

2
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -1,5 +1,5 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
namespaces sequences windows.shell32 make ;
IN: editors.ted-notepad
: ted-notepad-path

2
basis/editors/textmate/textmate.factor
View File

@ -1,5 +1,5 @@
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors ;
namespaces prettyprint editors make ;
IN: editors.textmate

2
basis/editors/textwrangler/textwrangler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Ben Schlingelhof.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io.launcher kernel parser words sequences
math math.parser namespaces editors ;
math math.parser namespaces editors make ;
IN: editors.textwrangler
: tw ( file line -- )

2
basis/editors/ultraedit/ultraedit.factor
View File

@ -1,5 +1,5 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
namespaces sequences windows.shell32 wne ;
IN: editors.ultraedit
: ultraedit-path ( -- path )

3
basis/editors/vim/vim.factor
View File

@ -1,5 +1,6 @@
USING: definitions io io.launcher kernel math math.parser
namespaces parser prettyprint sequences editors accessors ;
namespaces parser prettyprint sequences editors accessors
make ;
IN: editors.vim
SYMBOL: vim-path

17
basis/math/partial-dispatch/partial-dispatch-tests.factor
View File

@ -1,5 +1,6 @@
IN: math.partial-dispatch.tests
USING: math.partial-dispatch tools.test math kernel sequences ;
USING: math.partial-dispatch math.private
tools.test math kernel sequences ;
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
@ -10,3 +11,17 @@ USING: math.partial-dispatch tools.test math kernel sequences ;
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
[ { fixnum fixnum } ] [ \ fixnum+fast integer-op-input-classes ] unit-test
[ { integer } ] [ \ bitnot integer-op-input-classes ] unit-test
[ shift ] [ \ fixnum-shift generic-variant ] unit-test
[ fixnum-shift-fast ] [ \ fixnum-shift no-overflow-variant ] unit-test
[ fixnum-shift-fast ] [ \ shift modular-variant ] unit-test
[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test
[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test

54
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -6,13 +6,41 @@ generic generic.math hashtables effects compiler.units
classes.algebra ;
IN: math.partial-dispatch
! Partial dispatch.
! This code will be overhauled and generalized when
! multi-methods go into the core.
PREDICATE: math-partial < word
"derived-from" word-prop >boolean ;
GENERIC: integer-op-input-classes ( word -- classes )
M: math-partial integer-op-input-classes
"derived-from" word-prop rest ;
M: word integer-op-input-classes
"input-classes" word-prop
[ "Bug: integer-op-input-classes" throw ] unless* ;
: generic-variant ( op -- generic-op/f )
dup "derived-from" word-prop [ first ] [ ] ?if ;
: no-overflow-variant ( op -- fast-op )
H{
{ fixnum+ fixnum+fast }
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
} at ;
: modular-variant ( op -- fast-op )
generic-variant dup H{
{ + fixnum+fast }
{ - fixnum-fast }
{ * fixnum*fast }
{ shift fixnum-shift-fast }
{ bitand fixnum-bitand }
{ bitor fixnum-bitor }
{ bitxor fixnum-bitxor }
{ bitnot fixnum-bitnot }
} at swap or ;
:: fixnum-integer-op ( a b fix-word big-word -- c )
b tag 0 eq? [
a b fix-word execute
@ -69,10 +97,17 @@ PREDICATE: math-partial < word
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
>r >r integer-op-triples r> r>
[ define-integer-op-words ]
[ 2drop [ dup integer-op-word ] { } map>assoc % ]
3bi ;
[
rot tuck
[ fixnum fixnum 3array "derived-from" set-word-prop ]
[ bignum bignum 3array "derived-from" set-word-prop ]
2bi*
] [
[ integer-op-triples ] 2dip
[ define-integer-op-words ]
[ 2drop [ dup integer-op-word ] { } map>assoc % ]
3bi
] 3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
@ -125,6 +160,9 @@ SYMBOL: fast-math-ops
: each-fast-derived-op ( word quot -- )
>r fast-derived-ops r> each ; inline
: each-integer-derived-op ( word quot -- )
>r integer-derived-ops r> each ; inline
[
[
\ + define-math-ops

4
basis/math/vectors/vectors-tests.factor
View File

@ -5,3 +5,7 @@ USING: math.vectors tools.test ;
[ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
[ { 1 2 3 } ] [ { 2 4 6 } 2 v/n ] unit-test
[ { 1/1 1/2 1/3 } ] [ 1 { 1 2 3 } n/v ] unit-test
[ 5 ] [ { 1 2 } norm-sq ] unit-test
[ 13 ] [ { 2 3 } norm-sq ] unit-test

6
basis/math/vectors/vectors.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions hints
math.order ;
@ -19,8 +19,8 @@ IN: math.vectors
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
: v. ( u v -- x ) 0 [ * + ] 2reduce ;
: norm-sq ( v -- x ) 0 [ absq + ] reduce ;
: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
: norm ( v -- x ) norm-sq sqrt ;
: normalize ( u -- v ) dup norm v/n ;

35
basis/mime-types/mime-types-docs.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences ;
IN: mime-types
HELP: mime-db
{ $values
{ "seq" sequence } }
{ $description "Outputs an array where the first element is a MIME type and the rest of the array is file extensions that have that MIME type." } ;
HELP: mime-type
{ $values
{ "path" "a pathname string" }
{ "mime-type" "a MIME type string" } }
{ $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ;
HELP: mime-types
{ $values
{ "assoc" assoc } }
{ $description "Outputs an " { $snippet "assoc" } " made from the data in the " { $link mime-db } " word where the keys are file extensions and the values are the corresponding MIME types." } ;
HELP: nonstandard-mime-types
{ $values
{ "assoc" assoc } }
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
ARTICLE: "mime-types" "MIME types"
"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
"Looking up a MIME type:"
{ $subsection mime-type } ;
ABOUT: "mime-types"

11
basis/smtp/smtp-docs.factor
View File

@ -4,12 +4,18 @@ USING: accessors kernel quotations help.syntax help.markup
io.sockets strings calendar ;
IN: smtp
HELP: smtp-domain
{ $description "The name of the machine that is sending the email. This variable will be filled in by the " { $link host-name } " word if not set by the user." } ;
HELP: smtp-server
{ $description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
HELP: smtp-read-timeout
{ $description "Holds an " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
HELP: esmtp?
{ $description "Set true by default, determines whether the SMTP client is using the Extended SMTP protocol." } ;
HELP: with-smtp-connection
{ $values { "quot" quotation } }
{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } ;
@ -36,5 +42,10 @@ HELP: send-email
} ;
ARTICLE: "smtp" "SMTP Client Library"
"Configuring SMTP:"
{ $subsection smtp-server }
{ $subsection smtp-read-timeout }
{ $subsection smtp-domain }
{ $subsection esmtp? }
"Sending an email:"
{ $subsection send-email } ;

4
basis/smtp/smtp.factor
View File

@ -10,7 +10,7 @@ IN: smtp
SYMBOL: smtp-domain
SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global
SYMBOL: esmtp t esmtp set-global
SYMBOL: esmtp? t esmtp? set-global
LOG: log-smtp-connection NOTICE ( addrspec -- )
@ -39,7 +39,7 @@ TUPLE: email
: command ( string -- ) write crlf flush ;
: helo ( -- )
esmtp get "EHLO " "HELO " ? host-name append command ;
esmtp? get "EHLO " "HELO " ? host-name append command ;
ERROR: bad-email-address email ;

2
basis/sorting/human/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Doug Coleman
Slava Pestov

6
basis/sorting/human/human-tests.factor Normal file
View File

@ -0,0 +1,6 @@
USING: sorting.human tools.test ;
IN: sorting.human.tests
\ human-sort must-infer
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test

10
basis/sorting/human/human.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: peg.ebnf math.parser kernel assocs sorting ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
: human-sort ( seq -- seq' )
[ dup find-numbers ] { } map>assoc sort-values keys ;

1
basis/sorting/human/summary.txt Normal file
View File

@ -0,0 +1 @@
Correct sorting of sequences of strings with embedded numbers

2
basis/sorting/human/tags.txt Normal file
View File

@ -0,0 +1,2 @@
collections
text

2
core/kernel/kernel-docs.factor
View File

@ -550,7 +550,7 @@ HELP: 2bi
HELP: 3bi
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
{ $code

12
core/sequences/sequences-tests.factor
View File

@ -250,11 +250,11 @@ unit-test
[ 50 ] [ 100 [ even? ] count ] unit-test
[ 50 ] [ 100 [ odd? ] count ] unit-test
[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } nths ] unit-test
[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } nths ] unit-test
[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } nths ] unit-test
[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } nths ] unit-test
[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test
[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test
[ { "d" "c" "b" "a" } ] [ { 3 2 1 0 } { "a" "b" "c" "d" } nths ] unit-test
[ { "d" "a" "b" "c" } ] [ { 3 0 1 2 } { "a" "b" "c" "d" } nths ] unit-test
TUPLE: bogus-hashcode ;
M: bogus-hashcode hashcode* 2drop 0 >bignum ;
@ -266,3 +266,5 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test
[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test

22
core/sequences/sequences.factor
View File

@ -51,7 +51,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
: push ( elt seq -- ) [ length ] [ set-nth ] bi ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
dupd length < [ 0 >= ] [ drop f ] if ; inline
ERROR: bounds-error index seq ;
@ -480,8 +480,13 @@ PRIVATE>
: last-index-from ( obj i seq -- n )
rot [ = ] curry find-last-from drop ;
: nths ( seq indices -- seq' )
swap [ nth ] curry map ;
: indices ( obj seq -- indices )
V{ } clone spin
[ rot = [ over push ] [ drop ] if ]
curry each-index ;
: nths ( indices seq -- seq' )
[ nth ] curry map ;
: contains? ( seq quot -- ? )
find drop >boolean ; inline
@ -747,6 +752,17 @@ PRIVATE>
: unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ; inline
: 2unclip-slice ( seq1 seq2 -- seq1' seq2' elt1 elt2 )
[ unclip-slice ] bi@ swapd ; inline
: map-reduce ( seq map-quot reduce-quot -- result )
[ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline
: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
: unclip-last-slice ( seq -- butlast last )
[ but-last-slice ] [ peek ] bi ; inline

2
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -41,7 +41,7 @@ IN: benchmark.spectral-norm
] times ; inline
: spectral-norm ( n -- norm )
u/v [ v. ] keep norm-sq /f sqrt ;
u/v [ v. ] [ norm-sq ] bi /f sqrt ;
HINTS: spectral-norm fixnum ;

2
extra/math/combinatorics/combinatorics.factor
View File

@ -39,7 +39,7 @@ PRIVATE>
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
tuck permutation-indices nths ;
tuck permutation-indices swap nths ;
: all-permutations ( seq -- seq )
[

2
extra/project-euler/186/186.factor
View File

@ -9,7 +9,7 @@ IN: project-euler.186
55 [1,b] [ (generator) ] map <circular> ;
: advance ( lag -- )
[ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
[ { 0 31 } swap nths sum 1000000 rem ] keep push-circular ;
: next ( lag -- n )
[ first ] [ advance ] bi ;

3
extra/sequences/lib/lib-tests.factor
View File

@ -10,9 +10,6 @@ IN: sequences.lib.tests
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test

28
extra/sequences/lib/lib.factor
View File

@ -31,9 +31,6 @@ IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: map-reduce ( seq map-quot reduce-quot -- result )
>r [ unclip ] dip [ call ] keep r> compose reduce ; inline
: reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -134,23 +131,6 @@ PRIVATE>
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
: cut-find ( seq pred -- before after )
dupd find drop dup [ cut ] when ;
: cut3 ( seq pred -- first mid last )
[ cut-find ] keep [ not ] compose cut-find ;
: (cut-all) ( seq pred quot -- )
[ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep
pick [ (cut-all) ] [ 3drop ] if ;
: cut-all ( seq pred quot -- first mid last )
[ (cut-all) ] { } make ;
: human-sort ( seq -- newseq )
[ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
sort-values keys ;
: ?first ( seq -- first/f ) 0 swap ?nth ; inline
: ?second ( seq -- second/f ) 1 swap ?nth ; inline
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
@ -167,14 +147,6 @@ USE: continuations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
: indices ( seq obj -- seq )
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
sift ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )
[