diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 30f2ec23c4..43a1bac82d 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -104,3 +104,17 @@ unit-test 2drop ] { } make ] unit-test + +[ + H{ + { "bangers" "mash" } + { "fries" "onion rings" } + } +] [ + { "bangers" "fries" } H{ + { "fish" "chips" } + { "bangers" "mash" } + { "fries" "onion rings" } + { "nachos" "cheese" } + } extract-keys +] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 92db38573a..6b0798f2e3 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : map>assoc ( seq quot exemplar -- assoc ) >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 ; : value-at ( value assoc -- key/f ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index b1bfc659df..9c810592a0 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -22,8 +22,7 @@ C: predicate-dispatch-engine } cond ; : sort-methods ( assoc -- assoc' ) - [ keys sort-classes ] - [ [ dupd at ] curry ] bi { } map>assoc ; + >alist [ keys sort-classes ] keep extract-keys ; M: predicate-dispatch-engine engine>quot methods>> clone diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 933710aaca..dc632425fe 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -152,16 +152,16 @@ M: pair apply-constraint M: pair constraint-satisfied? first constraint-satisfied? ; -: extract-keys ( seq assoc -- newassoc ) - [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ; +: valid-keys ( seq assoc -- newassoc ) + extract-keys [ nip ] assoc-filter f assoc-like ; : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. dup node-values { - [ value-intervals get extract-keys >>intervals ] - [ value-classes get extract-keys >>classes ] - [ value-literals get extract-keys >>literals ] + [ value-intervals get valid-keys >>intervals ] + [ value-classes get valid-keys >>classes ] + [ value-literals get valid-keys >>literals ] [ 2drop ] } cleave ; @@ -330,7 +330,7 @@ M: #return infer-classes-around [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri classes= not [ fixed-point? off - [ in-d>> value-classes get extract-keys ] keep + [ in-d>> value-classes get valid-keys ] keep set-node-classes ] [ drop ] if ] [ call-next-method ] if