! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables kernel namespaces sequences
-sets strings vocabs sorting accessors arrays compiler.units
-combinators vectors splitting continuations math words
-parser.notes ;
+USING: accessors arrays assocs combinators compiler.units
+continuations hash-sets hashtables kernel math namespaces
+parser.notes sequences sets sorting splitting vectors vocabs
+words ;
IN: vocabs.parser
ERROR: no-word-error name ;
: word-restarts ( possibilities -- restarts )
- natural-sort
- [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
+ natural-sort [
+ [ vocabulary>> "Use the " " vocabulary" surround ] keep
+ ] { } map>assoc ;
: word-restarts-with-defer ( name possibilities -- restarts )
word-restarts
- swap "Defer word in current vocabulary" swap 2array
+ "Defer word in current vocabulary" rot 2array
suffix ;
: <no-word-error> ( name possibilities -- error restarts )
TUPLE: manifest
current-vocab
-{ search-vocab-names hashtable }
+{ search-vocab-names hash-set }
{ search-vocabs vector }
{ qualified-vocabs vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
manifest new
- H{ } clone >>search-vocab-names
+ HS{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
V{ } clone >>auto-used ;
<PRIVATE
-: (add-qualified) ( qualified -- )
- manifest get qualified-vocabs>> push ;
-
: (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab ;
: (lookup) ( name assoc -- word/f )
at* [ dup forward-reference? [ drop f ] when ] when ;
-: (use-words) ( assoc -- extra-words seq )
- <extra-words> manifest get qualified-vocabs>> ;
-
PRIVATE>
+: qualified-vocabs ( -- qualified-vocabs )
+ manifest get qualified-vocabs>> ;
+
: set-current-vocab ( name -- )
create-vocab
- [ manifest get current-vocab<< ] [ (add-qualified) ] bi ;
+ [ manifest get current-vocab<< ]
+ [ qualified-vocabs push ] bi ;
: with-current-vocab ( name quot -- )
manifest get clone manifest [
TUPLE: no-current-vocab-error ;
: no-current-vocab ( -- vocab )
- \ no-current-vocab-error boa
+ no-current-vocab-error boa
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
throw-restarts dup set-current-vocab ;
: current-vocab ( -- vocab )
manifest get current-vocab>> [ no-current-vocab ] unless* ;
+ERROR: unbalanced-private-declaration vocab ;
+
: begin-private ( -- )
current-vocab name>> ".private" ?tail
- [ drop ] [ ".private" append set-current-vocab ] if ;
+ [ unbalanced-private-declaration ]
+ [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
current-vocab name>> ".private" ?tail
- [ set-current-vocab ] [ drop ] if ;
+ [ set-current-vocab ]
+ [ unbalanced-private-declaration ] if ;
: using-vocab? ( vocab -- ? )
- vocab-name manifest get search-vocab-names>> key? ;
+ vocab-name manifest get search-vocab-names>> in? ;
: use-vocab ( vocab -- )
- dup using-vocab?
- [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
+ dup using-vocab? [
+ vocab-name "Already using ``" "'' vocabulary" surround note.
+ ] [
manifest get
- [ [ load-vocab ] dip search-vocabs>> push ]
- [ [ vocab-name ] dip search-vocab-names>> conjoin ]
+ [ [ ?load-vocab ] dip search-vocabs>> push ]
+ [ [ vocab-name ] dip search-vocab-names>> adjoin ]
2bi
] if ;
: auto-use-vocab ( vocab -- )
[ use-vocab ] [ manifest get auto-used>> push ] bi ;
-: auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
+: auto-used? ( -- ? )
+ manifest get auto-used>> length 0 > ;
: unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
[ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
- [ [ vocab-name ] dip search-vocab-names>> delete-at ]
+ [ [ vocab-name ] dip search-vocab-names>> delete ]
2bi
] [ drop ] if ;
(from) qualified-words qualified boa ;
: add-qualified ( vocab prefix -- )
- <qualified> (add-qualified) ;
+ <qualified> qualified-vocabs push ;
TUPLE: from vocab names words ;
(from) extract-words from boa ;
: add-words-from ( vocab words -- )
- <from> (add-qualified) ;
+ <from> qualified-vocabs push ;
TUPLE: exclude vocab names words ;
(from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
- <exclude> (add-qualified) ;
+ <exclude> qualified-vocabs push ;
TUPLE: rename word vocab words ;
: <rename> ( word vocab new-name -- rename )
- [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip
- associate rename boa ;
+ [
+ 2dup load-vocab words>> dupd at
+ [ ] [ swap no-word-in-vocab ] ?if
+ ] dip associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
- <rename> (add-qualified) ;
+ <rename> qualified-vocabs push ;
+
+: use-words ( assoc -- )
+ <extra-words> qualified-vocabs push ;
-: use-words ( assoc -- ) (use-words) push ;
+: unuse-words ( assoc -- )
+ <extra-words> qualified-vocabs remove! drop ;
-: unuse-words ( assoc -- ) (use-words) remove! drop ;
+: with-words ( assoc quot -- )
+ '[ use-words @ ] over '[ _ unuse-words ] finally ; inline
-TUPLE: ambiguous-use-error words ;
+TUPLE: ambiguous-use-error name words ;
-: <ambiguous-use-error> ( words -- error restarts )
- [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
+: <ambiguous-use-error> ( name words -- error restarts )
+ [ ambiguous-use-error boa ] [ word-restarts ] bi ;
<PRIVATE
-: (vocab-search) ( name assocs -- words n )
- [ words>> (lookup) ] with map
- sift dup length ;
+: (lookup-word) ( words name vocab -- words )
+ words>> (lookup) [ suffix! ] when* ; inline
+
+: (vocab-search) ( name assocs -- words )
+ [ V{ } clone ] 2dip [ (lookup-word) ] with each ;
+
+: (vocab-search-qualified) ( words name assocs -- words )
+ [ ":" split1 swap ] dip pick [
+ [ name>> = ] with find nip [ (lookup-word) ] with when*
+ ] [
+ 3drop
+ ] if ;
+
+: (vocab-search-full) ( name assocs -- words )
+ [ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
: vocab-search ( name manifest -- word/f )
- search-vocabs>>
- (vocab-search) {
- { 0 [ drop f ] }
- { 1 [ first ] }
+ dupd search-vocabs>> (vocab-search-full) dup length {
+ { 0 [ 2drop f ] }
+ { 1 [ first nip ] }
[
drop <ambiguous-use-error> throw-restarts
dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
} case ;
: qualified-search ( name manifest -- word/f )
- qualified-vocabs>>
- (vocab-search) 0 = [ drop f ] [ last ] if ;
+ qualified-vocabs>> (vocab-search) ?last ;
PRIVATE>
: search-manifest ( name manifest -- word/f )
- 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
+ 2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
: search ( name -- word/f )
manifest get search-manifest ;
GENERIC: update ( search-path-elt -- valid? )
: trim-forgotten ( qualified-vocab -- valid? )
- [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
+ [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
words>> assoc-empty? not ;
M: from update trim-forgotten ;
M: vocab update dup name>> lookup-vocab eq? ;
-: update-manifest ( manifest -- )
- [ dup [ name>> lookup-vocab ] when ] change-current-vocab
- [ [ drop lookup-vocab ] assoc-filter ] change-search-vocab-names
- dup search-vocab-names>> keys [ lookup-vocab ] V{ } map-as >>search-vocabs
- qualified-vocabs>> [ update ] filter! drop ;
+: update-current-vocab ( manifest -- manifest )
+ [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
+
+: compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
+ search-vocab-names>> members dup length <vector> [
+ [ push ] curry [ when* ] curry
+ [ lookup-vocab dup ] prepose filter fast-set
+ ] keep ; inline
+
+: update-search-vocabs ( manifest -- manifest )
+ dup compute-search-vocabs
+ [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
+
+: update-qualified-vocabs ( manifest -- manifest )
+ dup qualified-vocabs>> [ update ] filter! drop ; inline
+
+: update-manifest ( manifest -- manifest )
+ update-current-vocab
+ update-search-vocabs
+ update-qualified-vocabs ; inline
-M: manifest definitions-changed ( assoc manifest -- )
- nip update-manifest ;
+M: manifest definitions-changed
+ nip update-manifest drop ;
PRIVATE>
[ call ] [
[ manifest get add-definition-observer call ]
[ manifest get remove-definition-observer ]
- [ ]
- cleanup
+ finally
] if-bootstrapping
] with-variable ; inline
projects / factor.git / blobdiff