calendar: change >gmt, >local-time to clone.

[factor.git] / core / vocabs / parser / parser.factor

diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor
index 3751db3fba33f654b6652703263a06294ecd9ef9..cec44020512964b0acb6b65607fd96efa5227dd2 100644 (file)
--- a/core/vocabs/parser/parser.factor
+++ b/core/vocabs/parser/parser.factor
@@ -10,12 +10,13 @@ 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 )
@@ -110,10 +111,11 @@ ERROR: unbalanced-private-declaration vocab ;
     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 ]
+        [ [ ?load-vocab ] dip search-vocabs>> push ]
         [ [ vocab-name ] dip search-vocab-names>> adjoin ]
         2bi
     ] if ;
@@ -173,21 +175,36 @@ TUPLE: rename word vocab words ;
 : unuse-words ( assoc -- )
     <extra-words> qualified-vocabs remove! drop ;
 
-TUPLE: ambiguous-use-error words ;
+: with-words ( assoc quot -- )
+    '[ use-words @ ] over '[ _ unuse-words ] finally ; inline
+
+TUPLE: ambiguous-use-error name words ;
 
-: <ambiguous-use-error> ( words -- error restarts )
+: <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
@@ -195,13 +212,12 @@ TUPLE: ambiguous-use-error words ;
     } 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 ;
@@ -258,7 +274,6 @@ PRIVATE>
         [ call ] [
             [ manifest get add-definition-observer call ]
             [ manifest get remove-definition-observer ]
-            [ ]
-            cleanup
+            finally
         ] if-bootstrapping
     ] with-variable ; inline