From: Sam Anklesaria Date: Sun, 24 May 2009 23:57:22 +0000 (-0500) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.97~5838^2~97 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=3b10d4d86ef7d48918def7842cb26b432475353e Merge branch 'master' of git://factorcode.org/git/factor Conflicts: basis/ui/gadgets/tables/tables.factor core/vocabs/parser/parser.factor --- 3b10d4d86ef7d48918def7842cb26b432475353e diff --cc core/vocabs/parser/parser.factor index afa8f20f74,ff55f8e68d..b071a378bc --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@@ -2,58 -2,203 +2,203 @@@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences - sets strings vocabs sorting accessors arrays ; + sets strings vocabs sorting accessors arrays compiler.units + combinators vectors splitting continuations math + parser.notes ; IN: vocabs.parser - + ERROR: no-word-error name ; - - : word-restarts ( name possibilities -- restarts ) + + : word-restarts ( possibilities -- restarts ) natural-sort - [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc + [ [ 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 suffix ; - + : ( name possibilities -- error restarts ) - [ drop \ no-word-error boa ] [ word-restarts ] 2bi ; - - SYMBOL: use - SYMBOL: in - - : (use+) ( vocab -- ) - vocab-words use get push ; - - : use+ ( vocab -- ) - load-vocab (use+) ; - - : add-use ( seq -- ) [ use+ ] each ; - - : set-use ( seq -- ) - [ vocab-words ] V{ } map-as sift use set ; - - : add-qualified ( vocab prefix -- ) - [ load-vocab vocab-words ] [ CHAR: : suffix ] bi* + [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ; + + TUPLE: manifest + current-vocab + { search-vocab-names hashtable } + { search-vocabs vector } + { qualified-vocabs vector } + { extra-words vector } + { auto-used vector } ; + + : ( -- manifest ) + manifest new + H{ } clone >>search-vocab-names + V{ } clone >>search-vocabs + V{ } clone >>qualified-vocabs + V{ } clone >>extra-words + V{ } clone >>auto-used ; + + M: manifest clone + call-next-method + [ clone ] change-search-vocab-names + [ clone ] change-search-vocabs + [ clone ] change-qualified-vocabs + [ clone ] change-extra-words + [ clone ] change-auto-used ; + + TUPLE: extra-words words ; + + M: extra-words equal? + over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ; + + C: extra-words + + > clear-assoc ] + [ search-vocabs>> delete-all ] + [ qualified-vocabs>> delete-all ] + tri ; + + : (add-qualified) ( qualified -- ) + manifest get qualified-vocabs>> push ; + + : (from) ( vocab words -- vocab words words' assoc ) + 2dup swap load-vocab words>> ; + + : extract-words ( seq assoc -- assoc' ) + extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ; + + : (lookup) ( name assoc -- word/f ) + at dup forward-reference? [ drop f ] when ; + + : (use-words) ( assoc -- extra-words seq ) + manifest get qualified-vocabs>> ; + + PRIVATE> + + : set-current-vocab ( name -- ) + create-vocab + [ manifest get (>>current-vocab) ] + [ words>> (add-qualified) ] bi ; + + TUPLE: no-current-vocab ; + + : no-current-vocab ( -- vocab ) + \ no-current-vocab boa + { { "Define words in scratchpad vocabulary" "scratchpad" } } + throw-restarts dup set-current-vocab ; + + : current-vocab ( -- vocab ) + manifest get current-vocab>> [ no-current-vocab ] unless* ; + + : begin-private ( -- ) + manifest get current-vocab>> vocab-name ".private" ?tail + [ drop ] [ ".private" append set-current-vocab ] if ; + + : end-private ( -- ) + manifest get current-vocab>> vocab-name ".private" ?tail + [ set-current-vocab ] [ drop ] if ; + + : using-vocab? ( vocab -- ? ) + vocab-name manifest get search-vocab-names>> key? ; + + : use-vocab ( vocab -- ) + 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 ] + 2bi + ] if ; + + : auto-use-vocab ( vocab -- ) + [ use-vocab ] [ manifest get auto-used>> push ] bi ; + + : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ; + + : unuse-vocab ( vocab -- ) + dup using-vocab? [ + manifest get + [ [ load-vocab ] dip search-vocabs>> delq ] + [ [ vocab-name ] dip search-vocab-names>> delete-at ] + 2bi + ] [ drop ] if ; + + : only-use-vocabs ( vocabs -- ) + clear-manifest [ vocab ] filter [ use-vocab ] each ; + + TUPLE: qualified vocab prefix words ; + + : ( vocab prefix -- qualified ) + 2dup + [ load-vocab words>> ] [ CHAR: : suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map - use get push ; - - : partial-vocab ( words vocab -- assoc ) - load-vocab vocab-words - [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ; - - : add-words-from ( words vocab -- ) - partial-vocab use get push ; - - : partial-vocab-excluding ( words vocab -- assoc ) - load-vocab [ vocab-words keys swap diff ] keep partial-vocab ; - - : add-words-excluding ( words vocab -- ) - partial-vocab-excluding use get push ; - + qualified boa ; + + : add-qualified ( vocab prefix -- ) + (add-qualified) ; + + TUPLE: from vocab names words ; + + : ( vocab words -- from ) + (from) extract-words from boa ; + + : add-words-from ( vocab words -- ) + (add-qualified) ; + + TUPLE: exclude vocab names words ; + + : ( vocab words -- from ) + (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ; + + : add-words-excluding ( vocab words -- ) + (add-qualified) ; + + TUPLE: rename word vocab words ; + + : ( word vocab new-name -- rename ) + [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip + associate rename boa ; + : add-renamed-word ( word vocab new-name -- ) - [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip - associate use get push ; - - : check-vocab-string ( name -- name ) - dup string? [ "Vocabulary name must be a string" throw ] unless ; - - : set-in ( name -- ) - check-vocab-string dup in set create-vocab (use+) ; + (add-qualified) ; + + : use-words ( assoc -- ) (use-words) push ; + + : unuse-words ( assoc -- ) (use-words) delete ; + + TUPLE: ambiguous-use-error words ; + + : ( words -- error restarts ) + [ \ ambiguous-use-error boa ] [ word-restarts ] bi ; + + > (lookup) ] with map + sift dup length ; + + : vocab-search ( name manifest -- word/f ) + search-vocabs>> + (vocab-search) { + { 0 [ drop f ] } + { 1 [ first ] } + [ + drop throw-restarts + dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from + ] + } case ; + + : qualified-search ( name manifest -- word/f ) + qualified-vocabs>> + (vocab-search) 0 = [ drop f ] [ peek ] if ; + + PRIVATE> + + : search-manifest ( name manifest -- word/f ) + 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ; + + : search ( name -- word/f ) - manifest get search-manifest ; ++ manifest get search-manifest ;