FROM: and RENAME: give a more meaningful error if the vocabulary does not exist

Slava Pestov 2009-07-18 06:51:29 -05:00
parent 64f7a290f5
commit a222fc6bd2
2 changed files with 15 additions and 6 deletions

View File

@ -258,6 +258,12 @@ M: no-word-error summary
M: no-word-error error. summary print ; M: no-word-error error. summary print ;
M: no-word-in-vocab summary
[ vocab>> ] [ word>> ] bi
[ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
M: no-word-in-vocab error. summary print ;
M: ambiguous-use-error summary M: ambiguous-use-error summary
words>> first name>> words>> first name>>
"More than one vocabulary defines a word named ``" "''" surround ; "More than one vocabulary defines a word named ``" "''" surround ;

View File

@ -59,16 +59,19 @@ C: <extra-words> extra-words
[ qualified-vocabs>> delete-all ] [ qualified-vocabs>> delete-all ]
tri ; tri ;
ERROR: no-word-in-vocab word vocab ;
<PRIVATE <PRIVATE
: (add-qualified) ( qualified -- ) : (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ; manifest get qualified-vocabs>> push ;
: (from) ( vocab words -- vocab words words' assoc ) : (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab words>> ; 2dup swap load-vocab ;
: extract-words ( seq assoc -- assoc' ) : extract-words ( seq vocab -- assoc' )
extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ; [ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
: (lookup) ( name assoc -- word/f ) : (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ; at dup forward-reference? [ drop f ] when ;
@ -148,7 +151,7 @@ TUPLE: from vocab names words ;
TUPLE: exclude vocab names words ; TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from ) : <exclude> ( vocab words -- from )
(from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ; (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
: add-words-excluding ( vocab words -- ) : add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ; <exclude> (add-qualified) ;
@ -156,7 +159,7 @@ TUPLE: exclude vocab names words ;
TUPLE: rename word vocab words ; TUPLE: rename word vocab words ;
: <rename> ( word vocab new-name -- rename ) : <rename> ( word vocab new-name -- rename )
[ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip
associate rename boa ; associate rename boa ;
: add-renamed-word ( word vocab new-name -- ) : add-renamed-word ( word vocab new-name -- )