Remove interned predicate class

db4
Slava Pestov 2008-02-06 12:47:15 -06:00
parent 38b4f67b70
commit d9338b1cd2
8 changed files with 21 additions and 41 deletions

View File

@ -172,7 +172,9 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
FORGET: forget-class-bug-1 FORGET: forget-class-bug-1
FORGET: forget-class-bug-2 FORGET: forget-class-bug-2
[ t ] [ integer dll class-or interned? ] unit-test [ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
DEFER: mixin-forget-test-g DEFER: mixin-forget-test-g

View File

@ -92,8 +92,6 @@ DEFER: x-4
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1 DEFER: g-test-1
DEFER: g-test-3 DEFER: g-test-3
@ -237,7 +235,7 @@ DEFER: flushable-test-2
: bx ax ; : bx ax ;
[ \ bx forget ] with-compilation-unit [ \ bx forget ] with-compilation-unit
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test [ f ] [ \ bx \ ax compiled-usage contains? ] unit-test
DEFER: defer-redefine-test-2 DEFER: defer-redefine-test-2

View File

@ -38,7 +38,7 @@ uses definitions ;
: (xref-source) ( source-file -- pathname uses ) : (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses dup source-file-path <pathname> swap source-file-uses
[ interned? ] subset ; [ crossref? ] subset ;
: xref-source ( source-file -- ) : xref-source ( source-file -- )
(xref-source) crossref get add-vertex ; (xref-source) crossref get add-vertex ;

View File

@ -123,7 +123,7 @@ TUPLE: yo-momma ;
[ ] [ \ yo-momma forget ] unit-test [ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma typemap get values memq? ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test
[ f ] [ \ yo-momma interned? ] unit-test [ f ] [ \ yo-momma crossref ] unit-test
] with-compilation-unit ] with-compilation-unit
TUPLE: loc-recording ; TUPLE: loc-recording ;

2
core/vocabs/vocabs-docs.factor Normal file → Executable file
View File

@ -76,7 +76,7 @@ HELP: all-words
HELP: forget-vocab HELP: forget-vocab
{ $values { "vocab" string } } { $values { "vocab" string } }
{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." } { $description "Removes a vocabulary. All words in the vocabulary are forgotten." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: load-vocab-hook HELP: load-vocab-hook

View File

@ -14,9 +14,7 @@ $nl
{ $subsection lookup } { $subsection lookup }
"Words can output their name and vocabulary:" "Words can output their name and vocabulary:"
{ $subsection word-name } { $subsection word-name }
{ $subsection word-vocabulary } { $subsection word-vocabulary } ;
"Testing if a word object is part of a vocabulary:"
{ $subsection interned? } ;
ARTICLE: "uninterned-words" "Uninterned words" ARTICLE: "uninterned-words" "Uninterned words"
"A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "."
@ -369,18 +367,6 @@ HELP: delimiter?
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: 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." } ; { $notes "Outputs " { $link f } " if the object is not a word." } ;
HELP: interned
{ $class-description "The class of words defined in the " { $link dictionary } "." }
{ $examples
{ $example "\\ + interned? ." "t" }
{ $example "gensym interned? ." "f" }
} ;
HELP: rename-word
{ $values { "word" word } { "newname" string } { "newvocab" string } }
{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." }
{ $side-effects "word" } ;
HELP: make-flushable HELP: make-flushable
{ $values { "word" word } } { $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: flushable } "." } { $description "Declares a word as " { $link POSTPONE: flushable } "." }

View File

@ -54,22 +54,14 @@ GENERIC: testing
[ f ] [ \ testing generic? ] unit-test [ f ] [ \ testing generic? ] unit-test
[ f ] [ gensym interned? ] unit-test
: forgotten ; : forgotten ;
: another-forgotten ; : another-forgotten ;
[ f ] [ \ forgotten interned? ] unit-test
FORGET: forgotten FORGET: forgotten
[ f ] [ \ another-forgotten interned? ] unit-test
FORGET: another-forgotten FORGET: another-forgotten
: another-forgotten ; : another-forgotten ;
[ t ] [ \ + interned? ] unit-test
! I forgot remove-crossref calls! ! I forgot remove-crossref calls!
: fee ; : fee ;
: foe fee ; : foe fee ;
@ -87,8 +79,7 @@ FORGET: foe
] unit-test ] unit-test
[ t ] [ [ t ] [
\ * usage [ word? ] subset \ * usage [ word? ] subset [ crossref? ] all?
[ dup interned? swap method-body? or ] all?
] unit-test ] unit-test
DEFER: calls-a-gensym DEFER: calls-a-gensym

View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: words
USING: arrays definitions graphs assocs kernel kernel.private USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting math.parser words.private quotations assocs hashtables sorting math.parser words.private
vocabs ; vocabs combinators ;
IN: words
: word ( -- word ) \ word get-global ; : word ( -- word ) \ word get-global ;
@ -65,15 +65,20 @@ SYMBOL: bootstrapping?
: bootstrap-word ( word -- target ) : bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ; [ target-word ] [ ] if-bootstrapping ;
PREDICATE: word interned dup target-word eq? ; : crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
GENERIC# (quot-uses) 1 ( obj assoc -- ) GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ; M: object (quot-uses) 2drop ;
M: word (quot-uses) M: word (quot-uses)
>r dup "forgotten" word-prop >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
[ r> 2drop ] [ dup r> set-at ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
@ -94,6 +99,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- ) : compiled-xref ( word dependencies -- )
[ crossref? ] subset
2dup "compiled-uses" set-word-prop 2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ; compiled-crossref get add-vertex* ;
@ -118,9 +124,6 @@ SYMBOL: changed-words
[ no-compilation-unit ] unless* [ no-compilation-unit ] unless*
set-at ; set-at ;
: crossref? ( word -- ? )
dup word-vocabulary swap "method" word-prop or ;
: define ( word def -- ) : define ( word def -- )
[ ] like [ ] like
over unxref over unxref