diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 8e167c076a..edb0bdf2ae 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/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 diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index 7988432676..fe9bc19c1e 100644 --- a/basis/ui/commands/commands.factor +++ b/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 diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 34535f1a02..af49e22fad 100644 --- a/core/assocs/assocs-docs.factor +++ b/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." } ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 646f9a4561..e04237251b 100644 --- a/core/assocs/assocs-tests.factor +++ b/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 diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 5a727d6b3e..f8371640c4 100644 --- a/core/assocs/assocs.factor +++ b/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 -- ) - swap [ set-at ] with-assoc assoc-each ; +: assoc-union! ( assoc1 assoc2 -- assoc1 ) + 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 ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 812f75a591..7482cce048 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/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 ] keep ] dip swap [ [ slot-named-checked ] curry dip ] curry assoc-map - [ dup ] dip update boa>object ; + assoc-union! seq>> boa>object ; : parse-tuple-literal-slots ( class slots -- tuple ) scan { diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 11ab8ab1f2..60d27e8487 100644 --- a/core/compiler/units/units.factor +++ b/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 - dup new-definitions get first update - dup new-definitions get second update - dup changed-definitions get update - dup maybe-changed get update - dup dup changed-vocabs update ; + forgotten-definitions get assoc-union! + new-definitions get first assoc-union! + new-definitions get second assoc-union! + changed-definitions get assoc-union! + maybe-changed get assoc-union! + dup changed-vocabs assoc-union! ; : process-forgotten-definitions ( -- ) forgotten-definitions get keys diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index fe33d6a91f..b39956c731 100644 --- a/core/generic/single/single.factor +++ b/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 [ swap update ] keep ; + default get 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 - [ swap update ] keep + swap assoc-union! seq>> ] with-variable ; PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index f6bd13cf6d..191205a9b4 100644 --- a/core/slots/slots.factor +++ b/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 ;