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

Add extract-keys word

db4
Slava Pestov 2008-05-22 22:41:48 -05:00
parent e8815e7bb2
commit 3ee56c3a68
4 changed files with 24 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -104,3 +104,17 @@ unit-test
2drop 2drop
] { } make ] { } make
] unit-test ] unit-test
[
H{
{ "bangers" "mash" }
{ "fries" "onion rings" }
}
] [
{ "bangers" "fries" } H{
{ "fish" "chips" }
{ "bangers" "mash" }
{ "fries" "onion rings" }
{ "nachos" "cheese" }
} extract-keys
] unit-test

3
core/assocs/assocs.factor
View File

@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: map>assoc ( seq quot exemplar -- assoc ) : map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose { } map-as r> assoc-like ; inline >r [ 2array ] compose { } map-as r> assoc-like ; inline
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
M: assoc >alist [ 2array ] { } assoc>map ; M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f ) : value-at ( value assoc -- key/f )

3
core/generic/standard/engines/predicate/predicate.factor
View File

@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
} cond ; } cond ;
: sort-methods ( assoc -- assoc' ) : sort-methods ( assoc -- assoc' )
[ keys sort-classes ] >alist [ keys sort-classes ] keep extract-keys ;
[ [ dupd at ] curry ] bi { } map>assoc ;
M: predicate-dispatch-engine engine>quot M: predicate-dispatch-engine engine>quot
methods>> clone methods>> clone

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

@ -152,16 +152,16 @@ M: pair apply-constraint
M: pair constraint-satisfied? M: pair constraint-satisfied?
first constraint-satisfied? ; first constraint-satisfied? ;
: extract-keys ( seq assoc -- newassoc ) : valid-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ; extract-keys [ 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
#! value classes. #! value classes.
dup node-values { dup node-values {
[ value-intervals get extract-keys >>intervals ] [ value-intervals get valid-keys >>intervals ]
[ value-classes get extract-keys >>classes ] [ value-classes get valid-keys >>classes ]
[ value-literals get extract-keys >>literals ] [ value-literals get valid-keys >>literals ]
[ 2drop ] [ 2drop ]
} cleave ; } cleave ;
@ -330,7 +330,7 @@ M: #return infer-classes-around
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [ classes= not [
fixed-point? off fixed-point? off
[ in-d>> value-classes get extract-keys ] keep [ in-d>> value-classes get valid-keys ] keep
set-node-classes set-node-classes
] [ drop ] if ] [ drop ] if
] [ call-next-method ] if ] [ call-next-method ] if