"deprecated" declaration, "deprecation" vocab to track deprecations in the error log

basis/deprecation/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/deprecation/deprecation.factor

@@ -0,0 +1,72 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs compiler.units
+debugger io kernel namespaces prettyprint sequences
+source-files.errors summary tools.crossref.private
+tools.errors words ;
+IN: deprecation
+
+SYMBOL: +deprecation-note+
+SYMBOL: deprecation-notes
+
+deprecation-notes [ H{ } clone ] initialize
+
+TUPLE: deprecation-note < source-file-error ;
+
+M: deprecation-note error-type drop +deprecation-note+ ;
+
+TUPLE: deprecated-usages asset usages ;
+
+: :deprecations ( -- )
+    deprecation-notes get-global values errors. ;
+
+T{ error-type
+    { type +deprecation-note+ }
+    { word ":deprecations" }
+    { plural "deprecated word usages" }
+    { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
+    { quot [ deprecation-notes get values ] }
+    { forget-quot [ deprecation-notes get delete-at ] }
+} define-error-type
+
+: <deprecation-note> ( error word -- deprecation-note )
+    \ deprecation-note <definition-error> ;
+
+: deprecation-note ( word usages -- )
+    [ deprecated-usages boa ]
+    [ drop <deprecation-note> ]
+    [ drop deprecation-notes get-global set-at ] 2tri ;
+
+: clear-deprecation-note ( word -- )
+    deprecation-notes get-global delete-at ;
+
+: check-deprecations ( word -- )
+    dup "forgotten" word-prop
+    [ clear-deprecation-note ] [
+        dup def>> [ deprecated? ] filter
+        [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
+    ] if ;
+
+M: deprecated-usages summary
+    drop "Deprecated words used" ;
+
+M: deprecated-usages error.
+    "The definition of " write
+    dup asset>> pprint
+    " uses these deprecated words:" write nl
+    usages>> [ "    " write pprint nl ] each ;
+
+SINGLETON: deprecation-observer
+
+: initialize-deprecation-notes ( -- )
+    get-crossref [ drop deprecated? ] assoc-filter
+    values [ keys [ check-deprecations ] each ] each ;
+
+M: deprecation-observer definitions-changed
+    drop keys [ word? ] filter
+    dup [ deprecated? ] filter empty?
+    [ [ check-deprecations ] each ]
+    [ drop initialize-deprecation-notes ] if ;
+
+\ deprecation-observer add-definition-observer
+
+initialize-deprecation-notes

basis/deprecation/summary.txt

@@ -0,0 +1 @@
+Tracking usage of deprecated words

basis/see/see.factor

@@ -101,6 +101,7 @@ M: object declarations. drop ;
 M: word declarations.
     {
         POSTPONE: delimiter
+        POSTPONE: deprecated
         POSTPONE: inline
         POSTPONE: recursive
         POSTPONE: foldable

core/bootstrap/syntax.factor

@@ -67,6 +67,7 @@ IN: bootstrap.syntax
     "M\\"
     "]"
     "delimiter"
+    "deprecated"
     "f"
     "flushable"
     "foldable"

core/syntax/syntax-docs.factor

@@ -191,6 +191,10 @@ HELP: delimiter
 { $syntax ": foo ... ; delimiter" }
 { $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ;
 
+HELP: deprecated
+{ $syntax ": foo ... ; deprecated" }
+{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ;
+
 HELP: SYNTAX:
 { $syntax "SYNTAX: foo ... ;" }
 { $description "Defines a parsing word." }

core/syntax/syntax.factor

@@ -111,6 +111,7 @@ IN: bootstrap.syntax
     "foldable" [ word make-foldable ] define-core-syntax
     "flushable" [ word make-flushable ] define-core-syntax
     "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
+    "deprecated" [ word make-deprecated ] define-core-syntax
 
     "SYNTAX:" [
         CREATE-WORD parse-definition define-syntax

core/words/words-docs.factor

@@ -294,6 +294,16 @@ HELP: delimiter?
 { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
 { $notes "Outputs " { $link f } " if the object is not a word." } ;
 
+HELP: deprecated?
+{ $values { "obj" object } { "?" "a boolean" } }
+{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." }
+{ $notes "Outputs " { $link f } " if the object is not a word." } ;
+
+HELP: make-deprecated
+{ $values { "word" word } }
+{ $description "Declares a word as " { $link POSTPONE: deprecated } "." }
+{ $side-effects "word" } ;
+
 HELP: make-flushable
 { $values { "word" word } }
 { $description "Declares a word as " { $link POSTPONE: flushable } "." }

core/words/words.factor

@@ -123,6 +123,9 @@ M: word subwords drop f ;
 : define-declared ( word def effect -- )
     [ nip swap set-stack-effect ] [ drop define ] 3bi ;
 
+: make-deprecated ( word -- )
+    t "deprecated" set-word-prop ;
+
 : make-inline ( word -- )
     dup inline? [ drop ] [
         [ t "inline" set-word-prop ]
@@ -148,7 +151,7 @@ M: word reset-word
     {
         "unannotated-def" "parsing" "inline" "recursive"
         "foldable" "flushable" "reading" "writing" "reader"
-        "writer" "delimiter"
+        "writer" "delimiter" "deprecated"
     } reset-props ;
 
 : reset-generic ( word -- )
@@ -200,6 +203,9 @@ M: parsing-word definer drop \ SYNTAX: \ ; ;
 : delimiter? ( obj -- ? )
     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 
+: deprecated? ( obj -- ? )
+    dup word? [ "deprecated" word-prop ] [ drop f ] if ;
+
 ! Definition protocol
 M: word where "loc" word-prop ;