Rename update to assoc-union!, add assoc-filter! assoc-diff! words

basis/bootstrap/compiler/compiler.factor

@@ -103,7 +103,7 @@ gc
     "." write flush
 
     {
-        lines prefix suffix unclip new-assoc update
+        lines prefix suffix unclip new-assoc assoc-union!
         word-prop set-word-prop 1array 2array 3array ?nth
     } compile-unoptimized
 

basis/ui/commands/commands.factor

@@ -67,7 +67,8 @@ M: word command-description ( word -- str )
     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
 
 : define-command ( word hash -- )
-    [ props>> ] [ default-flags swap assoc-union ] bi* update ;
+    default-flags swap assoc-union
+    '[ _ assoc-union ] change-props drop ;
 
 : command-quot ( target command -- quot )
     [ 1quotation ] [ +nullary+ word-prop ] bi

core/assocs/assocs-docs.factor

@@ -93,12 +93,16 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 { $subsections
     assoc-subset?
     assoc-intersect
-    update
     assoc-union
     assoc-diff
     substitute
     extract-keys
 }
+"Destructive operations:"
+{ $subsections
+    assoc-union!
+    assoc-diff!
+}
 { $see-also key? assoc-any? assoc-all? "sets" } ;
 
 ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@@ -135,17 +139,21 @@ $nl
     assoc-map
     assoc-filter
     assoc-filter-as
+    assoc-partition
     assoc-any?
     assoc-all?
 }
-"Additional combinators:"
+"Mapping between assocs and sequences:"
 { $subsections
-    assoc-partition
-    cache
-    2cache
     map>assoc
     assoc>map
     assoc-map-as
+}
+"Destructive combinators:"
+{ $subsections
+    assoc-filter!
+    cache
+    2cache
 } ;
 
 ARTICLE: "assocs" "Associative mapping operations"
@@ -260,7 +268,12 @@ HELP: assoc-filter-as
 { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
 
-{ assoc-filter assoc-filter-as } related-words
+HELP: assoc-filter!
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } }
+{ $description "Removes all entries for which the predicate quotation yields true." }
+{ $side-effects "assoc" } ;
+
+{ assoc-filter assoc-filter-as assoc-filter! } related-words
 
 HELP: assoc-partition
 { $values
@@ -333,7 +346,7 @@ HELP: assoc-intersect
 { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
 { $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
 
-HELP: update
+HELP: assoc-union!
 { $values { "assoc1" assoc } { "assoc2" assoc } }
 { $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
 { $side-effects "assoc1" } ;
@@ -347,6 +360,11 @@ HELP: assoc-diff
 { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." } 
 ;
 
+HELP: assoc-diff!
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
+{ $description "Removes all entries from " { $snippet "assoc1" } " whose key is contained in " { $snippet "assoc2" } "." }
+{ $side-effects assoc-diff! } ;
+
 HELP: substitute
 { $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
 { $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;

core/assocs/assocs-tests.factor

@@ -32,11 +32,24 @@ IN: assocs.tests
 [ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
 
 [ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone dup [ 2drop f ] assoc-filter! drop ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone [ 2drop f ] assoc-filter! ] unit-test
+
 [ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
     H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
     [ drop 3 >= ] assoc-filter
 ] unit-test
 
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone
+    [ drop 3 >= ] assoc-filter!
+] unit-test
+
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone dup
+    [ drop 3 >= ] assoc-filter! drop
+] unit-test
+
 [ 21 ] [
     0 H{
         { 1 2 }
@@ -69,6 +82,20 @@ H{ } clone "cache-test" set
     assoc-union
 ] unit-test
 
+[
+    H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+    H{ { 2 4 } { 6 5 } } clone dup H{ { 1 2 } { 2 3 } }
+    assoc-union! drop
+] unit-test
+
+[
+    H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+    H{ { 2 4 } { 6 5 } } clone H{ { 1 2 } { 2 3 } }
+    assoc-union!
+] unit-test
+
 [ H{ { 1 2 } { 2 3 } } t ] [
     f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
 ] unit-test
@@ -79,6 +106,24 @@ H{ } clone "cache-test" set
     H{ { 1 f } } H{ { 1 f } } assoc-intersect
 ] unit-test
 
+[
+    H{ { 3 4 } }
+] [
+    H{ { 1 2 } { 3 4 } } H{ { 1 3 } } assoc-diff
+] unit-test
+
+[
+    H{ { 3 4 } }
+] [
+    H{ { 1 2 } { 3 4 } } clone dup H{ { 1 3 } } assoc-diff! drop
+] unit-test
+
+[
+    H{ { 3 4 } }
+] [
+    H{ { 1 2 } { 3 4 } } clone H{ { 1 3 } } assoc-diff!
+] unit-test
+
 [ H{ { "hi" 2 } { 3 4 } } ]
 [ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
 unit-test

core/assocs/assocs.factor

@@ -72,6 +72,12 @@ PRIVATE>
 : assoc-filter ( assoc quot -- subassoc )
     over assoc-filter-as ; inline
 
+: assoc-filter! ( assoc quot -- assoc )
+    [
+        over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
+        assoc-each
+    ] [ drop ] 2bi ; inline
+
 : assoc-partition ( assoc quot -- true-assoc false-assoc )
     [ (assoc-each) partition ] [ drop ] 2bi
     [ assoc-like ] curry bi@ ; inline
@@ -119,21 +125,27 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-intersect ( assoc1 assoc2 -- intersection )
     swap [ nip key? ] curry assoc-filter ;
 
-: update ( assoc1 assoc2 -- )
+: assoc-union! ( assoc1 assoc2 -- assoc1 )
-    swap [ set-at ] with-assoc assoc-each ;
+    over [ set-at ] with-assoc assoc-each ;
 
 : assoc-union ( assoc1 assoc2 -- union )
     [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
-    [ dupd update ] bi@ ;
+    [ assoc-union! ] bi@ ;
 
 : assoc-combine ( seq -- union )
-    H{ } clone [ dupd update ] reduce ;
+    H{ } clone [ assoc-union! ] reduce ;
 
 : assoc-refine ( seq -- assoc )
     [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
 
+: assoc-differ ( key -- quot )
+    [ nip key? not ] curry ; inline
+
 : assoc-diff ( assoc1 assoc2 -- diff )
-    [ nip key? not ] curry assoc-filter ;
+    assoc-differ assoc-filter ;
+
+: assoc-diff! ( assoc1 assoc2 -- assoc1 )
+    assoc-differ assoc-filter! ;
 
 : substitute ( seq assoc -- newseq )
     substituter map ;

core/classes/tuple/parser/parser.factor

@@ -101,9 +101,9 @@ ERROR: bad-slot-name class slot ;
     over [ slot-named* ] dip check-slot-exists drop ;
 
 : assoc>object ( class slots values -- tuple )
-    [ [ [ initial>> ] map ] keep ] dip
+    [ [ [ initial>> ] map <enum> ] keep ] dip
     swap [ [ slot-named-checked ] curry dip ] curry assoc-map
-    [ dup <enum> ] dip update boa>object ;
+    assoc-union! seq>> boa>object ;
 
 : parse-tuple-literal-slots ( class slots -- tuple )
     scan {

core/compiler/units/units.factor

@@ -120,12 +120,12 @@ M: object always-bump-effect-counter? drop f ;
 
 : updated-definitions ( -- assoc )
     H{ } clone
-    dup forgotten-definitions get update
+    forgotten-definitions get assoc-union!
-    dup new-definitions get first update
+    new-definitions get first assoc-union!
-    dup new-definitions get second update
+    new-definitions get second assoc-union!
-    dup changed-definitions get update
+    changed-definitions get assoc-union!
-    dup maybe-changed get update
+    maybe-changed get assoc-union!
-    dup dup changed-vocabs update ;
+    dup changed-vocabs assoc-union! ;
 
 : process-forgotten-definitions ( -- )
     forgotten-definitions get keys

core/generic/single/single.factor

@@ -133,7 +133,7 @@ GENERIC: compile-engine ( engine -- obj )
     [ over assumed [ compile-engine ] with-variable ] assoc-map ;
 
 : direct-dispatch-table ( assoc n -- table )
-    default get <array> [ <enum> swap update ] keep ;
+    default get <array> <enum> swap assoc-union! seq>> ;
 
 : tag-number ( class -- n ) "type" word-prop ;
 
@@ -160,7 +160,7 @@ M: tuple-dispatch-engine compile-engine
     tuple assumed [
         echelons>> compile-engines
         dup keys supremum 1 + f <array>
-        [ <enum> swap update ] keep
+        <enum> swap assoc-union! seq>>
     ] with-variable ;
 
 PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;

core/slots/slots.factor

@@ -22,7 +22,7 @@ PREDICATE: writer-method < method "writing" word-prop ;
 
 : define-typecheck ( class generic quot props -- )
     [ create-method ] 2dip
-    [ [ props>> ] [ drop ] [ ] tri* update ]
+    [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
     [ drop define ]
     [ 2drop make-inline ]
     3tri ;