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

core changes: 

index* -> index-from
last-index* -> last-index-from
1 tail -> rest
1 tail-slice -> rest-slice
subset -> filter
prepose
find* -> find-from
find-last* -> find-last-from
before, after generic, < for integers
make between? work for timestamps
db4
Doug Coleman 2008-04-25 23:12:44 -05:00
parent 44e48c72a8
commit 15402ed1b4
72 changed files with 205 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/syntax/syntax.factor
View File

@ -40,7 +40,7 @@ PRIVATE>
: FUNCTION: : FUNCTION:
scan "c-library" get scan ";" parse-tokens scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] subset [ "()" subseq? not ] filter
define-function ; parsing define-function ; parsing
: TYPEDEF: : TYPEDEF:

4
core/assocs/assocs-docs.factor
View File

@ -96,7 +96,7 @@ $nl
{ $subsection assoc-each } { $subsection assoc-each }
{ $subsection assoc-map } { $subsection assoc-map }
{ $subsection assoc-push-if } { $subsection assoc-push-if }
{ $subsection assoc-subset } { $subsection assoc-filter }
{ $subsection assoc-contains? } { $subsection assoc-contains? }
{ $subsection assoc-all? } { $subsection assoc-all? }
"Three additional combinators:" "Three additional combinators:"
@ -203,7 +203,7 @@ HELP: assoc-push-if
{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } } { $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ; { $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-subset HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;

4
core/assocs/assocs-tests.factor
View File

@ -30,10 +30,10 @@ continuations ;
[ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test [ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test [ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test [ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [ [ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop 3 >= ] assoc-subset [ drop 3 >= ] assoc-filter
] unit-test ] unit-test
[ 21 ] [ [ 21 ] [

8
core/assocs/assocs.factor
View File

@ -50,7 +50,7 @@ M: assoc assoc-find
: assoc-pusher ( quot -- quot' accum ) : assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
: assoc-subset ( assoc quot -- subassoc ) : assoc-filter ( assoc quot -- subassoc )
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
: assoc-contains? ( assoc quot -- ? ) : assoc-contains? ( assoc quot -- ? )
@ -110,7 +110,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
] { } assoc>map hashcode* ; ] { } assoc>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection ) : assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ; swap [ nip key? ] curry assoc-filter ;
: update ( assoc1 assoc2 -- ) : update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ; swap [ swapd set-at ] curry assoc-each ;
@ -120,10 +120,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ rot update ] keep [ swap update ] keep ; [ rot update ] keep [ swap update ] keep ;
: assoc-diff ( assoc1 assoc2 -- diff ) : assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ; swap [ nip key? not ] curry assoc-filter ;
: remove-all ( assoc seq -- subseq ) : remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ; swap [ key? not ] curry filter ;
: (substitute) : (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline [ dupd at* [ nip ] [ drop ] if ] curry ; inline

4
core/bootstrap/compiler/compiler.factor
View File

@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors classes.tuple sbufs inference.dataflow arrays hashtables vectors classes.tuple sbufs inference.dataflow
hashtables.private sequences.private math classes.tuple.private hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ; vocabs io prettyprint libc compiler.units math.order ;
IN: bootstrap.compiler IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a ! Don't bring this in when deploying, since it will store a
@ -74,6 +74,6 @@ nl
malloc calloc free memcpy malloc calloc free memcpy
} compile } compile
vocabs [ words [ compiled? not ] subset compile "." write flush ] each vocabs [ words [ compiled? not ] filter compile "." write flush ] each
" done" print flush " done" print flush

2
core/bootstrap/image/image.factor
View File

@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators quotations.private sequences.private combinators
io.encodings.binary ; io.encodings.binary math.order ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : my-arch ( -- arch )

2
core/bootstrap/primitives.factor
View File

@ -157,7 +157,7 @@ num-types get f <array> builtins set
! Catch-all class for providing a default method. ! Catch-all class for providing a default method.
"object" "kernel" create "object" "kernel" create
[ f builtins get [ ] subset union-class define-class ] [ f builtins get [ ] filter union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ] [ [ drop t ] "predicate" set-word-prop ]
bi bi

4
core/bootstrap/stage2.factor
View File

@ -23,12 +23,12 @@ SYMBOL: bootstrap-time
: load-components ( -- ) : load-components ( -- )
"exclude" "include" "exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@ [ get-global " " split [ empty? not ] filter ] bi@
diff diff
[ "bootstrap." prepend require ] each ; [ "bootstrap." prepend require ] each ;
: count-words ( pred -- ) : count-words ( pred -- )
all-words swap subset length number>string write ; all-words swap filter length number>string write ;
: print-report ( time -- ) : print-report ( time -- )
1000 /i 1000 /i

4
core/classes/algebra/algebra.factor
View File

@ -183,7 +183,7 @@ C: <anonymous-complement> anonymous-complement
: largest-class ( seq -- n elt ) : largest-class ( seq -- n elt )
dup [ dup [
[ 2dup class< >r swap class< not r> and ] [ 2dup class< >r swap class< not r> and ]
with subset empty? with filter empty?
] curry find [ "Topological sort failed" throw ] unless* ; ] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq ) : sort-classes ( seq -- newseq )
@ -193,7 +193,7 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ; [ ] unfold nip ;
: min-class ( class seq -- class/f ) : min-class ( class seq -- class/f )
over [ classes-intersect? ] curry subset over [ classes-intersect? ] curry filter
dup empty? [ 2drop f ] [ dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ; ] if ;

2
core/classes/classes.factor
View File

@ -33,7 +33,7 @@ PREDICATE: class < word
PREDICATE: tuple-class < class PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ; "metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ; : classes ( -- seq ) all-words [ class? ] filter ;
: predicate-word ( word -- predicate ) : predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ; [ word-name "?" append ] keep word-vocabulary create ;

2
core/classes/mixin/mixin.factor
View File

@ -31,7 +31,7 @@ TUPLE: check-mixin-class mixin ;
>r >r check-mixin-class 2dup members memq? r> r> if ; inline >r >r check-mixin-class 2dup members memq? r> r> if ; inline
: change-mixin-class ( class mixin quot -- ) : change-mixin-class ( class mixin quot -- )
[ members swap bootstrap-word ] swap compose keep [ members swap bootstrap-word ] prepose keep
swap redefine-mixin-class ; inline swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- ) : add-mixin-instance ( class mixin -- )

2
core/classes/tuple/tuple.factor
View File

@ -166,7 +166,7 @@ M: tuple-class update-class
3tri ; 3tri ;
: subclasses ( class -- classes ) : subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ; class-usages keys [ tuple-class? ] filter ;
: each-subclass ( class quot -- ) : each-subclass ( class quot -- )
>r subclasses r> each ; inline >r subclasses r> each ; inline

4
core/combinators/combinators.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: combinators
USING: arrays sequences sequences.private math.private USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors kernel kernel.private math assocs quotations vectors
hashtables sorting words sets ; hashtables sorting words sets math.order ;
IN: combinators
: cleave ( x seq -- ) : cleave ( x seq -- )
[ call ] with each ; [ call ] with each ;

2
core/command-line/command-line.factor
View File

@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
"none" "run" set-global ; "none" "run" set-global ;
: parse-command-line ( -- ) : parse-command-line ( -- )
cli-args [ cli-arg ] subset cli-args [ cli-arg ] filter
"script" get [ script-mode ] when "script" get [ script-mode ] when
ignore-cli-args? [ drop ] [ [ run-file ] each ] if ignore-cli-args? [ drop ] [ [ run-file ] each ] if
"e" get [ eval ] when* ; "e" get [ eval ] when* ;

2
core/compiler/errors/errors.factor
View File

@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
: errors-of-type ( type -- assoc ) : errors-of-type ( type -- assoc )
compiler-errors get-global compiler-errors get-global
swap [ >r nip compiler-error-type r> eq? ] curry swap [ >r nip compiler-error-type r> eq? ] curry
assoc-subset ; assoc-filter ;
: compiler-errors. ( type -- ) : compiler-errors. ( type -- )
errors-of-type >alist sort-keys errors-of-type >alist sort-keys

4
core/compiler/tests/intrinsics.factor
View File

@ -1,11 +1,11 @@
IN: compiler.tests
USING: arrays compiler.units kernel kernel.private math USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien sbufs.private strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ; namespaces libc sequences.private io.encodings.ascii ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test

4
core/compiler/tests/stack-trace.factor
View File

@ -13,11 +13,11 @@ words splitting sorting ;
[ baz ] [ 3 = ] must-fail-with [ baz ] [ 3 = ] must-fail-with
[ t ] [ [ t ] [
symbolic-stack-trace symbolic-stack-trace
[ word? ] subset [ word? ] filter
{ baz bar foo throw } tail? { baz bar foo throw } tail?
] unit-test ] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ; : bleh [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? symbolic-stack-trace memq? ; : stack-trace-contains? symbolic-stack-trace memq? ;

4
core/compiler/units/units.factor
View File

@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
[ definitions-changed ] with each ; [ definitions-changed ] with each ;
: changed-vocabs ( assoc -- vocabs ) : changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-subset [ drop word? ] assoc-filter
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ; [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
: updated-definitions ( -- assoc ) : updated-definitions ( -- assoc )
@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook SYMBOL: update-tuples-hook
: call-recompile-hook ( -- ) : call-recompile-hook ( -- )
changed-definitions get keys [ word? ] subset changed-definitions get keys [ word? ] filter
compiled-usages recompile-hook get call ; compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- ) : call-update-tuples-hook ( -- )

2
core/cpu/x86/64/64.factor
View File

@ -181,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq ) : split-struct ( pairs -- seq )
[ [
[ 8 mod zero? [ t , ] when , ] assoc-each [ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ; ] { } make { t } split [ empty? not ] filter ;
: flatten-large-struct ( type -- ) : flatten-large-struct ( type -- )
heap-size cell align heap-size cell align

3
core/cpu/x86/architecture/architecture.factor
View File

@ -3,7 +3,8 @@
USING: alien alien.c-types alien.compiler arrays USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ; generator.fixup system layouts combinators compiler.constants
math.order ;
IN: cpu.x86.architecture IN: cpu.x86.architecture
HOOK: ds-reg cpu HOOK: ds-reg cpu

2
core/cpu/x86/assembler/assembler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences combinators kernel.private math namespaces parser sequences
words system layouts ; words system layouts math.order ;
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64. ! A postfix assembler for x86 and AMD64.

3
core/debugger/debugger.factor
View File

@ -6,7 +6,8 @@ strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes.builtin classes generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private compiler.units generic.standard vocabs threads threads.private
init kernel.private libc io.encodings mirrors accessors ; init kernel.private libc io.encodings mirrors accessors
math.order ;
IN: debugger IN: debugger
GENERIC: error. ( error -- ) GENERIC: error. ( error -- )

2
core/definitions/definitions-tests.factor
View File

@ -1,6 +1,6 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences USING: tools.test generic kernel definitions sequences
compiler.units words ; compiler.units words ;
IN: definitions.tests
GENERIC: some-generic ( a -- b ) GENERIC: some-generic ( a -- b )

2
core/dlists/dlists.factor
View File

@ -153,7 +153,7 @@ PRIVATE>
drop ; drop ;
: dlist-each ( dlist quot -- ) : dlist-each ( dlist quot -- )
[ obj>> ] swap compose dlist-each-node ; inline [ obj>> ] prepose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- ) : dlist-slurp ( dlist quot -- )
over dlist-empty? over dlist-empty?

2
core/generator/fixup/fixup.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic assocs hashtables USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words kernel kernel.private math namespaces sequences words
quotations strings alien.strings layouts system combinators quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture ; math.bitfields words.private cpu.architecture math.order ;
IN: generator.fixup IN: generator.fixup
: no-stack-frame -1 ; inline : no-stack-frame -1 ; inline

6
core/generator/registers/registers.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays words effects alien byte-arrays bit-arrays float-arrays
accessors sets ; accessors sets math.order ;
IN: generator.registers IN: generator.registers
SYMBOL: +input+ SYMBOL: +input+
@ -314,7 +314,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq ) : (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved #! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset [ live-loc? ] assoc-filter
values ; values ;
: live-locs ( -- seq ) : live-locs ( -- seq )
@ -484,7 +484,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- ) : substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map [ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable [ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ; [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- ) : set-operand ( value var -- )

8
core/generic/generic-tests.factor
View File

@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ; M: integer generic-forget-test-1 / ;
[ t ] [ [ t ] [
\ / usage [ word? ] subset \ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains? [ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test ] unit-test
@ -152,7 +152,7 @@ M: integer generic-forget-test-1 / ;
] unit-test ] unit-test
[ f ] [ [ f ] [
\ / usage [ word? ] subset \ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains? [ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test ] unit-test
@ -161,7 +161,7 @@ GENERIC: generic-forget-test-2
M: sequence generic-forget-test-2 = ; M: sequence generic-forget-test-2 = ;
[ t ] [ [ t ] [
\ = usage [ word? ] subset \ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains? [ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test ] unit-test
@ -170,7 +170,7 @@ M: sequence generic-forget-test-2 = ;
] unit-test ] unit-test
[ f ] [ [ f ] [
\ = usage [ word? ] subset \ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains? [ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test ] unit-test

4
core/generic/generic.factor
View File

@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
GENERIC: effective-method ( ... generic -- method ) GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f ) : next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 = order [ class< ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ; [ drop f ] [ second ] if ;
: next-method ( class generic -- class/f ) : next-method ( class generic -- class/f )
@ -137,7 +137,7 @@ M: method-body forget*
all-words [ all-words [
"methods" word-prop keys "methods" word-prop keys
swap [ key? ] curry contains? swap [ key? ] curry contains?
] with subset ; ] with filter ;
: implementors ( class -- seq ) : implementors ( class -- seq )
dup associate implementors* ; dup associate implementors* ;

2
core/generic/math/math.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic hashtables kernel kernel.private USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators math namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra sequences.private classes classes.builtin classes.algebra
definitions ; definitions math.order ;
IN: generic.math IN: generic.math
PREDICATE: math-class < class PREDICATE: math-class < class

4
core/generic/standard/engines/engines.factor
View File

@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
alist>quot ; alist>quot ;
: split-methods ( assoc class -- first second ) : split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-subset ] [ [ nip class< not ] curry assoc-filter ]
[ [ nip class< ] curry assoc-subset ] 2bi ; [ [ nip class< ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' ) : convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [ over >r >r split-methods dup assoc-empty? [

2
core/hashtables/hashtables-tests.factor
View File

@ -10,7 +10,7 @@ continuations ;
[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test [ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ] [ V{ } ]
[ 1000 [ dup sq swap "testhash" get at = not ] subset ] [ 1000 [ dup sq swap "testhash" get at = not ] filter ]
unit-test unit-test
[ t ] [ t ]

3
core/heaps/heaps-docs.factor
View File

@ -1,4 +1,5 @@
USING: heaps.private help.markup help.syntax kernel math assocs ; USING: heaps.private help.markup help.syntax kernel math assocs
math.order ;
IN: heaps IN: heaps
ARTICLE: "heaps" "Heaps" ARTICLE: "heaps" "Heaps"

2
core/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private USING: kernel math sequences arrays assocs sequences.private
growable accessors ; growable accessors math.order ;
IN: heaps IN: heaps
MIXIN: priority-queue MIXIN: priority-queue

6
core/inference/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors ; generic.standard.engines.tuple accessors math.order ;
IN: inference.backend IN: inference.backend
: recursive-label ( word -- label/f ) : recursive-label ( word -- label/f )
@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? ) : balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map [ dup [ length - ] [ 2drop f ] if ] 2map
[ ] subset all-equal? ; [ ] filter all-equal? ;
TUPLE: unbalanced-branches-error quots in out ; TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [ 2dup balanced? [
over supremum -rot over supremum -rot
[ >r dupd r> unify-inputs ] 2map [ >r dupd r> unify-inputs ] 2map
[ ] subset unify-stacks [ ] filter unify-stacks
rot drop rot drop
] [ ] [
unbalanced-branches-error unbalanced-branches-error

2
core/inference/class/class.factor
View File

@ -153,7 +153,7 @@ M: pair constraint-satisfied?
first constraint-satisfied? ; first constraint-satisfied? ;
: extract-keys ( seq assoc -- newassoc ) : extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ; [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- ) : annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of #! Annotate the node with the currently-inferred set of

2
core/inference/dataflow/dataflow.factor
View File

@ -300,7 +300,7 @@ SYMBOL: node-stack
dup in-d>> first node-class ; dup in-d>> first node-class ;
: active-children ( node -- seq ) : active-children ( node -- seq )
children>> [ last-node ] map [ #terminate? not ] subset ; children>> [ last-node ] map [ #terminate? not ] filter ;
DEFER: #tail? DEFER: #tail?

2
core/inspector/inspector.factor
View File

@ -96,7 +96,7 @@ SYMBOL: +editable+
: namestack. ( seq -- ) : namestack. ( seq -- )
[ [
[ global eq? not ] subset [ global eq? not ] filter
[ keys ] map concat prune [ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;

4
core/io/files/files-tests.factor
View File

@ -135,13 +135,13 @@ strings accessors io.encodings.utf8 ;
[ { { "kernel" t } } ] [ [ { { "kernel" t } } ] [
"core" resource-path [ "core" resource-path [
"." directory [ first "kernel" = ] subset "." directory [ first "kernel" = ] filter
] with-directory ] with-directory
] unit-test ] unit-test
[ { { "kernel" t } } ] [ [ { { "kernel" t } } ] [
"resource:core" [ "resource:core" [
"." directory [ first "kernel" = ] subset "." directory [ first "kernel" = ] filter
] with-directory ] with-directory
] unit-test ] unit-test

6
core/io/files/files.factor
View File

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ; io.encodings.binary init accessors math.order ;
IN: io.files IN: io.files
HOOK: (file-reader) io-backend ( path -- stream ) HOOK: (file-reader) io-backend ( path -- stream )
@ -54,7 +54,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ path-separator? ] left-trim ; [ path-separator? ] left-trim ;
: last-path-separator ( path -- n ? ) : last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ; [ length 1- ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? ) HOOK: root-directory? io-backend ( path -- ? )
@ -232,7 +232,7 @@ HOOK: make-directory io-backend ( path -- )
dup string? dup string?
[ tuck append-path directory? 2array ] [ nip ] if [ tuck append-path directory? 2array ] [ nip ] if
] with map ] with map
[ first { "." ".." } member? not ] subset ; [ first { "." ".." } member? not ] filter ;
: directory ( path -- seq ) : directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ; normalize-directory dup (directory) fixup-directory ;

2
core/io/streams/string/string.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain generic splitting growable continuations io.streams.plain
io.encodings io.encodings.private ; io.encodings io.encodings.private math.order ;
IN: io.streams.string IN: io.streams.string
M: growable dispose drop ; M: growable dispose drop ;

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

@ -1,7 +1,7 @@
USING: generic help.markup help.syntax math memory USING: generic help.markup help.syntax math memory
namespaces sequences kernel.private layouts sorting classes namespaces sequences kernel.private layouts sorting classes
kernel.private vectors combinators quotations strings words kernel.private vectors combinators quotations strings words
assocs arrays ; assocs arrays math.order ;
IN: kernel IN: kernel
ARTICLE: "shuffle-words" "Shuffle words" ARTICLE: "shuffle-words" "Shuffle words"
@ -393,29 +393,8 @@ HELP: identity-tuple
{ $unchecked-example "T{ foo } dup clone = ." "f" } { $unchecked-example "T{ foo } dup clone = ." "f" }
} ; } ;
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
{ "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
{ "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
}
"The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
} ;
{ <=> compare natural-sort sort-keys sort-values } related-words { <=> compare natural-sort sort-keys sort-values } related-words
HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples
{ $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
} ;
HELP: clone HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } } { $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;

7
core/kernel/kernel.factor
View File

@ -133,8 +133,6 @@ M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? ) : = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline 2dup eq? [ 2drop t ] [ equal? ] if ; inline
GENERIC: <=> ( obj1 obj2 -- n )
GENERIC: clone ( obj -- cloned ) GENERIC: clone ( obj -- cloned )
M: object clone ; M: object clone ;
@ -158,6 +156,9 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry ) : with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- curry )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- curry ) : 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline compose compose ; inline
@ -176,8 +177,6 @@ M: callstack clone (clone) ;
: either? ( x y quot -- ? ) bi@ or ; inline : either? ( x y quot -- ? ) bi@ or ; inline
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
: most ( x y quot -- z ) : most ( x y quot -- z )
>r 2dup r> call [ drop ] [ nip ] if ; inline >r 2dup r> call [ drop ] [ nip ] if ; inline

2
core/layouts/layouts.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes USING: namespaces math words kernel assocs classes
kernel.private ; math.order kernel.private ;
IN: layouts IN: layouts
SYMBOL: tag-mask SYMBOL: tag-mask

2
core/math/intervals/intervals-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax math ; USING: help.markup help.syntax math math.order ;
IN: math.intervals IN: math.intervals
ARTICLE: "math-intervals-new" "Creating intervals" ARTICLE: "math-intervals-new" "Creating intervals"

4
core/math/intervals/intervals-tests.factor
View File

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays USING: math.intervals kernel sequences words math math.order
prettyprint tools.test random vocabs combinators ; arrays prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test

2
core/math/intervals/intervals.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice. ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: kernel sequences arrays math combinators ; USING: kernel sequences arrays math combinators math.order ;
IN: math.intervals IN: math.intervals
TUPLE: interval from to ; TUPLE: interval from to ;

39
core/math/math-docs.factor
View File

@ -79,28 +79,6 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } } { $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; { $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
{ before? after? before=? after=? } related-words
HELP: + HELP: +
{ $values { "x" number } { "y" number } { "z" number } } { $values { "x" number } { "y" number } { "z" number } }
@ -275,19 +253,6 @@ HELP: recip
{ $description "Computes a number's multiplicative inverse." } { $description "Computes a number's multiplicative inverse." }
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ; { $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
HELP: max
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the greatest of two real numbers." } ;
HELP: min
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: rem HELP: rem
{ $values { "x" integer } { "y" integer } { "z" integer } } { $values { "x" integer } { "y" integer } { "z" integer } }
{ $description { $description
@ -333,10 +298,6 @@ HELP: times
{ $description "Calls the quotation " { $snippet "n" } " times." } { $description "Calls the quotation " { $snippet "n" } " times." }
{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ; { $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
HELP: [-]
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
HELP: fp-nan? HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } } { $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;

22
core/math/math.factor
View File

@ -17,11 +17,6 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable
: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
MATH: + ( x y -- z ) foldable MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable MATH: * ( x y -- z ) foldable
@ -61,23 +56,14 @@ M: object zero? drop f ;
: sq ( x -- y ) dup * ; inline : sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline : neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline : recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline : ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline : /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; inline
: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable : rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
: 2^ ( n -- 2^n ) 1 swap shift ; inline : 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ; : even? ( n -- ? ) 1 bitand zero? ;
@ -96,13 +82,9 @@ M: number equal? number= ;
M: real hashcode* nip >fixnum ; M: real hashcode* nip >fixnum ;
M: real <=> - ;
! real and sequence overlap. we disambiguate: ! real and sequence overlap. we disambiguate:
M: integer hashcode* nip >fixnum ; M: integer hashcode* nip >fixnum ;
M: integer <=> - ;
GENERIC: fp-nan? ( x -- ? ) GENERIC: fp-nan? ( x -- ? )
M: object fp-nan? M: object fp-nan?
@ -161,7 +143,7 @@ PRIVATE>
iterate-prep (each-integer) ; inline iterate-prep (each-integer) ; inline
: times ( n quot -- ) : times ( n quot -- )
[ drop ] swap compose each-integer ; inline [ drop ] prepose each-integer ; inline
: find-integer ( n quot -- i ) : find-integer ( n quot -- i )
iterate-prep (find-integer) ; inline iterate-prep (find-integer) ; inline

2
core/optimizer/backend/backend.factor
View File

@ -87,7 +87,7 @@ M: node optimize-node* drop t f ;
: compute-value-substitutions ( #call/#merge #return/#values -- assoc ) : compute-value-substitutions ( #call/#merge #return/#values -- assoc )
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ; [ = not ] assoc-filter >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? ) : cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor [ dup node-successor [

4
core/optimizer/control/control.factor
View File

@ -75,7 +75,7 @@ USE: prettyprint
M: #call-label collect-label-info* M: #call-label collect-label-info*
node-param label-info get at node-param label-info get at
node-stack get over third tail node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep [ [ #label? ] filter [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array [ node-successor #tail? ] all? 2array
swap second push ; swap second push ;
@ -91,7 +91,7 @@ SYMBOL: potential-loops
: remove-non-tail-calls ( -- ) : remove-non-tail-calls ( -- )
label-info get label-info get
[ nip second [ second ] all? ] assoc-subset [ nip second [ second ] all? ] assoc-filter
[ first ] assoc-map [ first ] assoc-map
potential-loops set ; potential-loops set ;

4
core/optimizer/def-use/def-use.factor
View File

@ -56,7 +56,7 @@ UNION: #killable
: purge-invariants ( stacks -- seq ) : purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the #! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence. #! same position in each sequence of the stacks sequence.
unify-lengths flip [ all-eq? not ] subset concat ; unify-lengths flip [ all-eq? not ] filter concat ;
M: #label node-def-use M: #label node-def-use
[ [
@ -75,7 +75,7 @@ M: #branch node-def-use
dup branch-def-use (node-def-use) ; dup branch-def-use (node-def-use) ;
: compute-dead-literals ( -- values ) : compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ; def-use get [ >r value? r> empty? and ] assoc-filter ;
DEFER: kill-nodes DEFER: kill-nodes
SYMBOL: dead-literals SYMBOL: dead-literals

4
core/optimizer/math/partial/partial.factor
View File

@ -85,7 +85,7 @@ PREDICATE: math-partial < word
: define-math-ops ( op -- ) : define-math-ops ( op -- )
{ fixnum bignum float } { fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ nip ] assoc-subset [ nip ] assoc-filter
[ word-def peek ] assoc-map % ; [ word-def peek ] assoc-map % ;
SYMBOL: math-ops SYMBOL: math-ops
@ -155,7 +155,7 @@ SYMBOL: fast-math-ops
[ drop math-class-max swap specific-method >boolean ] if ; [ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words ) : (derived-ops) ( word assoc -- words )
swap [ rot first eq? nip ] curry assoc-subset values ; swap [ rot first eq? nip ] curry assoc-filter values ;
: derived-ops ( word -- words ) : derived-ops ( word -- words )
[ 1array ] [ 1array ]

2
core/optimizer/specializers/specializers.factor
View File

@ -12,7 +12,7 @@ IN: optimizer.specializers
: make-specializer ( classes -- quot ) : make-specializer ( classes -- quot )
dup length <reversed> dup length <reversed>
[ (picker) 2array ] 2map [ (picker) 2array ] 2map
[ drop object eq? not ] assoc-subset [ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [ dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map [ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce unclip [ swap [ f ] \ if 3array append [ ] like ] reduce

12
core/parser/parser.factor
View File

@ -63,7 +63,7 @@ t parser-notes set-global
: skip ( i seq ? -- n ) : skip ( i seq ? -- n )
over >r over >r
[ swap CHAR: \s eq? xor ] curry find* drop [ swap CHAR: \s eq? xor ] curry find-from drop
[ r> drop ] [ r> length ] if* ; [ r> drop ] [ r> length ] if* ;
: change-lexer-column ( lexer quot -- ) : change-lexer-column ( lexer quot -- )
@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ; : add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- ) : set-use ( seq -- )
[ vocab-words ] map [ ] subset >vector use set ; [ vocab-words ] map [ ] filter >vector use set ;
: check-vocab-string ( name -- name ) : check-vocab-string ( name -- name )
dup string? dup string?
@ -270,7 +270,7 @@ M: no-word-error summary
: no-word ( name -- newword ) : no-word ( name -- newword )
dup no-word-error boa dup no-word-error boa
swap words-named [ forward-reference? not ] subset swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts word-restarts throw-restarts
dup word-vocabulary (use+) ; dup word-vocabulary (use+) ;
@ -278,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [ dup forward-reference? [
drop drop
use get use get
[ at ] with map [ ] subset [ at ] with map [ ] filter
[ forward-reference? not ] find nip [ forward-reference? not ] find nip
] [ ] [
nip nip
@ -516,7 +516,7 @@ SYMBOL: interactive-vocabs
assoc-diff [ assoc-diff [
drop where dup [ first ] when drop where dup [ first ] when
file get source-file-path = file get source-file-path =
] assoc-subset keys ; ] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 ) : removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions new-definitions old-definitions
@ -531,7 +531,7 @@ SYMBOL: interactive-vocabs
: reset-removed-classes ( -- ) : reset-removed-classes ( -- )
removed-classes removed-classes
filter-moved [ class? ] subset [ reset-class ] each ; filter-moved [ class? ] filter [ reset-class ] each ;
: fix-class-words ( -- ) : fix-class-words ( -- )
#! If a class word had a compound definition which was #! If a class word had a compound definition which was

2
core/prettyprint/backend/backend.factor
View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays bit-arrays generic hashtables io USING: arrays byte-arrays bit-arrays generic hashtables io
assocs kernel math namespaces sequences strings sbufs io.styles assocs kernel math namespaces sequences strings sbufs io.styles
vectors words prettyprint.config prettyprint.sections quotations vectors words prettyprint.config prettyprint.sections quotations
io io.files math.parser effects classes.tuple io io.files math.parser effects classes.tuple math.order
classes.tuple.private classes float-arrays ; classes.tuple.private classes float-arrays ;
IN: prettyprint.backend IN: prettyprint.backend

2
core/prettyprint/prettyprint.factor
View File

@ -45,7 +45,7 @@ sets ;
] if ; ] if ;
: vocabs. ( in use -- ) : vocabs. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] subset dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ; use. in. ;
: with-use ( obj quot -- ) : with-use ( obj quot -- )

4
core/prettyprint/sections/sections.factor
View File

@ -171,7 +171,7 @@ M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ call-next-method ] if ; line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- ) : pprint-sections ( block advancer -- )
swap sections>> [ line-break? not ] subset swap sections>> [ line-break? not ] filter
unclip pprint-section [ unclip pprint-section [
dup rot call pprint-section dup rot call pprint-section
] with each ; inline ] with each ; inline
@ -310,7 +310,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set 2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after swap nth dup split-before dup , split-after
] with each ] with each
] { } make { t } split [ empty? not ] subset ; ] { } make { t } split [ empty? not ] filter ;
: break-group? ( seq -- ? ) : break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ; [ first section-fits? ] [ peek section-fits? not ] bi and ;

6
core/quotations/quotations.factor
View File

@ -50,14 +50,14 @@ M: curry nth
INSTANCE: curry immutable-sequence INSTANCE: curry immutable-sequence
M: compose length M: compose length
dup compose-first length [ compose-first length ]
swap compose-second length + ; [ compose-second length ] bi + ;
M: compose nth M: compose nth
2dup compose-first length < [ 2dup compose-first length < [
compose-first compose-first
] [ ] [
[ compose-first length - ] keep compose-second [ compose-first length - ] [ compose-second ] bi
] if nth ; ] if nth ;
INSTANCE: compose immutable-sequence INSTANCE: compose immutable-sequence

45
core/sequences/sequences-docs.factor
View File

@ -1,5 +1,5 @@
USING: arrays bit-arrays help.markup help.syntax USING: arrays bit-arrays help.markup help.syntax math
sequences.private vectors strings sbufs kernel math ; sequences.private vectors strings sbufs kernel math.order ;
IN: sequences IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations" ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq } { $subsection subseq }
{ $subsection head } { $subsection head }
{ $subsection tail } { $subsection tail }
{ $subsection rest }
{ $subsection head* } { $subsection head* }
{ $subsection tail* } { $subsection tail* }
"Taking a sequence apart into a head and a tail:" "Taking a sequence apart into a head and a tail:"
@ -105,6 +106,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> } { $subsection <slice> }
{ $subsection head-slice } { $subsection head-slice }
{ $subsection tail-slice } { $subsection tail-slice }
{ $subsection rest-slice }
{ $subsection head-slice* } { $subsection head-slice* }
{ $subsection tail-slice* } { $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:" "Taking a sequence apart into a head and a tail:"
@ -127,7 +129,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection unfold } { $subsection unfold }
"Filtering:" "Filtering:"
{ $subsection push-if } { $subsection push-if }
{ $subsection subset } ; { $subsection filter } ;
ARTICLE: "sequences-tests" "Testing sequences" ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:" "Testing for an empty sequence:"
@ -153,17 +155,17 @@ ARTICLE: "sequences-tests" "Testing sequences"
ARTICLE: "sequences-search" "Searching sequences" ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:" "Finding the index of an element:"
{ $subsection index } { $subsection index }
{ $subsection index* } { $subsection index-from }
{ $subsection last-index } { $subsection last-index }
{ $subsection last-index* } { $subsection last-index-from }
"Finding the start of a subsequence:" "Finding the start of a subsequence:"
{ $subsection start } { $subsection start }
{ $subsection start* } { $subsection start* }
"Finding the index of an element satisfying a predicate:" "Finding the index of an element satisfying a predicate:"
{ $subsection find } { $subsection find }
{ $subsection find* } { $subsection find-from }
{ $subsection find-last } { $subsection find-last }
{ $subsection find-last* } ; { $subsection find-last-from } ;
ARTICLE: "sequences-destructive" "Destructive operations" ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence." "These words modify their input, instead of creating a new sequence."
@ -500,9 +502,9 @@ HELP: find
{ $snippet "( elt -- ? )" } } { $snippet "( elt -- ? )" } }
{ "i" "the index of the first match, or f" } { "i" "the index of the first match, or f" }
{ "elt" "the first matching element, or " { $link f } } } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find* } " where the starting index is 0." } ; { $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
HELP: find* HELP: find-from
{ $values { "n" "a starting index" } { $values { "n" "a starting index" }
{ "seq" sequence } { "seq" sequence }
{ "quot" "a quotation with stack effect " { "quot" "a quotation with stack effect "
@ -513,9 +515,9 @@ HELP: find*
HELP: find-last HELP: find-last
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last* } " where the starting index is one less than the length of the sequence." } ; { $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last* HELP: find-last-from
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ; { $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
@ -530,9 +532,9 @@ HELP: all?
HELP: push-if HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } } { $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." } { $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link subset } "." } ; { $notes "This word is a factor of " { $link filter } "." } ;
HELP: subset HELP: filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } } { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ; { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
@ -562,9 +564,9 @@ HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } } { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ; { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
{ index index* last-index last-index* member? memq? } related-words { index index-from last-index last-index-from member? memq? } related-words
HELP: index* HELP: index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } } { $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ; { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;
@ -572,7 +574,7 @@ HELP: last-index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } } { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } "; the sequence is traversed back to front. If no element is found, outputs " { $link f } "." } ; { $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } "; the sequence is traversed back to front. If no element is found, outputs " { $link f } "." } ;
HELP: last-index* HELP: last-index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } } { $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ; { $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ;
@ -834,6 +836,12 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." } { $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ; { $errors "Throws an error if the index is out of bounds." } ;
HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
{ $notes "Equivalent to " { $snippet "1 tail" } }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: head-slice* HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } } { $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." } { $description "Outputs a virtual sequence sharing storage with all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
@ -854,6 +862,11 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." } { $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ; { $errors "Throws an error if the index is out of bounds." } ;
HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: head* HELP: head*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "headseq" "a new sequence" } } { $values { "seq" sequence } { "n" "a non-negative integer" } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." } { $description "Outputs a new sequence consisting of all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }

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

@ -27,7 +27,7 @@ IN: sequences.tests
[ "hello world" "aeiou" [ member? ] curry find ] unit-test [ "hello world" "aeiou" [ member? ] curry find ] unit-test
[ 4 CHAR: o ] [ 4 CHAR: o ]
[ 3 "hello world" "aeiou" [ member? ] curry find* ] unit-test [ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test
[ f ] [ 3 [ ] member? ] unit-test [ f ] [ 3 [ ] member? ] unit-test
[ f ] [ 3 [ 1 2 ] member? ] unit-test [ f ] [ 3 [ 1 2 ] member? ] unit-test
@ -39,18 +39,18 @@ IN: sequences.tests
[ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test [ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test
[ f ] [ CHAR: x 5 "tuvwxyz" >vector index* ] unit-test [ f ] [ CHAR: x 5 "tuvwxyz" >vector index-from ] unit-test
[ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test [ f ] [ CHAR: a 0 "tuvwxyz" >vector index-from ] unit-test
[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test [ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test [ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test [ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test [ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] filter ] unit-test
[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test [ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] filter ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry subset ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
[ "hello world how are you" ] [ "hello world how are you" ]
[ { "hello" "world" "how" "are" "you" } " " join ] [ { "hello" "world" "how" "are" "you" } " " join ]
@ -169,9 +169,9 @@ unit-test
[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test [ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find* ] unit-test [ f f ] [ 100 { 1 2 3 } [ 1 = ] find-from ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last* ] unit-test [ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last-from ] unit-test
[ f f ] [ -1 { 1 2 3 } [ 1 = ] find* ] unit-test [ f f ] [ -1 { 1 2 3 } [ 1 = ] find-from ] unit-test
[ 0 ] [ { "a" "b" "c" } { "A" "B" "C" } mismatch ] unit-test [ 0 ] [ { "a" "b" "c" } { "A" "B" "C" } mismatch ] unit-test
@ -187,9 +187,6 @@ unit-test
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test
[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [ [ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
V{ } clone "cache-test" set V{ } clone "cache-test" set
1 "cache-test" get [ sq ] cache-nth 1 "cache-test" get [ sq ] cache-nth

80
core/sequences/sequences.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private slots.private math math.private
math.order ;
IN: sequences IN: sequences
USING: kernel kernel.private slots.private math math.private ;
MIXIN: sequence MIXIN: sequence
@ -36,7 +37,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: set-third ( third seq -- ) 2 swap set-nth ; inline : set-third ( third seq -- ) 2 swap set-nth ; inline
: set-fourth ( fourth seq -- ) 3 swap set-nth ; inline : set-fourth ( fourth seq -- ) 3 swap set-nth ; inline
: push ( elt seq -- ) dup length swap set-nth ; : push ( elt seq -- ) [ length ] [ set-nth ] bi ;
: bounds-check? ( n seq -- ? ) : bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline length 1- 0 swap between? ; inline
@ -100,13 +101,13 @@ M: integer nth-unsafe drop ;
INSTANCE: integer immutable-sequence INSTANCE: integer immutable-sequence
: first2-unsafe : first2-unsafe
[ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline [ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
: first3-unsafe : first3-unsafe
[ first2-unsafe ] keep 2 swap nth-unsafe ; inline [ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
: first4-unsafe : first4-unsafe
[ first3-unsafe ] keep 3 swap nth-unsafe ; inline [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- ) : exchange-unsafe ( m n seq -- )
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
@ -179,7 +180,7 @@ M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence INSTANCE: reversed virtual-sequence
: reverse ( seq -- newseq ) [ <reversed> ] keep like ; : reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
! A slice of another sequence. ! A slice of another sequence.
TUPLE: slice from to seq ; TUPLE: slice from to seq ;
@ -201,7 +202,7 @@ ERROR: slice-error reason ;
M: slice virtual-seq slice-seq ; M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ; M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
M: slice length dup slice-to swap slice-from - ; M: slice length dup slice-to swap slice-from - ;
@ -209,6 +210,8 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice ( seq n -- slice ) (tail) <slice> ; : tail-slice ( seq n -- slice ) (tail) <slice> ;
: rest-slice ( seq -- slice ) 1 tail-slice ;
: head-slice* ( seq n -- slice ) from-end head-slice ; : head-slice* ( seq n -- slice ) from-end head-slice ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ; : tail-slice* ( seq n -- slice ) from-end tail-slice ;
@ -248,12 +251,14 @@ INSTANCE: repetition immutable-sequence
PRIVATE> PRIVATE>
: subseq ( from to seq -- subseq ) : subseq ( from to seq -- subseq )
[ check-slice prepare-subseq (copy) ] keep like ; [ check-slice prepare-subseq (copy) ] [ like ] bi ;
: head ( seq n -- headseq ) (head) subseq ; : head ( seq n -- headseq ) (head) subseq ;
: tail ( seq n -- tailseq ) (tail) subseq ; : tail ( seq n -- tailseq ) (tail) subseq ;
: rest ( seq -- seq' ) 1 tail ;
: head* ( seq n -- headseq ) from-end head ; : head* ( seq n -- headseq ) from-end head ;
: tail* ( seq n -- tailseq ) from-end tail ; : tail* ( seq n -- tailseq ) from-end tail ;
@ -267,11 +272,12 @@ M: sequence clone-like
M: immutable-sequence clone-like like ; M: immutable-sequence clone-like like ;
: push-all ( src dest -- ) [ length ] keep copy ; : push-all ( src dest -- ) [ length ] [ copy ] bi ;
: ((append)) ( seq1 seq2 accum -- accum ) : ((append)) ( seq1 seq2 accum -- accum )
[ >r over length r> copy ] keep [ >r over length r> copy ]
[ 0 swap copy ] keep ; inline [ 0 swap copy ]
[ ] tri ; inline
: (append) ( seq1 seq2 exemplar -- newseq ) : (append) ( seq1 seq2 exemplar -- newseq )
>r over length over length + r> >r over length over length + r>
@ -279,8 +285,8 @@ M: immutable-sequence clone-like like ;
: (3append) ( seq1 seq2 seq3 exemplar -- newseq ) : (3append) ( seq1 seq2 seq3 exemplar -- newseq )
>r pick length pick length pick length + + r> [ >r pick length pick length pick length + + r> [
[ >r pick length pick length + r> copy ] keep [ >r pick length pick length + r> copy ]
((append)) [ ((append)) ] bi
] new-like ; inline ] new-like ; inline
: append ( seq1 seq2 -- newseq ) over (append) ; : append ( seq1 seq2 -- newseq ) over (append) ;
@ -323,7 +329,7 @@ M: immutable-sequence clone-like like ;
: (find) ( seq quot quot' -- i elt ) : (find) ( seq quot quot' -- i elt )
pick >r >r (each) r> call r> finish-find ; inline pick >r >r (each) r> call r> finish-find ; inline
: (find*) ( n seq quot quot' -- i elt ) : (find-from) ( n seq quot quot' -- i elt )
>r >r 2dup bounds-check? [ >r >r 2dup bounds-check? [
r> r> (find) r> r> (find)
] [ ] [
@ -332,7 +338,7 @@ M: immutable-sequence clone-like like ;
: (monotonic) ( seq quot -- ? ) : (monotonic) ( seq quot -- ? )
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ] [ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
swap compose curry ; inline prepose curry ; inline
: (interleave) ( n elt between quot -- ) : (interleave) ( n elt between quot -- )
roll zero? [ nip ] [ swapd 2slip ] if call ; inline roll zero? [ nip ] [ swapd 2slip ] if call ; inline
@ -373,14 +379,14 @@ PRIVATE>
: 2all? ( seq1 seq2 quot -- ? ) : 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline (2each) all-integers? ; inline
: find* ( n seq quot -- i elt ) : find-from ( n seq quot -- i elt )
[ (find-integer) ] (find*) ; inline [ (find-integer) ] (find-from) ; inline
: find ( seq quot -- i elt ) : find ( seq quot -- i elt )
[ find-integer ] (find) ; inline [ find-integer ] (find) ; inline
: find-last* ( n seq quot -- i elt ) : find-last-from ( n seq quot -- i elt )
[ nip find-last-integer ] (find*) ; inline [ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt ) : find-last ( seq quot -- i elt )
[ >r 1- r> find-last-integer ] (find) ; inline [ >r 1- r> find-last-integer ] (find) ; inline
@ -394,7 +400,7 @@ PRIVATE>
: pusher ( quot -- quot accum ) : pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline V{ } clone [ [ push-if ] 2curry ] keep ; inline
: subset ( seq quot -- subseq ) : filter ( seq quot -- subseq )
over >r pusher >r each r> r> like ; inline over >r pusher >r each r> r> like ; inline
: monotonic? ( seq quot -- ? ) : monotonic? ( seq quot -- ? )
@ -414,14 +420,14 @@ PRIVATE>
: index ( obj seq -- n ) : index ( obj seq -- n )
[ = ] with find drop ; [ = ] with find drop ;
: index* ( obj i seq -- n ) : index-from ( obj i seq -- n )
rot [ = ] curry find* drop ; rot [ = ] curry find-from drop ;
: last-index ( obj seq -- n ) : last-index ( obj seq -- n )
[ = ] with find-last drop ; [ = ] with find-last drop ;
: last-index* ( obj i seq -- n ) : last-index-from ( obj i seq -- n )
rot [ = ] curry find-last* drop ; rot [ = ] curry find-last-from drop ;
: contains? ( seq quot -- ? ) : contains? ( seq quot -- ? )
find drop >boolean ; inline find drop >boolean ; inline
@ -433,7 +439,7 @@ PRIVATE>
[ eq? ] with contains? ; [ eq? ] with contains? ;
: remove ( obj seq -- newseq ) : remove ( obj seq -- newseq )
[ = not ] with subset ; [ = not ] with filter ;
: cache-nth ( i seq quot -- elt ) : cache-nth ( i seq quot -- elt )
2over ?nth dup [ 2over ?nth dup [
@ -472,7 +478,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- ) : move ( to from seq -- )
2over number= 2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline [ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq ) : (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [ 2dup length < [
@ -497,9 +503,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ 0 swap copy ] keep [ 0 swap copy ] keep
] new-like ; ] new-like ;
: peek ( seq -- elt ) dup length 1- swap nth ; : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
: pop* ( seq -- ) dup length 1- swap set-length ; : pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
: move-backward ( shift from to seq -- ) : move-backward ( shift from to seq -- )
2over number= [ 2over number= [
@ -519,7 +525,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (open-slice) ( shift from to seq ? -- ) : (open-slice) ( shift from to seq ? -- )
[ [
>r >r 1- r> 1- r> move-forward >r [ 1- ] bi@ r> move-forward
] [ ] [
>r >r over - r> r> move-backward >r >r over - r> r> move-backward
] if ; ] if ;
@ -544,7 +550,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
copy ; copy ;
: pop ( seq -- elt ) : pop ( seq -- elt )
dup length 1- swap [ nth ] 2keep set-length ; [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ; : all-equal? ( seq -- ? ) [ = ] monotonic? ;
@ -609,7 +615,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ; ] if ;
: cut-slice ( seq n -- before after ) : cut-slice ( seq n -- before after )
[ head-slice ] 2keep tail-slice ; [ head-slice ] [ tail-slice ] 2bi ;
: midpoint@ ( seq -- n ) length 2/ ; inline : midpoint@ ( seq -- n ) length 2/ ; inline
@ -634,10 +640,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ; inline ] if ; inline
: cut ( seq n -- before after ) : cut ( seq n -- before after )
[ head ] 2keep tail ; [ head ] [ tail ] 2bi ;
: cut* ( seq n -- before after ) : cut* ( seq n -- before after )
[ head* ] 2keep tail* ; [ head* ] [ tail* ] 2bi ;
<PRIVATE <PRIVATE
@ -650,7 +656,7 @@ PRIVATE>
: start* ( subseq seq n -- i ) : start* ( subseq seq n -- i )
pick length pick length swap - 1+ pick length pick length swap - 1+
[ (start) ] find* [ (start) ] find-from
swap >r 3drop r> ; swap >r 3drop r> ;
: start ( subseq seq -- i ) 0 start* ; inline : start ( subseq seq -- i ) 0 start* ; inline
@ -662,10 +668,10 @@ PRIVATE>
tuck tail-slice >r tail-slice r> ; tuck tail-slice >r tail-slice r> ;
: unclip ( seq -- rest first ) : unclip ( seq -- rest first )
dup 1 tail swap first ; [ rest ] [ first ] bi ;
: unclip-slice ( seq -- rest first ) : unclip-slice ( seq -- rest first )
dup 1 tail-slice swap first ; [ rest-slice ] [ first ] bi ;
: <flat-slice> ( seq -- slice ) : <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ; dup slice? [ { } like ] when 0 over length rot <slice> ;
@ -680,7 +686,7 @@ PRIVATE>
[ 1+ head ] [ 0 head ] if* ; inline [ 1+ head ] [ 0 head ] if* ; inline
: trim ( seq quot -- newseq ) : trim ( seq quot -- newseq )
[ left-trim ] keep right-trim ; inline [ left-trim ] [ right-trim ] bi ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ; : sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] binary-reduce ; : product ( seq -- n ) 1 [ * ] binary-reduce ;

4
core/sets/sets.factor
View File

@ -22,10 +22,10 @@ IN: sets
dup length <hashtable> [ (all-unique?) ] curry all? ; dup length <hashtable> [ (all-unique?) ] curry all? ;
: intersect ( seq1 seq2 -- newseq ) : intersect ( seq1 seq2 -- newseq )
unique [ key? ] curry subset ; unique [ key? ] curry filter ;
: diff ( seq1 seq2 -- newseq ) : diff ( seq1 seq2 -- newseq )
swap unique [ key? not ] curry subset ; swap unique [ key? not ] curry filter ;
: union ( seq1 seq2 -- newseq ) : union ( seq1 seq2 -- newseq )
append prune ; append prune ;

2
core/slots/deprecated/deprecated.factor
View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] } { [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] } { [ over array? ] [ long-slot ] }
} cond } cond
] 2map [ ] subset nip ; ] 2map [ ] filter nip ;
: slot-of-reader ( reader specs -- spec/f ) : slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ; [ slot-spec-reader eq? ] with find nip ;

5
core/sorting/sorting-docs.factor
View File

@ -1,5 +1,6 @@
USING: sorting help.markup help.syntax kernel words math USING: help.markup help.syntax kernel words math
sequences ; sequences math.order ;
IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search" ARTICLE: "sequences-sorting" "Sorting and binary search"
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:" "Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:"

2
core/sorting/sorting.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences vectors USING: arrays kernel math sequences vectors math.order
sequences sequences.private growable ; sequences sequences.private growable ;
IN: sorting IN: sorting

2
core/source-files/source-files.factor
View File

@ -19,7 +19,7 @@ uses definitions ;
: (xref-source) ( source-file -- pathname uses ) : (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> dup source-file-path <pathname>
swap source-file-uses [ crossref? ] subset ; swap source-file-uses [ crossref? ] filter ;
: xref-source ( source-file -- ) : xref-source ( source-file -- )
(xref-source) crossref get add-vertex ; (xref-source) crossref get add-vertex ;

4
core/splitting/splitting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences USING: kernel math namespaces strings arrays vectors sequences
sets ; sets math.order ;
IN: splitting IN: splitting
TUPLE: groups seq n sliced? ; TUPLE: groups seq n sliced? ;
@ -61,7 +61,7 @@ INSTANCE: groups sequence
dup [ swap ] when ; dup [ swap ] when ;
: (split) ( separators n seq -- ) : (split) ( separators n seq -- )
3dup rot [ member? ] curry find* drop 3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ] [ [ swap subseq , ] 2keep 1+ swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline

2
core/strings/strings-tests.factor
View File

@ -31,6 +31,8 @@ IN: strings.tests
[ t ] [ "abc" "abd" before? ] unit-test [ t ] [ "abc" "abd" before? ] unit-test
[ t ] [ "z" "abd" after? ] unit-test [ t ] [ "z" "abd" after? ] unit-test
[ t ] [ "abc" "abd" min ] unit-test
[ t ] [ "z" "abd" max ] unit-test
[ 0 10 "hello" subseq ] must-fail [ 0 10 "hello" subseq ] must-fail

5
core/threads/threads.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight. ! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: threads
USING: arrays hashtables heaps kernel kernel.private math USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors ; dlists assocs system combinators init boxes accessors
math.order ;
IN: threads
SYMBOL: initial-thread SYMBOL: initial-thread

4
core/vocabs/vocabs.factor
View File

@ -76,14 +76,14 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq ) : words-named ( str -- seq )
dictionary get values dictionary get values
[ vocab-words at ] with map [ vocab-words at ] with map
[ ] subset ; [ ] filter ;
: child-vocab? ( prefix name -- ? ) : child-vocab? ( prefix name -- ? )
2dup = pick empty? or 2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . suffix head? ] if ; [ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq ) : child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ; vocab-name vocabs [ child-vocab? ] with filter ;
TUPLE: vocab-link name ; TUPLE: vocab-link name ;

4
core/words/words-tests.factor
View File

@ -68,7 +68,7 @@ FORGET: another-forgotten
: foe fee ; : foe fee ;
: fie foe ; : fie foe ;
[ t ] [ \ fee usage [ word? ] subset empty? ] unit-test [ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
[ t ] [ \ foe usage empty? ] unit-test [ t ] [ \ foe usage empty? ] unit-test
[ f ] [ \ foe crossref get key? ] unit-test [ f ] [ \ foe crossref get key? ] unit-test
@ -80,7 +80,7 @@ FORGET: foe
] unit-test ] unit-test
[ t ] [ [ t ] [
\ * usage [ word? ] subset [ crossref? ] all? \ * usage [ word? ] filter [ crossref? ] all?
] unit-test ] unit-test
DEFER: calls-a-gensym DEFER: calls-a-gensym

11
core/words/words.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting words.private vocabs ; quotations assocs hashtables sorting words.private vocabs
math.order ;
IN: words IN: words
: word ( -- word ) \ word get-global ; : word ( -- word ) \ word get-global ;
@ -101,7 +102,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- ) : compiled-xref ( word dependencies -- )
[ drop compiled-crossref? ] assoc-subset [ drop compiled-crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop 2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ; compiled-crossref get add-vertex* ;
@ -121,7 +122,7 @@ SYMBOL: +called+
: compiled-usages ( words -- seq ) : compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [ [ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update compiled-usage [ nip +inlined+ eq? ] assoc-filter update
] with each keys ; ] with each keys ;
<PRIVATE <PRIVATE
@ -135,9 +136,9 @@ SYMBOL: visited
[ reset-on-redefine reset-props ] [ reset-on-redefine reset-props ]
[ dup visited get set-at ] [ dup visited get set-at ]
[ [
crossref get at keys [ word? ] subset [ crossref get at keys [ word? ] filter [
reset-on-redefine [ word-prop ] with contains? reset-on-redefine [ word-prop ] with contains?
] subset ] filter
[ (redefined) ] each [ (redefined) ] each
] tri ] tri
] if ; ] if ;