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

Merge branch 'bags' of git://github.com/littledan/Factor 

Conflicts:

	basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
	basis/furnace/auth/auth.factor
	basis/stack-checker/backend/backend.factor
db4
Daniel Ehrenberg 2010-03-16 13:28:00 -04:00
parent db106486f1 e3481a7ed7
commit 512fe14e4e
113 changed files with 656 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/bit-sets/bit-sets-docs.factor Normal file
View File

@ -0,0 +1,18 @@
USING: help.markup help.syntax sequences math ;
IN: bit-sets
ARTICLE: "bit-sets" "Bit sets"
"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation."
"Bit sets are of the class"
{ $subsection bit-set }
"They can be instantiated with the word"
{ $subsection <bit-set> } ;
ABOUT: "bit-sets"
HELP: bit-set
{ $class-description "The class of bit-array-based sets. These implement the " { $link "sets" } "." } ;
HELP: <bit-set>
{ $values { "capacity" integer } { "bit-set" bit-set } }
{ $description "Creates a new bit set with the given capacity. This set is initially empty and can contain as members integers between 0 and " { $snippet "capacity" } "-1." } ;

66
basis/bit-sets/bit-sets-tests.factor
View File

@ -1,17 +1,63 @@
USING: bit-sets tools.test bit-arrays ;
USING: bit-sets tools.test sets kernel bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-union
[ T{ bit-set f ?{ t f t f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } union
] unit-test
[ ?{ f f f f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-intersect
[ T{ bit-set f ?{ f f f f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
[ ?{ t f t f f f } ] [
?{ t t t f f f }
?{ f t f f t t } bit-set-diff
[ T{ bit-set f ?{ t f t f f f } } ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } diff
] unit-test
[ f ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } subset?
] unit-test
[ t ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ t ] [
{ 0 1 2 }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ f ] [
T{ bit-set f ?{ f t f f f f } }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ f ] [
{ 1 }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
[ t V{ 1 2 3 } ] [
{ 1 2 } 5 <bit-set> set-like
[ bit-set? ] keep
3 over adjoin
members
] unit-test
[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
[ 1 <bit-set> dup clone 0 over adjoin ] unit-test

59
basis/bit-sets/bit-sets.factor
View File

@ -1,8 +1,33 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
IN: bit-sets
TUPLE: bit-set { table bit-array read-only } ;
: <bit-set> ( capacity -- bit-set )
<bit-array> bit-set boa ;
INSTANCE: bit-set set
M: bit-set in?
over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
M: bit-set adjoin
! This is allowed to crash when the elt couldn't go in the set
[ t ] 2dip table>> set-nth ;
M: bit-set delete
! This isn't allowed to crash if the elt wasn't in the set
over integer? [
table>> 2dup bounds-check? [
[ f ] 2dip set-nth
] [ 2drop ] if
] [ 2drop ] if ;
! If you do binary set operations with a bitset, it's expected
! that the other thing can also be represented as a bitset
! of the same length.
<PRIVATE
: bit-set-map ( seq1 seq2 quot -- seq )
@ -14,18 +39,36 @@ IN: bit-sets
] dip 2map
] 3bi bit-array boa ; inline
: (bit-set-op) ( set1 set2 -- table1 table2 )
[ set-like ] keep [ table>> ] bi@ ; inline
: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
[ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
PRIVATE>
: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
M: bit-set union
[ bitor ] bit-set-op ;
HINTS: bit-set-union bit-array bit-array ;
M: bit-set intersect
[ bitand ] bit-set-op ;
: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
M: bit-set diff
[ bitnot bitand ] bit-set-op ;
HINTS: bit-set-intersect bit-array bit-array ;
M: bit-set subset?
[ intersect ] keep = ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
M: bit-set members
[ table>> length iota ] keep [ in? ] curry filter ;
HINTS: bit-set-diff bit-array bit-array ;
M: bit-set set-like
! This crashes if there are keys that can't be put in the bit set
over bit-set? [ 2dup [ table>> ] bi@ length = ] [ f ] if
[ drop ] [
[ members ] dip table>> length <bit-set>
[ [ adjoin ] curry each ] keep
] if ;
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
M: bit-set clone
table>> clone bit-set boa ;

5
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -12,6 +12,7 @@ compiler.cfg.registers
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
FROM: namespaces => set ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
@ -297,14 +298,14 @@ SYMBOL: live-stores
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat unique
] map concat fast-set
live-stores set ;
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
insn# get live-stores get in? [
drop f
] unless
] when ;

19
basis/compiler/cfg/dce/dce.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
USING: accessors assocs kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
compiler.cfg.rpo compiler.cfg.predecessors ;
compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
FROM: namespaces => set ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
@ -12,18 +13,18 @@ SYMBOL: liveness-graph
SYMBOL: live-vregs
: live-vreg? ( vreg -- ? )
live-vregs get key? ;
live-vregs get in? ;
! vregs which are the result of an allocation
SYMBOL: allocations
: allocation? ( vreg -- ? )
allocations get key? ;
allocations get in? ;
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set
H{ } clone allocations set ;
HS{ } clone live-vregs set
HS{ } clone allocations set ;
GENERIC: build-liveness-graph ( insn -- )
@ -46,7 +47,7 @@ M: ##write-barrier-imm build-liveness-graph
dup src>> setter-liveness-graph ;
M: ##allot build-liveness-graph
[ dst>> allocations get conjoin ] [ call-next-method ] bi ;
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
@ -55,8 +56,8 @@ GENERIC: compute-live-vregs ( insn -- )
: (record-live) ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
dup live-vreg? [ drop ] [
[ live-vregs get adjoin ]
[ liveness-graph get at (record-live) ]
bi
] if

8
basis/compiler/cfg/def-use/def-use.factor
View File

@ -5,6 +5,8 @@ compiler.units fry generalizations generic kernel locals
namespaces quotations sequences sets slots words
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.rpo ;
FROM: namespaces => set ;
FROM: sets => members ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
@ -94,9 +96,9 @@ SYMBOLS: defs insns uses ;
cfg [| block |
block instructions>> [
dup ##phi?
[ inputs>> [ use conjoin-at ] assoc-each ]
[ uses-vregs [ block swap use conjoin-at ] each ]
[ inputs>> [ use adjoin-at ] assoc-each ]
[ uses-vregs [ block swap use adjoin-at ] each ]
if
] each
] each-basic-block
use [ keys ] assoc-map uses set ;
use [ members ] assoc-map uses set ;

3
basis/compiler/cfg/dominance/dominance.factor
View File

@ -3,6 +3,7 @@
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
compiler.cfg.rpo compiler.cfg.predecessors ;
FROM: namespaces => set ;
IN: compiler.cfg.dominance
! Reference:
@ -103,4 +104,4 @@ PRIVATE>
[ accum push ]
[ dom-children work-list push-all-front ] bi
] slurp-deque
accum ;
accum ;

1
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -13,6 +13,7 @@ compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.assignment
! This contains both active and inactive intervals; any interval

1
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -3,6 +3,7 @@
USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.debugger
: check-linear-scan ( live-intervals machine-registers -- )

3
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1,4 +1,3 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping strings strings.private classes layouts
@ -21,6 +20,8 @@ compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.debugger ;
FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.tests
check-allocation? on
check-numbering? on

16
basis/compiler/cfg/linearization/order/order.factor
View File

@ -2,8 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
fry math sets compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg.loop-detection compiler.cfg.predecessors ;
fry math compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg.loop-detection compiler.cfg.predecessors
sets hash-sets ;
FROM: namespaces => set ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
@ -12,16 +14,16 @@ IN: compiler.cfg.linearization.order
SYMBOLS: work-list loop-heads visited ;
: visited? ( bb -- ? ) visited get key? ;
: visited? ( bb -- ? ) visited get in? ;
: add-to-work-list ( bb -- )
dup visited get key? [ drop ] [
dup visited? [ drop ] [
work-list get push-back
] if ;
: init-linearization-order ( cfg -- )
<dlist> work-list set
H{ } clone visited set
HS{ } clone visited set
entry>> add-to-work-list ;
: (find-alternate-loop-head) ( bb -- bb' )
@ -58,7 +60,7 @@ SYMBOLS: work-list loop-heads visited ;
: process-block ( bb -- )
dup visited? [ drop ] [
[ , ]
[ visited get conjoin ]
[ visited get adjoin ]
[ sorted-successors [ process-successor ] each ]
tri
] if ;
@ -76,4 +78,4 @@ PRIVATE>
dup linear-order>> [ ] [
dup (linearization-order)
>>linear-order linear-order>>
] ?if ;
] ?if ;

3
basis/compiler/cfg/liveness/ssa/ssa.factor
View File

@ -4,6 +4,7 @@ USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities
compiler.cfg.predecessors ;
FROM: namespaces => set ;
IN: compiler.cfg.liveness.ssa
! TODO: merge with compiler.cfg.liveness
@ -59,4 +60,4 @@ SYMBOL: work-list
: live-in? ( vreg bb -- ? ) live-in key? ;
: live-out? ( vreg bb -- ? ) live-out key? ;
: live-out? ( vreg bb -- ? ) live-out key? ;

1
basis/compiler/cfg/loop-detection/loop-detection.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators deques dlists fry kernel
namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
FROM: namespaces => set ;
IN: compiler.cfg.loop-detection
TUPLE: natural-loop header index ends blocks ;

1
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -5,6 +5,7 @@ words sets combinators generalizations cpu.architecture compiler.units
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.def-use ;
FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )

1
basis/compiler/cfg/representations/representations.factor
View File

@ -15,6 +15,7 @@ compiler.cfg.utilities
compiler.cfg.loop-detection
compiler.cfg.renaming.functor
compiler.cfg.representations.preferred ;
FROM: namespaces => set ;
IN: compiler.cfg.representations
! Virtual register representation selection.

1
basis/compiler/cfg/rpo/rpo.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ;
FROM: namespaces => set ;
IN: compiler.cfg.rpo
SYMBOL: visited

3
basis/compiler/cfg/ssa/construction/construction.factor
View File

@ -12,6 +12,7 @@ compiler.cfg.instructions
compiler.cfg.renaming
compiler.cfg.renaming.functor
compiler.cfg.ssa.construction.tdmsc ;
FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction
! The phi placement algorithm is implemented in
@ -135,4 +136,4 @@ PRIVATE>
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
[ ]
} cleave ;
} cleave ;

3
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor
View File

@ -2,6 +2,7 @@ USING: accessors arrays compiler.cfg compiler.cfg.debugger
compiler.cfg.dominance compiler.cfg.predecessors
compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences
tools.test vectors sets ;
FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction.tdmsc.tests
: test-tdmsc ( -- )
@ -70,4 +71,4 @@ V{ } 7 test-bb
[ ] [ test-tdmsc ] unit-test
[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test
[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test

37
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
View File

@ -3,6 +3,7 @@
USING: accessors arrays assocs bit-arrays bit-sets fry
hashtables hints kernel locals math namespaces sequences sets
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction.tdmsc
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
@ -15,7 +16,7 @@ IN: compiler.cfg.ssa.construction.tdmsc
SYMBOLS: visited merge-sets levels again? ;
: init-merge-sets ( cfg -- )
post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
: compute-levels ( cfg -- )
0 over entry>> associate [
@ -29,15 +30,12 @@ SYMBOLS: visited merge-sets levels again? ;
: level ( bb -- n ) levels get at ; inline
: set-bit ( bit-array n -- )
[ t ] 2dip swap set-nth ;
: update-merge-set ( tmp to -- )
[ merge-sets get ] dip
'[
_
[ merge-sets get at bit-set-union ]
[ dupd number>> set-bit ]
[ merge-sets get at union ]
[ number>> over adjoin ]
bi
] change-at ;
@ -51,10 +49,10 @@ SYMBOLS: visited merge-sets levels again? ;
[ [ predecessors>> ] keep ] dip
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
: visited? ( pair -- ? ) visited get key? ;
: visited? ( pair -- ? ) visited get in? ;
: consistent? ( snode lnode -- ? )
[ merge-sets get at ] bi@ swap bit-set-subset? ;
[ merge-sets get at ] bi@ subset? ;
: (process-edge) ( from to -- )
f walk [
@ -65,7 +63,7 @@ SYMBOLS: visited merge-sets levels again? ;
: process-edge ( from to -- )
2dup 2array dup visited? [ 3drop ] [
visited get conjoin
visited get adjoin
(process-edge)
] if ;
@ -73,7 +71,7 @@ SYMBOLS: visited merge-sets levels again? ;
[ process-edge ] each-incoming-j-edge ;
: compute-merge-set-step ( bfo -- )
visited get clear-assoc
HS{ } clone visited set
[ process-block ] each ;
: compute-merge-set-loop ( cfg -- )
@ -82,29 +80,22 @@ SYMBOLS: visited merge-sets levels again? ;
loop ;
: (merge-set) ( bbs -- flags rpo )
merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
merge-sets get '[ _ at ] [ union ] map-reduce
cfg get reverse-post-order ; inline
: filter-by ( flags seq -- seq' )
[ drop ] selector [ 2each ] dip ;
HINTS: filter-by { bit-array object } ;
PRIVATE>
: compute-merge-sets ( cfg -- )
needs-dominance
H{ } clone visited set
HS{ } clone visited set
[ compute-levels ]
[ init-merge-sets ]
[ compute-merge-set-loop ]
tri ;
: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
[ (merge-set) ] dip '[
swap _ [ drop ] if
] 2each ; inline
: merge-set ( bbs -- bbs' )
(merge-set) filter-by ;
(merge-set) [ members ] dip nths ;
: merge-set-each ( bbs quot: ( bb -- ) -- )
[ merge-set ] dip each ; inline

1
basis/compiler/cfg/ssa/destruction/destruction.factor
View File

@ -15,6 +15,7 @@ compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges
compiler.cfg.utilities
compiler.utilities ;
FROM: namespaces => set ;
IN: compiler.cfg.ssa.destruction
! Maps vregs to leaders.

1
basis/compiler/cfg/ssa/liveness/liveness.factor
View File

@ -6,6 +6,7 @@ compiler.cfg.rpo
compiler.cfg.dominance
compiler.cfg.def-use
compiler.cfg.instructions ;
FROM: namespaces => set ;
IN: compiler.cfg.ssa.liveness
! Liveness checking on SSA IR, as described in

3
basis/compiler/cfg/stacks/local/local.factor
View File

@ -8,6 +8,7 @@ compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.stacks.height
compiler.cfg.parallel-copy ;
FROM: namespaces => set ;
IN: compiler.cfg.stacks.local
! Local stack analysis. We build three sets for every basic block
@ -106,4 +107,4 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;
: kill-set ( bb -- assoc ) kill-sets get at ;
: kill-set ( bb -- assoc ) kill-sets get at ;

1
basis/compiler/cfg/write-barrier/write-barrier.factor
View File

@ -3,6 +3,7 @@
USING: accessors assocs combinators.short-circuit
compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
sequences sets ;
FROM: namespaces => set ;
IN: compiler.cfg.write-barrier
SYMBOL: fresh-allocations

1
basis/compiler/codegen/codegen.factor
View File

@ -16,6 +16,7 @@ compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
FROM: namespaces => set ;
IN: compiler.codegen
SYMBOL: insn-counts

1
basis/compiler/tree/checker/checker.factor
View File

@ -7,6 +7,7 @@ compiler.tree
compiler.tree.def-use
compiler.tree.recursive
compiler.tree.combinators ;
FROM: namespaces => set ;
IN: compiler.tree.checker
! Check some invariants; this can help catch compiler bugs.

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

@ -4,6 +4,7 @@ USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
stack-checker.branches compiler.tree compiler.tree.combinators
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
FROM: namespaces => set ;
IN: compiler.tree.dead-code.branches
M: #if mark-live-values* look-at-inputs ;

1
basis/compiler/tree/dead-code/liveness/liveness.factor
View File

@ -4,6 +4,7 @@ USING: fry accessors namespaces assocs deques search-deques
dlists kernel sequences compiler.utilities words sets
stack-checker.branches compiler.tree compiler.tree.def-use
compiler.tree.combinators ;
FROM: namespaces => set ;
IN: compiler.tree.dead-code.liveness
SYMBOL: work-list

4
basis/compiler/tree/def-use/def-use.factor
View File

@ -6,6 +6,8 @@ stack-checker.state
stack-checker.branches
compiler.tree
compiler.tree.combinators ;
FROM: namespaces => set ;
FROM: sets => members ;
IN: compiler.tree.def-use
SYMBOL: def-use
@ -42,7 +44,7 @@ GENERIC: node-uses-values ( node -- values )
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom members ;
M: #declare node-uses-values drop f ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;

1
basis/compiler/tree/def-use/simplified/simplified.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel fry vectors accessors namespaces assocs sets
stack-checker.branches compiler.tree compiler.tree.def-use ;
FROM: namespaces => set ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.

1
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.values ;
FROM: namespaces => set ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to classes. Only for #introduce outputs

1
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

@ -9,6 +9,7 @@ compiler.tree.propagation.info
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
FROM: namespaces => set ;
IN: compiler.tree.modular-arithmetic
! This is a late-stage optimization.

12
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -9,6 +9,7 @@ vectors hashtables combinators effects generalizations assocs
sets combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
FROM: math => float ;
FROM: sets => set ;
IN: compiler.tree.propagation.transforms
\ equal? [
@ -134,6 +135,7 @@ IN: compiler.tree.propagation.transforms
in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] }
{ H{ } [ [ drop 0 <hashtable> ] ] }
{ HS{ } [ [ drop f fast-set ] ] }
[ drop f ]
} case
] "custom-inlining" set-word-prop
@ -207,7 +209,7 @@ ERROR: bad-partial-eval quot word ;
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
] [
unique [ key? ] curry
tester
] if ;
\ member? [
@ -272,14 +274,14 @@ CONSTANT: lookup-table-at-max 256
\ at* [ at-quot ] 1 define-partial-eval
: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
tester '[ [ @ not ] filter ] ;
tester '[ [ [ @ not ] filter ] keep set-like ] ;
\ diff [ diff-quot ] 1 define-partial-eval
M\ set diff [ diff-quot ] 1 define-partial-eval
: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
tester '[ _ filter ] ;
tester '[ [ _ filter ] keep set-like ] ;
\ intersect [ intersect-quot ] 1 define-partial-eval
M\ set intersect [ intersect-quot ] 1 define-partial-eval
: fixnum-bits ( -- n )
cell-bits tag-bits get - ;

1
basis/compiler/tree/recursive/recursive.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs arrays namespaces accessors sequences deques fry
search-deques dlists combinators.short-circuit make sets compiler.tree ;
FROM: namespaces => set ;
IN: compiler.tree.recursive
TUPLE: call-site tail? node label ;

1
basis/farkup/farkup.factor
View File

@ -4,6 +4,7 @@ USING: sequences kernel splitting lists fry accessors assocs math.order
math combinators namespaces urls.encoding xml.syntax xmode.code2html
xml.data arrays strings vectors xml.writer io.streams.string locals
unicode.categories ;
FROM: namespaces => set ;
IN: farkup
SYMBOL: relative-link-prefix

1
basis/furnace/auth/auth.factor
View File

@ -15,6 +15,7 @@ furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
FROM: assocs => change-at ;
FROM: namespaces => set ;
IN: furnace.auth
SYMBOL: logged-in-user

2
basis/help/crossref/crossref-tests.factor
View File

@ -62,4 +62,4 @@ ARTICLE: "crossref-test-1" "Crossref test 1"
ARTICLE: "crossref-test-2" "Crossref test 2"
{ $markup-example { $subsection "crossref-test-1" } } ;
[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test
[ { } ] [ "crossref-test-2" >link article-children ] unit-test

1
basis/help/handbook/handbook.factor
View File

@ -166,6 +166,7 @@ ARTICLE: "collections" "Collections"
}
{ $heading "Other collections" }
{ $subsections
"sets"
"lists"
"disjoint-sets"
"interval-maps"

5
basis/help/lint/checks/checks.factor
View File

@ -6,6 +6,7 @@ help help.markup help.topics io.streams.string kernel macros
namespaces sequences sequences.deep sets sorting splitting
strings unicode.categories values vocabs vocabs.loader words
words.symbol summary debugger io ;
FROM: sets => members ;
IN: help.lint.checks
ERROR: simple-lint-error message ;
@ -48,7 +49,7 @@ SYMBOL: vocab-articles
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ dup pair? [ first ] when effect>string ] map prune ;
[ dup pair? [ first ] when effect>string ] map members ;
: effect-effects ( word -- seq )
stack-effect in>> [
@ -103,7 +104,7 @@ SYMBOL: vocab-articles
: check-see-also ( element -- )
\ $see-also swap elements [
rest dup prune [ length ] bi@ assert=
rest all-unique? t assert=
] each ;
: vocab-exists? ( name -- ? )

3
basis/help/markup/markup.factor
View File

@ -8,6 +8,7 @@ prettyprint.stylesheet quotations see sequences sets slots
sorting splitting strings vectors vocabs vocabs.loader words
words.symbol ;
FROM: prettyprint.sections => with-pprint ;
FROM: namespaces => set ;
IN: help.markup
PREDICATE: simple-element < array
@ -441,7 +442,7 @@ M: array elements*
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
: collect-elements ( element seq -- elements )
swap '[ _ elements [ rest ] map concat ] map concat prune ;
swap '[ _ elements [ rest ] map concat ] gather ;
: <$link> ( topic -- element )
1array \ $link prefix ;

1
basis/inspector/inspector.factor
View File

@ -5,6 +5,7 @@ namespaces prettyprint prettyprint.custom prettyprint.sections
sequences strings io.styles vectors words quotations mirrors
splitting math.parser classes vocabs sets sorting summary
debugger continuations fry combinators ;
FROM: namespaces => set ;
IN: inspector
SYMBOL: +number-rows+

2
basis/io/monitors/linux/linux.factor
View File

@ -81,7 +81,7 @@ M: linux-monitor dispose* ( monitor -- )
IN_MOVED_FROM +rename-file-old+ ?flag
IN_MOVED_TO +rename-file-new+ ?flag
drop
] { } make prune ;
] { } make members ;
: parse-event-name ( event -- name )
dup len>> zero?

4
basis/locals/rewrite/closures/closures.factor
View File

@ -18,7 +18,7 @@ GENERIC: rewrite-closures* ( obj -- )
GENERIC: defs-vars* ( seq form -- seq' )
: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce prune ;
: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce members ;
M: def defs-vars* local>> unquote suffix ;
@ -28,7 +28,7 @@ M: object defs-vars* drop ;
GENERIC: uses-vars* ( seq form -- seq' )
: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce prune ;
: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce members ;
M: local-writer uses-vars* "local-reader" word-prop suffix ;

2
basis/math/ranges/ranges-tests.factor
View File

@ -23,5 +23,5 @@ IN: math.ranges.tests
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
[ 100 ] [
1 100 [a,b] [ 2^ [1,b] ] map prune length
1 100 [a,b] [ 2^ [1,b] ] map members length
] unit-test

1
basis/peg/peg.factor
View File

@ -5,6 +5,7 @@ io vectors arrays math.parser math.order combinators classes
sets unicode.categories compiler.units parser effects.parser
words quotations memoize accessors locals splitting
combinators.short-circuit generalizations ;
FROM: namespaces => set ;
IN: peg
TUPLE: parse-result remaining ast ;

6
basis/prettyprint/backend/backend.factor
View File

@ -6,7 +6,8 @@ combinators continuations effects generic hashtables io
io.pathnames io.styles kernel make math math.order math.parser
namespaces prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.stylesheet quotations sbufs
sequences strings vectors words words.symbol ;
sequences strings vectors words words.symbol hash-sets ;
FROM: sets => members ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -187,6 +188,7 @@ M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
M: wrapper pprint-delims drop \ W{ \ } ;
M: callstack pprint-delims drop \ CS{ \ } ;
M: hash-set pprint-delims drop \ HS{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
@ -195,6 +197,7 @@ M: callable >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
M: hash-set >pprint-sequence members ;
: class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
@ -226,6 +229,7 @@ M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
M: wrapper pprint*
{

1
basis/prettyprint/prettyprint.factor
View File

@ -5,6 +5,7 @@ io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
vocabs.prettyprint words sets generic ;
FROM: namespaces => set ;
IN: prettyprint
: with-use ( obj quot -- )

1
basis/prettyprint/sections/sections.factor
View File

@ -4,6 +4,7 @@ USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
accessors sets vocabs.parser combinators vocabs ;
FROM: namespaces => set ;
IN: prettyprint.sections
! State

6
basis/random/random-tests.factor
View File

@ -14,7 +14,7 @@ IN: random.tests
[ t ] [ 10000 [ iota 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
[ t ] [ 10000 [ iota 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
[ t ] [ 1000 [ 400 random ] replicate members length 256 > ] unit-test
[ f ] [ 0 random ] unit-test
@ -28,8 +28,8 @@ IN: random.tests
[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
[ 99 ] [ 100 iota 99 sample prune length ] unit-test
[ 3 ] [ { 1 2 3 4 } 3 sample members length ] unit-test
[ 99 ] [ 100 iota 99 sample members length ] unit-test
[ ]
[ [ 100 random-bytes ] with-system-random drop ] unit-test

2
basis/regexp/classes/classes-tests.factor
View File

@ -36,7 +36,7 @@ IN: regexp.classes.tests
! Making classes into nested conditionals
[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test

9
basis/regexp/classes/classes.factor
View File

@ -5,6 +5,7 @@ unicode.categories combinators.short-circuit sequences
fry macros arrays assocs sets classes mirrors unicode.script
unicode.data ;
FROM: ascii => ascii? ;
FROM: sets => members ;
IN: regexp.classes
SINGLETONS: dot letter-class LETTER-class Letter-class digit-class
@ -157,7 +158,7 @@ DEFER: substitute
TUPLE: class-partition integers not-integers simples not-simples and or other ;
: partition-classes ( seq -- class-partition )
prune
members
[ integer? ] partition
[ not-integer? ] partition
[ simple-class? ] partition
@ -194,7 +195,7 @@ TUPLE: class-partition integers not-integers simples not-simples and or other ;
[ t swap remove ] change-other
dup contradiction?
[ drop f ]
[ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ;
[ filter-not-integers class-partition>seq members t and-class seq>instance ] if ;
: <and-class> ( seq -- class )
dup and-class flatten partition-classes
@ -225,7 +226,7 @@ TUPLE: class-partition integers not-integers simples not-simples and or other ;
[ f swap remove ] change-other
dup tautology?
[ drop t ]
[ filter-integers class-partition>seq prune f or-class seq>instance ] if ;
[ filter-integers class-partition>seq members f or-class seq>instance ] if ;
: <or-class> ( seq -- class )
dup or-class flatten partition-classes
@ -329,7 +330,7 @@ M: object class>questions 1array ;
: condition-states ( condition -- states )
dup condition? [
[ yes>> ] [ no>> ] bi
[ condition-states ] bi@ append prune
[ condition-states ] bi@ union
] [ 1array ] if ;
: condition-at ( condition assoc -- new-condition )

4
basis/regexp/compiler/compiler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.classes kernel sequences regexp.negation
quotations assocs fry math locals combinators
quotations assocs fry math locals combinators sets
accessors words compiler.units kernel.private strings
sequences.private arrays namespaces unicode.breaks
regexp.transition-tables combinators.short-circuit ;
@ -106,7 +106,7 @@ C: <box> box
: word>quot ( word dfa -- quot )
[ transitions>> at ]
[ final-states>> key? ] 2bi
[ final-states>> in? ] 2bi
transitions>quot ;
: states>code ( words dfa -- )

4
basis/regexp/dfa/dfa.factor
View File

@ -69,10 +69,10 @@ IN: regexp.dfa
: set-final-states ( nfa dfa -- )
[
[ final-states>> keys ]
[ final-states>> members ]
[ transitions>> keys ] bi*
[ intersects? ] with filter
unique
fast-set
] keep (>>final-states) ;
: initialize-dfa ( nfa -- dfa )

4
basis/regexp/minimize/minimize-tests.factor
View File

@ -34,7 +34,7 @@ IN: regexp.minimize.tests
{ 3 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 3 3 } } }
{ final-states HS{ 3 } }
}
] [
T{ transition-table
@ -48,7 +48,7 @@ IN: regexp.minimize.tests
{ 6 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 3 3 } { 6 6 } } }
{ final-states HS{ 3 6 } }
} combine-states
] unit-test

2
basis/regexp/minimize/minimize.factor
View File

@ -19,7 +19,7 @@ IN: regexp.minimize
{
[ drop <= ]
[ transitions>> '[ _ at keys ] bi@ set= ]
[ final-states>> '[ _ key? ] bi@ = ]
[ final-states>> '[ _ in? ] bi@ = ]
} 3&& ;
:: initialize-partitions ( transition-table -- partitions )

4
basis/regexp/negation/negation-tests.factor
View File

@ -12,7 +12,7 @@ IN: regexp.negation.tests
{ -1 H{ { t -1 } } }
} }
{ start-state 0 }
{ final-states H{ { 0 0 } { -1 -1 } } }
{ final-states HS{ 0 -1 } }
}
] [
! R/ a/
@ -22,6 +22,6 @@ IN: regexp.negation.tests
{ 1 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 1 1 } } }
{ final-states HS{ 1 } }
} negate-table
] unit-test

10
basis/regexp/negation/negation.factor
View File

@ -3,7 +3,7 @@
USING: regexp.nfa regexp.disambiguate kernel sequences
assocs regexp.classes hashtables accessors fry vectors
regexp.ast regexp.transition-tables regexp.minimize
regexp.dfa namespaces ;
regexp.dfa namespaces sets ;
IN: regexp.negation
CONSTANT: fail-state -1
@ -21,7 +21,7 @@ CONSTANT: fail-state -1
fail-state-recurses ;
: inverse-final-states ( transition-table -- final-states )
[ transitions>> assoc>set ] [ final-states>> ] bi assoc-diff ;
[ transitions>> keys ] [ final-states>> ] bi diff fast-set ;
: negate-table ( transition-table -- transition-table )
clone
@ -36,14 +36,14 @@ CONSTANT: fail-state -1
[ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
: unify-final-state ( transition-table -- transition-table )
dup [ final-states>> keys ] keep
dup [ final-states>> members ] keep
'[ -2 epsilon _ set-transition ] each
H{ { -2 -2 } } >>final-states ;
HS{ -2 } clone >>final-states ;
: adjoin-dfa ( transition-table -- start end )
unify-final-state renumber-states box-transitions
[ start-state>> ]
[ final-states>> keys first ]
[ final-states>> members first ]
[ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
: ast>dfa ( parse-tree -- minimal-dfa )

3
basis/regexp/nfa/nfa.factor
View File

@ -5,6 +5,7 @@ sequences fry quotations math.order math.ranges vectors
unicode.categories regexp.transition-tables words sets hashtables
combinators.short-circuit unicode.data regexp.ast
regexp.classes memoize ;
FROM: namespaces => set ;
IN: regexp.nfa
! This uses unicode.data for ch>upper and ch>lower
@ -162,6 +163,6 @@ M: with-options nfa-node ( node -- start end )
<transition-table> nfa-table set
nfa-node
nfa-table get
swap dup associate >>final-states
swap 1array fast-set >>final-states
swap >>start-state
] with-scope ;

2
basis/regexp/parser/parser.factor
View File

@ -27,7 +27,7 @@ ERROR: bad-class name ;
[ [ simple ] keep ] H{ } map>assoc ;
MEMO: simple-script-table ( -- table )
script-table interval-values prune simple-table ;
script-table interval-values members simple-table ;
MEMO: simple-category-table ( -- table )
categories simple-table ;

8
basis/regexp/transition-tables/transition-tables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel sequences
vectors locals regexp.classes ;
vectors locals regexp.classes sets ;
IN: regexp.transition-tables
TUPLE: transition-table transitions start-state final-states ;
@ -9,7 +9,7 @@ TUPLE: transition-table transitions start-state final-states ;
: <transition-table> ( -- transition-table )
transition-table new
H{ } clone >>transitions
H{ } clone >>final-states ;
HS{ } clone >>final-states ;
:: (set-transition) ( from to obj hash -- )
from hash at
@ -27,8 +27,8 @@ TUPLE: transition-table transitions start-state final-states ;
: add-transition ( from to obj transition-table -- )
transitions>> (add-transition) ;
: map-set ( assoc quot -- new-assoc )
'[ drop @ dup ] assoc-map ; inline
: map-set ( set quot -- new-set )
over [ [ members ] dip map ] dip set-like ; inline
: number-transitions ( transitions numbering -- new-transitions )
dup '[

5
basis/see/see.factor
View File

@ -8,6 +8,9 @@ io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary words
words.symbol words.constant words.alias vocabs slots ;
FROM: namespaces => set ;
FROM: classes => members ;
RENAME: members sets => set-members
IN: see
GENERIC: synopsis* ( defspec -- )
@ -237,7 +240,7 @@ PRIVATE>
dup class? [ dup seeing-implementors % ] when
dup generic? [ dup seeing-methods % ] when
drop
] { } make prune ;
] { } make set-members ;
: see-methods ( word -- )
methods see-all nl ;

2
basis/simple-flat-file/simple-flat-file.factor
View File

@ -47,7 +47,7 @@ SYMBOL: interned
] { } make <interval-map> ;
: process-interval-file ( ranges -- table )
dup values prune interned
dup values members interned
[ expand-ranges ] with-variable ;
: load-interval-file ( filename -- table )

1
basis/smtp/smtp.factor
View File

@ -7,6 +7,7 @@ io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
kernel logging sequences combinators splitting assocs strings
math.order math.parser random system calendar summary calendar.format
accessors sets hashtables base64 debugger classes prettyprint words ;
FROM: namespaces => set ;
IN: smtp
SYMBOL: smtp-domain

1
basis/stack-checker/backend/backend.factor
View File

@ -7,6 +7,7 @@ definitions locals sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state stack-checker.dependencies summary ;
FROM: sequences.private => from-end ;
FROM: namespaces => set ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;

1
basis/stack-checker/dependencies/dependencies.factor
View File

@ -5,6 +5,7 @@ generic kernel math namespaces sequences words sets
combinators.short-circuit classes.tuple alien.c-types ;
FROM: classes.tuple.private => tuple-layout ;
FROM: assocs => change-at ;
FROM: namespaces => set ;
IN: stack-checker.dependencies
! Words that the current quotation depends on

1
basis/stack-checker/transforms/transforms.factor
View File

@ -9,6 +9,7 @@ sequences.private generalizations stack-checker.backend
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state
stack-checker.dependencies ;
FROM: namespaces => set ;
IN: stack-checker.transforms
: call-transformer ( stack quot -- newquot )

12
basis/suffix-arrays/suffix-arrays-tests.factor
View File

@ -25,14 +25,14 @@ IN: suffix-arrays.tests
[ { } ]
[ SA{ } "something" swap query ] unit-test
[ V{ "unit-test" "(unit-test)" } ]
[ { "unit-test" "(unit-test)" } ]
[ "suffix-array" get "unit-test" swap query ] unit-test
[ t ]
[ "suffix-array" get "something else" swap query empty? ] unit-test
[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
[ { "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
[ { "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
[ { "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
[ { "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
[ { } ] [ SA{ "rofl" } "t" swap query ] unit-test

2
basis/suffix-arrays/suffix-arrays.factor
View File

@ -35,5 +35,5 @@ SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ;
: query ( begin suffix-array -- matches )
2dup find-index dup
[ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
[ -rot [ from-to ] keep <funky-slice> [ seq>> ] map members ]
[ 3drop { } ] if ;

4
basis/tools/deploy/shaker/shaker.factor
View File

@ -20,6 +20,8 @@ QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
FROM: alien.libraries.private => >deployed-library-path ;
FROM: namespaces => set ;
FROM: sets => members ;
IN: tools.deploy.shaker
! This file is some hairy shit.
@ -506,7 +508,7 @@ SYMBOL: deploy-vocab
: write-vocab-manifest ( vocab-manifest-out -- )
"Writing vocabulary manifest to " write dup print flush
vocabs "VOCABS:" prefix
deploy-libraries get [ libraries get at path>> ] map prune "LIBRARIES:" prefix append
deploy-libraries get [ libraries get at path>> ] map members "LIBRARIES:" prefix append
swap utf8 set-file-lines ;
: prepare-deploy-libraries ( -- )

3
basis/tools/profiler/profiler.factor
View File

@ -5,6 +5,7 @@ io io.styles namespaces assocs kernel.private strings
combinators sorting math.parser vocabs definitions
tools.profiler.private tools.crossref continuations generic
compiler.units compiler.crossref sets classes fry ;
FROM: sets => members ;
IN: tools.profiler
: profile ( quot -- )
@ -41,7 +42,7 @@ IN: tools.profiler
[ smart-usage [ word? ] filter ]
[ generic-call-sites-of keys ]
[ effect-dependencies-of keys ]
tri 3append prune ;
tri 3append members ;
: usage-counters ( word -- alist )
profiler-usage counters ;

9
basis/ui/gadgets/gadgets-tests.factor
View File

@ -2,6 +2,7 @@ USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
tools.test namespaces models kernel dlists deques math
math.parser ui sequences hashtables assocs io arrays prettyprint
io.streams.string math.rectangles ui.gadgets.private sets generic ;
FROM: namespaces => set ;
IN: ui.gadgets.tests
[ { 300 300 } ]
@ -126,16 +127,16 @@ M: mock-gadget ungraft*
] each-integer ;
: status-flags ( -- seq )
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
{ "g" "1" "2" "3" } [ get graft-state>> ] map members ;
: notify-combo ( ? ? -- )
nl "===== Combo: " write 2dup 2array . nl
<dlist> \ graft-queue [
<mock-gadget> "g" set
[ ] [ add-some-children ] unit-test
[ V{ { f f } } ] [ status-flags ] unit-test
[ { { f f } } ] [ status-flags ] unit-test
[ ] [ "g" get graft ] unit-test
[ V{ { f t } } ] [ status-flags ] unit-test
[ { { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
[ [ t ] [ graft-queue [ front>> ] [ back>> ] bi eq? ] unit-test ] unless
@ -146,7 +147,7 @@ M: mock-gadget ungraft*
[ { f t } ] [ "3" get graft-state>> ] unit-test
[ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test
[ { { t t } } ] [ status-flags ] unit-test
] with-variable ;
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each

4
basis/ui/gestures/gestures.factor
View File

@ -5,6 +5,8 @@ namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ;
FROM: namespaces => set ;
FROM: sets => members ;
IN: ui.gestures
: get-gesture-handler ( gesture gadget -- quot )
@ -234,7 +236,7 @@ SYMBOL: drag-timer
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] with filter
0 <column> prune [ f ] [ >array ] if-empty ;
0 <column> members [ f ] [ >array ] if-empty ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;

1
basis/ui/tools/listener/listener.factor
View File

@ -16,6 +16,7 @@ ui.tools.listener.completion ui.tools.listener.popups
ui.tools.listener.history ui.images ui.tools.error-list
tools.errors.model ;
FROM: source-files.errors => all-errors ;
FROM: namespaces => set ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking

2
basis/ui/ui.factor
View File

@ -138,7 +138,7 @@ M: world ungraft*
layout-queue [
dup layout find-world [ , ] when*
] slurp-deque
] { } make prune ;
] { } make members ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;

3
basis/unicode/data/data.factor
View File

@ -6,6 +6,7 @@ math.parser hash2 math.order byte-arrays namespaces
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 memoize simple-flat-file ;
FROM: namespaces => set ;
IN: unicode.data
<PRIVATE
@ -183,7 +184,7 @@ C: <code-point> code-point
] assoc-map ;
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
dup values members [ f ] H{ } map>assoc
[ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;

4
basis/vocabs/hierarchy/hierarchy.factor
View File

@ -65,8 +65,8 @@ PRIVATE>
#! Hack.
[ vocab-prefix? ] partition
[
[ vocab-name ] map unique
'[ name>> _ key? not ] filter
[ vocab-name ] map fast-set
'[ name>> _ in? not ] filter
convert-prefixes
] keep
append ;

2
basis/vocabs/metadata/metadata.factor
View File

@ -73,7 +73,7 @@ M: vocab-link summary vocab-summary ;
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
[ vocab-tags append members ] keep set-vocab-tags ;
: remove-vocab-tags ( tags vocab -- )
[ vocab-tags swap diff ] keep set-vocab-tags ;

2
basis/vocabs/refresh/monitor/monitor.factor
View File

@ -39,7 +39,7 @@ TR: convert-separators "/\\" ".." ;
: monitor-thread ( -- )
[
[
vocab-roots get prune [ add-monitor-for-path ] each
vocab-roots get [ add-monitor-for-path ] each
H{ } clone changed-vocabs set-global
vocabs [ changed-vocab ] each

5
basis/vocabs/refresh/refresh.factor
View File

@ -3,6 +3,7 @@
USING: accessors assocs checksums checksums.crc32
io.encodings.utf8 io.files kernel namespaces sequences sets
source-files vocabs vocabs.errors vocabs.loader ;
FROM: namespaces => set ;
IN: vocabs.refresh
: source-modified? ( path -- ? )
@ -81,11 +82,11 @@ SYMBOL: modified-docs
[ [ vocab f >>docs-loaded? drop ] each ] bi*
]
[
append prune
union
[ unchanged-vocabs ]
[ require-all load-failures. ] bi
] 2bi ;
: refresh ( prefix -- ) to-refresh do-refresh ;
: refresh-all ( -- ) "" refresh ;
: refresh-all ( -- ) "" refresh ;

1
basis/xml/elements/elements.factor
View File

@ -4,6 +4,7 @@ USING: kernel namespaces xml.tokenize xml.state xml.name
xml.data accessors arrays make xml.char-classes fry assocs sequences
math xml.errors sets combinators io.encodings io.encodings.iana
unicode.case xml.dtd strings xml.entities unicode.categories ;
FROM: namespaces => set ;
IN: xml.elements
: take-interpolated ( quot -- interpolated )

2
basis/xmode/keyword-map/keyword-map.factor
View File

@ -32,7 +32,7 @@ M: keyword-map >alist
assoc>> >alist ;
: (keyword-map-no-word-sep) ( assoc -- str )
keys concat [ alpha? not ] filter prune natural-sort ;
keys combine [ alpha? not ] filter natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str )
dup no-word-sep>> [ ] [

3
core/alien/alien-tests.factor
View File

@ -1,6 +1,7 @@
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts alien.libraries sets ;
FROM: namespaces => set ;
IN: alien.tests
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
@ -83,4 +84,4 @@ f initialize-test set-global
[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test
[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } members ] unit-test

1
core/bootstrap/syntax.factor
View File

@ -29,6 +29,7 @@ IN: bootstrap.syntax
"HEX:"
"HOOK:"
"H{"
"HS{"
"IN:"
"INSTANCE:"
"M:"

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

@ -3,6 +3,8 @@
USING: kernel classes classes.private combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
FROM: classes => members ;
RENAME: members sets => set-members
IN: classes.algebra
<PRIVATE
@ -10,13 +12,14 @@ IN: classes.algebra
TUPLE: anonymous-union { members read-only } ;
: <anonymous-union> ( members -- class )
[ null eq? not ] filter prune
[ null eq? not ] filter set-members
dup length 1 = [ first ] [ anonymous-union boa ] if ;
TUPLE: anonymous-intersection { participants read-only } ;
: <anonymous-intersection> ( participants -- class )
prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
set-members dup length 1 =
[ first ] [ anonymous-intersection boa ] if ;
TUPLE: anonymous-complement { class read-only } ;

1
core/classes/classes.factor
View File

@ -4,6 +4,7 @@ USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces make sequences strings words words.symbol
vectors math quotations combinators sorting effects graphs
vocabs sets ;
FROM: namespaces => set ;
IN: classes
ERROR: bad-inheritance class superclass ;

2
core/combinators/combinators.factor
View File

@ -147,7 +147,7 @@ ERROR: no-case object ;
: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
[ prune length ]
[ length ]
[ [ supremum ] [ infimum ] bi - ]
bi - 1 =
] [ drop f ] if

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

@ -4,6 +4,7 @@ USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets math
math.order classes classes.private classes.algebra classes.tuple
classes.tuple.private generic source-files.errors kernel.private ;
FROM: namespaces => set ;
IN: compiler.units
SYMBOL: old-definitions

1
core/destructors/destructors.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel namespaces make
sequences vectors sets assocs init math ;
FROM: namespaces => set ;
IN: destructors
SYMBOL: disposables

1
core/generic/generic.factor
View File

@ -4,6 +4,7 @@ USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
sets ;
FROM: namespaces => set ;
IN: generic
! Method combination protocol

1
core/generic/single/single-tests.factor
View File

@ -5,6 +5,7 @@ quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
QUALIFIED-WITH: alien.c-types c
FROM: namespaces => set ;
SPECIALIZED-VECTOR: c:double
IN: generic.single.tests

18
core/hash-sets/hash-sets-docs.factor Normal file
View File

@ -0,0 +1,18 @@
USING: help.markup help.syntax sequences ;
IN: hash-sets
ARTICLE: "hash-sets" "Hash sets"
"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. These are of the class:"
{ $subsection hash-set }
"They can be instantiated with the word"
{ $subsection <hash-set> }
"The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ;
ABOUT: "hash-sets"
HELP: hash-set
{ $class-description "The class of hashtable-based sets. These implement the " { $link "sets" } "." } ;
HELP: <hash-set>
{ $values { "members" sequence } { "hash-set" hash-set } }
{ $description "Creates a new hash set with the given members." } ;

33
core/hash-sets/hash-sets-tests.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sets tools.test kernel sorting prettyprint hash-sets ;
IN: hash-sets.tests
[ { 1 2 3 } ] [ HS{ 1 2 3 } members natural-sort ] unit-test
[ "HS{ 1 2 3 4 }" ] [ HS{ 1 2 3 4 } unparse ] unit-test
[ t ] [ 1 HS{ 0 1 2 } in? ] unit-test
[ f ] [ 3 HS{ 0 1 2 } in? ] unit-test
[ HS{ 1 2 3 } ] [ 3 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
[ HS{ 1 2 } ] [ 2 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
[ HS{ 1 2 3 } ] [ 4 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
[ HS{ 1 2 } ] [ 3 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
[ HS{ 1 2 } ] [ HS{ 1 2 } fast-set ] unit-test
[ { 1 2 } ] [ HS{ 1 2 } members natural-sort ] unit-test
[ HS{ 1 2 3 4 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } union ] unit-test
[ HS{ 2 3 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersect ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersects? ] unit-test
[ f ] [ HS{ 1 } HS{ 2 3 4 } intersects? ] unit-test
[ f ] [ HS{ 1 } HS{ 2 3 4 } subset? ] unit-test
[ f ] [ HS{ 1 2 3 } HS{ 2 3 4 } subset? ] unit-test
[ t ] [ HS{ 2 3 } HS{ 2 3 4 } subset? ] unit-test
[ t ] [ HS{ } HS{ 2 3 4 } subset? ] unit-test
[ HS{ 1 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } diff ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } set= ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } = ] unit-test
[ f ] [ HS{ 2 3 } HS{ 2 1 3 } set= ] unit-test
[ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
[ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test

28
core/hash-sets/hash-sets.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs hashtables kernel sets
sequences parser ;
QUALIFIED: sets
IN: hash-sets
! In a better implementation, less memory would be used
TUPLE: hash-set { table hashtable read-only } ;
: <hash-set> ( members -- hash-set )
[ dup ] H{ } map>assoc hash-set boa ;
INSTANCE: hash-set set
M: hash-set in? table>> key? ; inline
M: hash-set adjoin table>> dupd set-at ; inline
M: hash-set delete table>> delete-at ; inline
M: hash-set members table>> keys ; inline
M: hash-set set-like
drop dup hash-set? [ members <hash-set> ] unless ;
M: hash-set clone
table>> clone hash-set boa ;
M: sequence fast-set <hash-set> ;
M: f fast-set drop H{ } clone hash-set boa ;
M: sequence duplicates
HS{ } clone [ [ in? ] [ adjoin ] 2bi ] curry filter ;

165
core/sets/sets-docs.factor
View File

@ -1,42 +1,71 @@
USING: assocs hashtables help.markup help.syntax kernel
quotations sequences ;
quotations sequences vectors ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
$nl
"Remove duplicates:"
{ $subsections prune }
"Test for duplicates:"
ARTICLE: "sets" "Sets"
"A set is an unordered list of elements. Words for working with sets are in the " { $vocab-link "sets" } " vocabulary."
"All sets are instances of a mixin class:"
{ $subsections
all-unique?
duplicates
set
set?
}
"Set operations on sequences:"
{ $subsections "set-operations" "set-implementations" } ;
ABOUT: "sets"
ARTICLE: "set-operations" "Operations on sets"
"To test if an object is a member of a set:"
{ $subsection member? }
"All sets can be represented as a sequence, without duplicates, of their members:"
{ $subsection members }
"Sets can have members added or removed destructively:"
{ $subsections
adjoin
delete
}
"Basic mathematical operations, which any type of set may override for efficiency:"
{ $subsections
diff
intersect
union
}
"Set-theoretic predicates:"
"Mathematical predicates on sets, which may be overridden for efficiency:"
{ $subsections
intersects?
subset?
set=
}
"A word used to implement the above:"
{ $subsections unique }
"Adding elements to sets:"
"An optional generic word for creating sets of the same class as a given set:"
{ $subsection set-like }
"An optional generic word for creating a set with a fast lookup operation, if the set itself has a slow lookup operation:"
{ $subsection fast-set }
"For set types that allow duplicates, like sequence sets, some additional words test for duplication:"
{ $subsections
adjoin
}
{ $see-also member? member-eq? any? all? "assocs-sets" } ;
all-unique?
duplicates
} ;
ABOUT: "sets"
ARTICLE: "set-implementations" "Set implementations"
"There are several implementations of sets in the Factor library. More can be added if they implement the words of the set protocol, the basic set operations."
{ $subsections
"sequence-sets"
"hash-sets"
"bit-sets"
} ;
ARTICLE: "sequence-sets" "Sequences as sets"
"Any sequence can be used as a set. The members of this set are the elements of the sequence. Calling the word " { $link members } " on a sequence returns a copy of the sequence with only one listing of each member. Destructive operations " { $link adjoin } " and " { $link delete } " only work properly on growable sequences like " { $link vector } "s."
$nl
"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } "are asymptotically optimal, taking time proportional to the sum of the size of the inputs."
$nl
"As one particlar example, " { $link POSTPONE: f } " is a representation of the empty set, as it represents the empty sequence." ;
HELP: set
{ $class-description "The class of all sets. Custom implementations of the set protocol should be declared as instances of this mixin for all set implementation to work correctly." } ;
HELP: adjoin
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $values { "elt" object } { "set" set } }
{ $description "Destructively adds " { $snippet "elt" } " to " { $snippet "set" } ". For sequences, this guarantees that this element is not duplicated, and that it is at the end of the sequence." $nl "Each mutable set type is expected to implement a method on this generic word." }
{ $examples
{ $example
"USING: namespaces prettyprint sets ;"
@ -47,48 +76,36 @@ HELP: adjoin
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
}
}
{ $side-effects "seq" } ;
{ $side-effects "set" } ;
HELP: conjoin
{ $values { "elt" object } { "assoc" assoc } }
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
{ $examples
{ $example
"USING: kernel prettyprint sets ;"
"H{ } clone 1 over conjoin ."
"H{ { 1 1 } }"
}
}
HELP: delete
{ $values { "elt" object } { "set" set } }
{ $description "Destructively removes " { $snippet "elt" } " from " { $snippet "set" } ". If the element is not present, this does nothing." $nl "Each mutable set type is expected to implement a method on this generic word." }
{ $side-effects "set" } ;
HELP: members
{ $values { "set" set } { "seq" sequence } }
{ $description "Creates a sequence with a single copy of each member of the set." $nl "Each set type is expected to implement a method on this generic word." } ;
HELP: in?
{ $values { "elt" object } { "set" set } { "?" "a boolean" } }
{ $description "Tests whether the element is a member of the set." $nl "Each set type is expected to implement a method on this generic word as part of the set protocol." } ;
HELP: adjoin-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." }
{ $side-effects "assoc" } ;
HELP: conjoin-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
} ;
HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
HELP: duplicates
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
{ $values { "set" set } { "seq" sequence } }
{ $description "Outputs a sequence consisting of elements which occur more than once in " { $snippet "set" } "." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 2 1 2 1 }" }
} ;
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $values { "set" set } { "?" "a boolean" } }
{ $description "Tests whether a set contains any repeated elements." }
{ $example
"USING: sets prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
@ -96,41 +113,44 @@ HELP: all-unique?
} ;
HELP: diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " but not " { $snippet "seq2" } ", comparing elements for equality."
{ $values { "set1" set } { "set2" set } { "set" set } }
{ $description "Outputs a set consisting of elements present in " { $snippet "set1" } " but not " { $snippet "set2" } ", comparing elements for equality."
"This word has a default definition which works for all sets, but set implementations may override the default for efficiency."
} { $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 1 }" }
} ;
HELP: intersect
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
{ $values { "set1" set } { "set2" set } { "set" set } }
{ $description "Outputs a set consisting of elements present in both " { $snippet "set1" } " and " { $snippet "set2" } "."
"This word has a default definition which works for all sets, but set implementations may override the default for efficiency." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
} ;
HELP: union
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
{ $values { "set1" set } { "set2" set } { "set" set } }
{ $description "Outputs a set consisting of elements present in either " { $snippet "set1" } " or " { $snippet "set2" } " which does not contain duplicate values."
"This word has a default definition which works for all sets, but set implementations may override the default for efficiency." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" }
} ;
{ diff intersect union } related-words
HELP: intersects?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "set1" } " and " { $snippet "set2" } " have any elements in common." }
{ $notes "If one of the sets is empty, the result is always " { $link f } "." } ;
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
{ $description "Tests if every element of " { $snippet "set1" } " is contained in " { $snippet "set2" } "." }
{ $notes "If " { $snippet "set1" } " is empty, the result is always " { $link t } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
{ $description "Tests if both sets contain the same elements, disregrading order and duplicates." } ;
HELP: gather
{ $values
@ -138,3 +158,10 @@ HELP: gather
{ "newseq" sequence } }
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
HELP: set-like
{ $values { "set" set } { "exemplar" set } { "set'" set } }
{ $description "If the conversion is defined for the exemplar, converts the set into a set of the exemplar's class. This is not guaranteed to create a new set, for example if the input set and exemplar are of the same class." $nl
"Set implementations may optionally implement a method on this generic word. The default implementation returns its input set." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } HS{ } set-like ." "HS{ 1 2 3 }" }
} ;

51
core/sets/sets-tests.factor
View File

@ -1,26 +1,16 @@
USING: kernel sets tools.test ;
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sets tools.test kernel prettyprint hash-sets sorting ;
IN: sets.tests
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
[ { } ] [ { } { } intersect ] unit-test
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
[ { } ] [ { } { } union ] unit-test
[ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
@ -30,3 +20,34 @@ IN: sets.tests
[ f ] [ { 1 } { } intersects? ] unit-test
[ t ] [ 4 { 2 4 5 } in? ] unit-test
[ f ] [ 1 { 2 4 5 } in? ] unit-test
[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
[ t ] [ { 1 2 3 } { 2 1 3 } set= ] unit-test
[ f ] [ { 2 3 } { 1 2 3 } set= ] unit-test
[ f ] [ { 1 2 3 } { 2 3 } set= ] unit-test
[ { 1 } ] [ { 1 } members ] unit-test
[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
[ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
[ { 1 2 3 } ] [ { 1 2 2 3 3 } { } set-like ] unit-test
[ { 3 2 1 } ] [ { 3 3 2 2 1 } { } set-like ] unit-test
[ { 2 1 2 1 } ] [ { 1 2 3 2 1 2 1 } duplicates ] unit-test
[ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test
[ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test

138
core/sets/sets.factor
View File

@ -1,59 +1,113 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences vectors ;
USING: accessors assocs hashtables kernel vectors
math sequences ;
IN: sets
: adjoin ( elt seq -- ) [ remove! drop ] [ push ] 2bi ;
! Set protocol
MIXIN: set
GENERIC: adjoin ( elt set -- )
GENERIC: in? ( elt set -- ? )
GENERIC: delete ( elt set -- )
GENERIC: set-like ( set exemplar -- set' )
GENERIC: fast-set ( set -- set' )
GENERIC: members ( set -- sequence )
GENERIC: union ( set1 set2 -- set )
GENERIC: intersect ( set1 set2 -- set )
GENERIC: intersects? ( set1 set2 -- ? )
GENERIC: diff ( set1 set2 -- set )
GENERIC: subset? ( set1 set2 -- ? )
GENERIC: set= ( set1 set2 -- ? )
GENERIC: duplicates ( set -- seq )
GENERIC: all-unique? ( set -- ? )
: conjoin ( elt assoc -- ) dupd set-at ;
! Defaults for some methods.
! Override them for efficiency
: conjoin-at ( value key assoc -- )
[ dupd ?set-at ] change-at ;
M: set set-like drop ; inline
: (prune) ( elt hash vec -- )
3dup drop key? [ 3drop ] [
[ drop conjoin ] [ nip push ] 3bi
] if ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
: duplicates ( seq -- newseq )
H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
: gather ( seq quot -- newseq )
map concat prune ; inline
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
2dup key? [ 2drop f ] [ conjoin t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
M: set union
[ [ members ] bi@ append ] keep set-like ;
<PRIVATE
: tester ( seq -- quot ) unique [ key? ] curry ; inline
: tester ( set -- quot )
fast-set [ in? ] curry ; inline
: sequence/tester ( set1 set2 -- set1' quot )
[ members ] [ tester ] bi* ; inline
PRIVATE>
: intersect ( seq1 seq2 -- newseq )
tester filter ;
M: set intersect
[ sequence/tester filter ] keep set-like ;
: intersects? ( seq1 seq2 -- ? )
tester any? ;
M: set diff
[ sequence/tester [ not ] compose filter ] keep set-like ;
: diff ( seq1 seq2 -- newseq )
tester [ not ] compose filter ;
M: set intersects?
sequence/tester any? ;
: union ( seq1 seq2 -- newseq )
append prune ;
M: set subset?
sequence/tester all? ;
M: set set=
2dup subset? [ swap subset? ] [ 2drop f ] if ;
: subset? ( seq1 seq2 -- ? )
tester all? ;
M: set fast-set ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;
M: set duplicates drop f ;
M: set all-unique? drop t ;
<PRIVATE
: (pruned) ( elt hash vec -- )
3dup drop in? [ 3drop ] [
[ drop adjoin ] [ nip push ] 3bi
] if ; inline
: pruned ( seq -- newseq )
[ f fast-set ] [ length <vector> ] bi
[ [ (pruned) ] 2curry each ] keep ;
PRIVATE>
! Sequences are sets
INSTANCE: sequence set
M: sequence in?
member? ; inline
M: sequence adjoin
[ delete ] [ push ] 2bi ;
M: sequence delete
remove! drop ; inline
M: sequence set-like
[ members ] dip like ;
M: sequence members
[ pruned ] keep like ;
M: sequence all-unique?
dup pruned sequence= ;
: combine ( sets -- set )
f [ union ] reduce ;
: gather ( seq quot -- newseq )
map concat members ; inline
: adjoin-at ( value key assoc -- )
[ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
! Temporarily for compatibility
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;
: conjoin ( elt assoc -- )
dupd set-at ;
: conjoin-at ( value key assoc -- )
[ dupd ?set-at ] change-at ;

13
core/syntax/syntax-docs.factor
View File

@ -189,6 +189,10 @@ ARTICLE: "syntax-hashtables" "Hashtable syntax"
{ $subsections POSTPONE: H{ }
"Hashtables are documented in " { $link "hashtables" } "." ;
ARTICLE: "syntax-hash-sets" "Hash set syntax"
{ $subsections POSTPONE: HS{ }
"Hashtables are documented in " { $link "hash-sets" } "." ;
ARTICLE: "syntax-tuples" "Tuple syntax"
{ $subsections POSTPONE: T{ }
"Tuples are documented in " { $link "tuples" } "." ;
@ -229,6 +233,7 @@ $nl
"syntax-vectors"
"syntax-sbufs"
"syntax-hashtables"
"syntax-hash-sets"
"syntax-tuples"
"syntax-pathnames"
"syntax-effects"
@ -330,7 +335,7 @@ HELP: }
$nl
"Parsing words can use this word as a generic end delimiter." } ;
{ POSTPONE: { POSTPONE: V{ POSTPONE: H{ POSTPONE: C{ POSTPONE: T{ POSTPONE: W{ POSTPONE: } } related-words
{ POSTPONE: { POSTPONE: V{ POSTPONE: H{ POSTPONE: HS{ POSTPONE: C{ POSTPONE: T{ POSTPONE: W{ POSTPONE: } } related-words
HELP: {
{ $syntax "{ elements... }" }
@ -356,6 +361,12 @@ HELP: H{
{ $description "Marks the beginning of a literal hashtable, given as a list of two-element arrays holding key/value pairs. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegetable\" } }" } } ;
HELP: HS{
{ $syntax "HS{ members ... }" }
{ $values { "members" "a list of objects" } }
{ $description "Marks the beginning of a literal hash set, given as a list of its members. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "HS{ 3 \"foo\" }" } } ;
HELP: C{
{ $syntax "C{ real-part imaginary-part }" }
{ $values { "real-part" "a real number" } { "imaginary-part" "a real number" } }

3
core/syntax/syntax.factor
View File

@ -8,7 +8,7 @@ generic.standard generic.hook generic.math generic.parser classes
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
combinators effects.parser slots ;
combinators effects.parser slots hash-sets ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -104,6 +104,7 @@ IN: bootstrap.syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
"T{" [ parse-tuple-literal suffix! ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
"HS{" [ \ } [ <hash-set> ] parse-literal ] define-core-syntax
"POSTPONE:" [ scan-word suffix! ] define-core-syntax
"\\" [ scan-word <wrapper> suffix! ] define-core-syntax

2
extra/contributors/contributors.factor
View File

@ -11,7 +11,7 @@ IN: contributors
] with-directory ;
: patch-counts ( authors -- assoc )
dup prune
dup members
[ dup rot [ = ] with count ] with
{ } map>assoc ;

4
extra/fuel/xref/xref.factor
View File

@ -29,7 +29,7 @@ IN: fuel.xref
[ word? ] filter [ word>xref ] map ;
: filter-prefix ( seq prefix -- seq )
[ drop-prefix nip length 0 = ] curry filter prune ;
[ drop-prefix nip length 0 = ] curry filter members ;
MEMO: (vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
@ -40,7 +40,7 @@ MEMO: (vocab-words) ( name -- seq )
append H{ } [ assoc-union ] reduce keys ;
: vocabs-words ( names -- seq )
prune [ (vocab-words) ] map concat ;
members [ (vocab-words) ] map concat ;
PRIVATE>

2
extra/html/parser/analyzer/analyzer.factor
View File

@ -145,7 +145,7 @@ TUPLE: link attributes clickable ;
[ >url ] map ;
: find-all-links ( vector -- vector' )
[ find-hrefs ] [ find-frame-links ] bi append prune ;
[ find-hrefs ] [ find-frame-links ] bi union ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name

Some files were not shown because too many files have changed in this diff Show More