vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
-: do-crossref ( -- )
- "Cross-referencing..." print flush
- H{ } clone crossref set-global
- xref-words
- xref-generics
- xref-sources ;
-
: load-components ( -- )
"include" "exclude"
[ get-global " " split harvest ] bi@
(command-line) parse-command-line
- do-crossref
-
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
{ $values { "topic" "an article name or a word" } }
{ $description "Sets the " { $link article-parent } " of each child of this article." }
$low-level-note ;
-
-HELP: unxref-article
-{ $values { "topic" "an article name or a word" } }
-{ $description "Clears the " { $link article-parent } " of each child of this article." }
-$low-level-note ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
: article-children ( topic -- seq )
{ $subsection } article-links ;
-M: link uses
- { $subsection $link $see-also } article-links ;
-
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
- dup >link xref dup set-article-parents ;
-
-: unxref-article ( topic -- )
- >link unxref ;
+ dup set-article-parents ;
: prev/next ( obj seq n -- obj' )
[ [ index dup ] keep ] dip swap
error get (:help) ;
: remove-article ( name -- )
- dup articles get key? [
- dup unxref-article
- dup articles get delete-at
- ] when drop ;
+ articles get delete-at ;
: add-article ( article name -- )
[ remove-article ] keep
xref-article ;
: remove-word-help ( word -- )
- dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.standard definitions make sbufs ;
+generic generic.standard definitions make sbufs tools.crossref ;
IN: tools.continuations
<PRIVATE
-USING: help.markup help.syntax words definitions prettyprint ;
+USING: help.markup help.syntax words definitions prettyprint
+tools.crossref.private math quotations assocs ;
IN: tools.crossref
-ARTICLE: "tools.crossref" "Cross-referencing tools"
+ARTICLE: "tools.crossref" "Definition cross referencing"
+"Definitions can answer a sequence of definitions they directly depend on:"
+{ $subsection uses }
+"An inverted index of the above:"
+{ $subsection get-crossref }
+"Words to access it:"
+{ $subsection usage }
+{ $subsection smart-usage }
+"Tools for interactive use:"
{ $subsection usage. }
+{ $subsection vocab-uses. }
+{ $subsection vocab-usage. }
{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"
+HELP: uses
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions directory called by the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." }
+{ $examples
+ "We can ask the " { $link sq } " word to produce a list of words it calls:"
+ { $unchecked-example "\ sq uses ." "{ dup * }" }
+} ;
+
+HELP: crossref
+{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } ". This variable is reset to " { $link f } " every time a definition is added or removed. Call " { $link get-crossref } " to lazily construct the graph instead of using this variable directly." } ;
+
+HELP: get-crossref
+{ $values { "crossref" assoc } }
+{ $description "Outputs the cross-referencing index, mapping definitions to usages, building it first if necessary." }
+{ $notes "This word is used to implement " { $link usage } " and " { $link usage. } "." } ;
+
+HELP: crossref-def
+{ $values { "defspec" "a definition specifier" } }
+{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
+$low-level-note ;
+
+HELP: usage
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions that directly call the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
+
HELP: usage.
{ $values { "word" "a word" } }
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
{ $examples { $code "\\ reverse usage." } } ;
+HELP: quot-uses
+{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
+{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
+
{ usage usage. } related-words
[ t ] [ integer \ foo method \ + usage member? ] unit-test
[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
+
+! Issues with forget
+GENERIC: generic-forget-test-1 ( a b -- c )
+
+M: integer generic-forget-test-1 / ;
+
+[ t ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+[ ] [
+ [ \ generic-forget-test-1 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+GENERIC: generic-forget-test-2 ( a b -- c )
+
+M: sequence generic-forget-test-2 = ;
+
+[ t ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
+
+[ ] [
+ [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
\ No newline at end of file
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs definitions io io.styles kernel prettyprint
-sorting see ;
+USING: words assocs definitions io io.pathnames io.styles kernel
+prettyprint sorting see sets sequences arrays hashtables help.crossref
+help.topics help.markup quotations accessors source-files namespaces
+graphs vocabs generic generic.standard.engines.tuple threads
+compiler.units init ;
IN: tools.crossref
+SYMBOL: crossref
+
+GENERIC: uses ( defspec -- seq )
+
+<PRIVATE
+
+GENERIC# quot-uses 1 ( obj assoc -- )
+
+M: object quot-uses 2drop ;
+
+M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
+
+: seq-uses ( seq assoc -- ) [ quot-uses ] curry each ;
+
+M: array quot-uses seq-uses ;
+
+M: hashtable quot-uses [ >alist ] dip seq-uses ;
+
+M: callable quot-uses seq-uses ;
+
+M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
+
+M: callable uses ( quot -- assoc )
+ H{ } clone [ quot-uses ] keep keys ;
+
+M: word uses def>> uses ;
+
+M: link uses { $subsection $link $see-also } article-links ;
+
+M: pathname uses string>> source-file top-level-form>> uses ;
+
+GENERIC: crossref-def ( defspec -- )
+
+M: object crossref-def
+ dup uses crossref get add-vertex ;
+
+M: word crossref-def
+ [ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
+
+: build-crossref ( -- crossref )
+ "Computing usage index... " write flush yield
+ H{ } clone crossref [
+ all-words
+ source-files get keys [ <pathname> ] map
+ [ [ crossref-def ] each ] bi@
+ crossref get
+ ] with-variable
+ "done" print flush ;
+
+: get-crossref ( -- crossref )
+ crossref global [ drop build-crossref ] cache ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+M: default-method irrelevant? drop t ;
+
+M: engine-word irrelevant? drop t ;
+
+PRIVATE>
+
+: usage ( defspec -- seq ) get-crossref at keys ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
+
+M: method-body smart-usage "method-generic" word-prop smart-usage ;
+
+M: f smart-usage drop \ f smart-usage ;
+
: synopsis-alist ( definitions -- alist )
[ [ synopsis ] keep ] { } map>assoc ;
: usage. ( word -- )
smart-usage sorted-definitions. ;
+
+: vocab-xref ( vocab quot -- vocabs )
+ [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
+ [
+ [ [ word? ] [ generic? not ] bi and ] filter [
+ dup method-body?
+ [ "method-generic" word-prop ] when
+ vocabulary>>
+ ] map
+ ] gather natural-sort remove sift ; inline
+
+: vocabs. ( seq -- )
+ [ dup >vocab-link write-object nl ] each ;
+
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+
+: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
+
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+
+: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
+
+<PRIVATE
+
+SINGLETON: invalidate-crossref
+
+M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
+
+[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
+
+PRIVATE>
\ No newline at end of file
-USING: tools.profiler.private tools.time help.markup help.syntax
-quotations io strings words definitions ;
+USING: tools.profiler.private tools.time tools.crossref
+help.markup help.syntax quotations io strings words definitions ;
IN: tools.profiler
ARTICLE: "profiler-limitations" "Profiler limitations"
USING: accessors words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private
-continuations generic compiler.units sets classes fry ;
+tools.crossref continuations generic compiler.units sets classes fry ;
IN: tools.profiler
: profile ( quot -- )
sets accessors generic definitions words ;\r
IN: tools.vocabs\r
\r
-: vocab-xref ( vocab quot -- vocabs )\r
- [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map\r
- [\r
- [ [ word? ] [ generic? not ] bi and ] filter [\r
- dup method-body?\r
- [ "method-generic" word-prop ] when\r
- vocabulary>>\r
- ] map\r
- ] gather natural-sort remove sift ; inline\r
-\r
-: vocabs. ( seq -- )\r
- [ dup >vocab-link write-object nl ] each ;\r
-\r
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;\r
-\r
-: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;\r
-\r
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;\r
-\r
-: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;\r
-\r
: vocab-tests-file ( vocab -- path )\r
dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
[ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs definitions fry help.topics kernel
colors.constants math.rectangles models.arrow namespaces sequences
-sorting definitions.icons ui.gadgets ui.gadgets.glass
+sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass
ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations
ui.pens.solid ui.images ;
"Creating primitives and basic runtime structures..." print flush
-crossref off
-
H{ } clone sub-primitives set
"vocab:bootstrap/syntax.factor" parse-file
[ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
-
- [ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
enable-compiler
] unit-test
-! Notify observers even if compilation unit did nothing
+! Check that we notify observers
SINGLETON: observer
observer add-definition-observer
M: observer definitions-changed 2drop global [ counter inc ] bind ;
-[ ] with-compilation-unit
+[ gensym [ ] (( -- )) define-declared ] with-compilation-unit
[ 1 ] [ counter get-global ] unit-test
update-tuples
process-forgotten-definitions
modify-code-heap
- updated-definitions notify-definition-observers
+ updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if
notify-error-observers ;
: with-nested-compilation-unit ( quot -- )
{ $subsection set-where }
"Definitions can be removed:"
{ $subsection forget }
-"Definitions can answer a sequence of definitions they directly depend on:"
-{ $subsection uses }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection definer }
{ $subsection definition }
{ $see-also "see" } ;
-ARTICLE: "definition-crossref" "Definition cross referencing"
-"A common cross-referencing system is used to track definition usages:"
-{ $subsection crossref }
-{ $subsection xref }
-{ $subsection unxref }
-{ $subsection delete-xref }
-{ $subsection usage } ;
-
ARTICLE: "definition-checking" "Definition sanity checking"
"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
$nl
}
"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details."
{ $subsection "definition-protocol" }
-{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
"A parsing word to remove definitions:"
{ $values { "definitions" "a sequence of definition specifiers" } }
{ $description "Forgets every definition in a sequence." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
-
-HELP: uses
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions directory called by the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." }
-{ $examples
- "We can ask the " { $link sq } " word to produce a list of words it calls:"
- { $unchecked-example "\ sq uses ." "{ dup * }" }
-} ;
-
-HELP: crossref
-{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ;
-
-HELP: xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: usage
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions that directly call the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-
-HELP: unxref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is redefined." } ;
-
-HELP: delete-xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is forgotten." }
-{ $see-also forget } ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs graphs math math.order ;
+USING: kernel sequences namespaces assocs math ;
IN: definitions
MIXIN: definition
GENERIC: definer ( defspec -- start end )
GENERIC: definition ( defspec -- seq )
-
-SYMBOL: crossref
-
-GENERIC: uses ( defspec -- seq )
-
-M: object uses drop f ;
-
-: xref ( defspec -- ) dup uses crossref get add-vertex ;
-
-: usage ( defspec -- seq ) crossref get at keys ;
-
-GENERIC: irrelevant? ( defspec -- ? )
-
-M: object irrelevant? drop f ;
-
-GENERIC: smart-usage ( defspec -- seq )
-
-M: f smart-usage drop \ f smart-usage ;
-
-M: object smart-usage usage [ irrelevant? not ] filter ;
-
-: unxref ( defspec -- )
- dup uses crossref get remove-vertex ;
-
-: delete-xref ( defspec -- )
- dup unxref crossref get delete-at ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! Issues with forget
-GENERIC: generic-forget-test-1 ( a b -- c )
+GENERIC: generic-forget-test ( a -- b )
-M: integer generic-forget-test-1 / ;
+M: f generic-forget-test ;
-[ t ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-[ ] [
- [ \ generic-forget-test-1 forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-2 ( a b -- c )
-
-M: sequence generic-forget-test-2 = ;
-
-[ t ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-[ ] [
- [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-3 ( a -- b )
-
-M: f generic-forget-test-3 ;
-
-[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
+[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test
+[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ f ] [ f generic-forget-test-3 ] unit-test
-
-: a-word ( -- ) ;
-
-GENERIC: a-generic ( a -- b )
-
-M: integer a-generic a-word ;
-
-[ ] [ \ integer \ a-generic method "m" set ] unit-test
-
-[ t ] [ "m" get \ a-word usage memq? ] unit-test
-
-[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test
-
-[ f ] [ "m" get \ a-word usage memq? ] unit-test
+[ f ] [ f generic-forget-test ] unit-test
! erg's regression
[ ] [
PREDICATE: default-method < word "default" word-prop ;
-M: default-method irrelevant? drop t ;
-
: <default-method> ( generic combination -- method )
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
[ call-next-method ] bi
] if ;
-M: method-body smart-usage
- "method-generic" word-prop smart-usage ;
-
M: sequence update-methods ( class seq -- )
implementors [
[ changed-generic ] [ remake-generic drop ] 2bi
M: class forget-methods
[ implementors ] [ [ swap method ] curry ] bi map forget-all ;
-
-: xref-generics ( -- )
- all-words [ subwords [ xref ] each ] each ;
M: engine-word crossref? "forgotten" word-prop not ;
-M: engine-word irrelevant? drop t ;
-
: remember-engine ( word -- )
generic get "engines" word-prop push ;
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
-! Cross-referencing with generic words
-TUPLE: xref-tuple-1 ;
-TUPLE: xref-tuple-2 < xref-tuple-1 ;
-
-: (xref-test) ( obj -- ) drop ;
-
-GENERIC: xref-test ( obj -- )
-
-M: xref-tuple-1 xref-test (xref-test) ;
-M: xref-tuple-2 xref-test (xref-test) ;
-
-[ t ] [
- \ xref-test
- \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
-[ t ] [
- \ xref-test
- \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
: finish-parsing ( lines quot -- )
file get
- [ record-form ]
+ [ record-top-level-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
{ $subsection source-file }
"Words intended for the parser:"
{ $subsection record-checksum }
-{ $subsection record-form }
-{ $subsection xref-source }
-{ $subsection unxref-source }
+{ $subsection record-definitions }
"Removing a source file from the database:"
{ $subsection forget-source }
"Updating the database:"
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
-HELP: xref-source
-{ $values { "source-file" source-file } }
-{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." }
-$low-level-note ;
-
-HELP: unxref-source
-{ $values { "source-file" source-file } }
-{ $description "Removes the source file from the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: xref-sources
-{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." }
-$low-level-note ;
-
-HELP: record-form
-{ $values { "quot" quotation } { "source-file" source-file } }
-{ $description "Records usage information for a source file's top level form." }
-$low-level-note ;
-
HELP: reset-checksums
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words quotations io io.files
TUPLE: source-file
path
+top-level-form
checksum
-uses definitions ;
+definitions ;
+
+: record-top-level-form ( quot file -- )
+ (>>top-level-form) H{ } notify-definition-observers ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;
-: (xref-source) ( source-file -- pathname uses )
- [ path>> <pathname> ]
- [ uses>> [ crossref? ] filter ] bi ;
-
-: xref-source ( source-file -- )
- (xref-source) crossref get add-vertex ;
-
-: unxref-source ( source-file -- )
- (xref-source) crossref get remove-vertex ;
-
-: xref-sources ( -- )
- source-files get [ nip xref-source ] assoc-each ;
-
-: record-form ( quot source-file -- )
- [ quot-uses keys ] dip
- [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ;
-
: record-definitions ( file -- )
new-definitions get >>definitions drop ;
M: pathname where string>> 1 2array ;
: forget-source ( path -- )
- [
- source-file
- [ unxref-source ]
- [ definitions>> [ keys forget-all ] each ] bi
- ]
- [ source-files get delete-at ]
- bi ;
+ source-files get delete-at*
+ [ definitions>> [ keys forget-all ] each ] [ drop ] if ;
M: pathname forget*
string>> forget-source ;
"This word must be called from inside " { $link with-compilation-unit } "."
} ;
-HELP: quot-uses
-{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
-{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
-
HELP: delimiter?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
FORGET: another-forgotten
: another-forgotten ( -- ) ;
-! I forgot remove-crossref calls!
-: fee ( -- ) ;
-: foe ( -- ) fee ;
-: fie ( -- ) foe ;
-
-[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
-[ t ] [ \ foe usage empty? ] unit-test
-[ f ] [ \ foe crossref get key? ] unit-test
-
-FORGET: foe
-
-! xref should not retain references to gensyms
-[ ] [
- [ gensym [ * ] define ] with-compilation-unit
-] unit-test
-
-[ t ] [
- \ * usage [ word? ] filter [ crossref? ] all?
-] unit-test
-
-DEFER: calls-a-gensym
-[ ] [
- [
- \ calls-a-gensym
- gensym dup "x" set 1quotation
- (( x -- x )) define-declared
- ] with-compilation-unit
-] unit-test
-
-[ f ] [ "x" get crossref get at ] unit-test
-
-! more xref buggery
-[ f ] [
- GENERIC: xyzzle ( x -- x )
- : a ( -- ) ; \ a
- M: integer xyzzle a ;
- FORGET: a
- M: object xyzzle ;
- crossref get at
-] unit-test
-
-! regression
-GENERIC: freakish ( x -- y )
-: bar ( x -- y ) freakish ;
-M: array freakish ;
-[ t ] [ \ bar \ freakish usage member? ] unit-test
DEFER: x
[ x ] [ undefined? ] must-fail-with
[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test
[ "test-last" ] [ word name>> ] unit-test
-! regression
-SYMBOL: quot-uses-a
-SYMBOL: quot-uses-b
-
-[ ] [
- [
- quot-uses-a [ 2 3 + ] define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-a uses ] unit-test
-
-[ ] [
- [
- quot-uses-b 2 [ 3 + ] curry define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-b uses ] unit-test
-
"undef-test" "words.tests" lookup [
[ forget ] with-compilation-unit
] when*
keys [ "forgotten" word-prop ] any?
] filter
] unit-test
-
-[ { } ] [
- crossref get keys
- [ word? ] filter [ "forgotten" word-prop ] filter
-] unit-test
GENERIC: crossref? ( word -- ? )
M: word crossref?
- dup "forgotten" word-prop [
- drop f
- ] [
- vocabulary>> >boolean
- ] if ;
-
-GENERIC# (quot-uses) 1 ( obj assoc -- )
-
-M: object (quot-uses) 2drop ;
-
-M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
-
-: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
-
-M: array (quot-uses) seq-uses ;
-
-M: hashtable (quot-uses) [ >alist ] dip seq-uses ;
-
-M: callable (quot-uses) seq-uses ;
-
-M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ;
-
-: quot-uses ( quot -- assoc )
- global [ H{ } clone [ (quot-uses) ] keep ] bind ;
-
-M: word uses ( word -- seq )
- def>> quot-uses keys ;
+ dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
SYMBOL: compiled-crossref
M: word subwords drop f ;
: define ( word def -- )
- [ ] like
- over unxref
- over changed-definition
- >>def
- dup crossref? [ dup xref ] when drop ;
+ over changed-definition [ ] like >>def drop ;
: changed-effect ( word -- )
[ dup changed-effects get set-in-unit ]
M: word forget*
dup "forgotten" word-prop [ drop ] [
- [ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
- tri
+ bi
] if ;
M: word hashcode*
M: word literalize <wrapper> ;
-: xref-words ( -- ) all-words [ xref ] each ;
-
INSTANCE: word definition
\ No newline at end of file
projects / factor.git / commitdiff