diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8a2823010d..e75e7f6046 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -151,14 +151,14 @@ SYMBOL: node-count H{ } clone intrinsics-called set 0 swap [ - >r 1+ r> + [ 1+ ] dip dup #call? [ word>> { { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } [ words-called ] - } cond 1 -rot get at+ + } cond inc-at ] [ drop ] if ] each-node node-count set diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e35eb02604..bd6d657442 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -152,7 +152,7 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - [ [ 1 ] dip inlining-count get at+ ] + [ inlining-count get inc-at ] [ history [ swap suffix ] change ] bi ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index e9e1bfa16a..77b87d1b49 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -67,6 +67,8 @@ HELP: :> { $syntax ":> binding" } { $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } { $notes + "This word can only be used inside a lambda word, lambda quotation or let binding form." + $nl "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "." $nl "Lambdas desugar as follows:" diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index d84e49f784..24810a6c3e 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -13,10 +13,10 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when - 1 over word-name>> word-histogram get at+ + dup word-name>> word-histogram get inc-at dup word-name>> word-names get member? [ - 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array - message-histogram get at+ + dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get inc-at ] when drop ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 8c35ae25a8..2ad16a4d8d 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -53,7 +53,7 @@ IN: tools.memory : heap-stat-step ( obj counts sizes -- ) [ over ] dip - [ [ [ drop 1 ] [ class ] bi ] dip at+ ] + [ [ class ] dip inc-at ] [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ; PRIVATE> diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 662d667485..2f486cd948 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -90,6 +90,7 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs" { $subsection rename-at } { $subsection change-at } { $subsection at+ } +{ $subsection inc-at } { $see-also set-at delete-at clear-assoc push-at } ; ARTICLE: "assocs-conversions" "Associative mapping conversions" @@ -349,6 +350,11 @@ HELP: at+ { $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." } { $side-effects "assoc" } ; +HELP: inc-at +{ $values { "key" object } { "assoc" assoc } } +{ $description "Adds 1 to the value associated with " { $snippet "key" } "; if there is no value, stores 1." } +{ $side-effects "assoc" } ; + HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } { $contract "Converts an associative structure into an association list." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 76745cc015..320e370ec9 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -141,8 +141,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : change-at ( key assoc quot -- ) [ [ at ] dip call ] 3keep drop set-at ; inline -: at+ ( n key assoc -- ) - [ 0 or + ] change-at ; +: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline + +: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline : map>assoc ( seq quot exemplar -- assoc ) [ [ 2array ] compose { } map-as ] dip assoc-like ; inline