Implement stricter vocab search path semantics, with a new API for vocabs.parser. Add map-find-last to sequences vocab

basis/alien/complex/functor/functor.factor

@@ -23,7 +23,7 @@ WHERE
 : *T ( alien -- z )
     [ T-real ] [ T-imaginary ] bi rect> ; inline
 
-T in get
+T current-vocab
 { { N "real" } { N "imaginary" } }
 define-struct
 

basis/alien/syntax/syntax.factor

@@ -22,7 +22,7 @@ SYNTAX: TYPEDEF:
     scan scan typedef ;
 
 SYNTAX: C-STRUCT:
-    scan in get parse-definition define-struct ;
+    scan current-vocab parse-definition define-struct ;
 
 SYNTAX: C-UNION:
     scan parse-definition define-union ;

basis/command-line/command-line.factor

@@ -69,6 +69,4 @@ SYMBOL: main-vocab-hook
 : ignore-cli-args? ( -- ? )
     os macosx? "run" get "ui" = and ;
 
-: script-mode ( -- ) ;
-
 [ default-cli-args ] "command-line" add-init-hook

basis/functors/functors.factor

@@ -146,10 +146,10 @@ DEFER: ;FUNCTOR delimiter
     } ;
 
 : push-functor-words ( -- )
-    functor-words use get push ;
+    functor-words use-words ;
 
 : pop-functor-words ( -- )
-    functor-words use get delq ;
+    functor-words unuse-words ;
 
 : parse-functor-body ( -- form )
     push-functor-words

basis/help/syntax/syntax.factor

@@ -16,4 +16,4 @@ SYNTAX: ARTICLE:
     ] dip remember-definition ;
 
 SYNTAX: ABOUT:
-    in get vocab scan-object >>help changed-definition ;
+    current-vocab scan-object >>help changed-definition ;

basis/io/sockets/sockets.factor

@@ -11,7 +11,7 @@ IN: io.sockets
 << {
     { [ os windows? ] [ "windows.winsock" ] }
     { [ os unix? ] [ "unix" ] }
-} cond add-ambiguous-use >>
+} cond use-vocab >>
 
 ! Addressing
 GENERIC: protocol-family ( addrspec -- af )

basis/listener/listener-tests.factor

@@ -15,7 +15,7 @@ SYNTAX: hello "Hi" print ;
 ] with-file-vocabs
 
 [
-    "debugger" add-use
+    "debugger" add-ambiguous-use
 
     [ [ \ + 1 2 3 4 ] ]
     [

basis/listener/listener.factor

@@ -10,7 +10,7 @@ IN: listener
 GENERIC: stream-read-quot ( stream -- quot/f )
 
 : parse-lines-interactive ( lines -- quot/f )
-    [ parse-lines in get ] with-compilation-unit in set ;
+    [ parse-lines ] with-compilation-unit ;
 
 : read-quot-step ( lines -- quot/f )
     [ parse-lines-interactive ] [
@@ -98,7 +98,7 @@ t error-summary? set-global
     ] [ drop ] if ;
 
 : prompt. ( -- )
-    in get auto-use? get [ " - auto" append ] when "( " " )" surround
+    current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround
     H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
 
 :: (listener) ( datastack -- )

basis/locals/parser/parser.factor

@@ -25,12 +25,6 @@ SYMBOL: in-lambda?
     [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
     "local-word-def" set-word-prop ;
 
-: push-locals ( assoc -- )
-    use get push ;
-
-: pop-locals ( assoc -- )
-    use get delq ;
-
 SINGLETON: lambda-parser
 
 SYMBOL: locals
@@ -39,7 +33,9 @@ SYMBOL: locals
     '[
         in-lambda? on
         lambda-parser quotation-parser set
-        [ locals set ] [ push-locals @ ] [ pop-locals ] tri
+        [ locals set ]
+        [ use-words @ ]
+        [ unuse-words ] tri
     ] with-scope ; inline
     
 : (parse-lambda) ( assoc -- quot )
@@ -81,9 +77,9 @@ M: lambda-parser parse-quotation ( -- quotation )
 
 : parse-bindings* ( end -- words assoc )
     [
-        namespace push-locals
+        namespace use-words
         (parse-bindings)
-        namespace pop-locals
+        namespace unuse-words
     ] with-bindings ;
 
 : parse-let* ( -- form )

basis/opengl/gl/extensions/extensions.factor

@@ -9,7 +9,7 @@ ERROR: unknown-gl-platform ;
     { [ os macosx? ]  [ "opengl.gl.macosx" ] }
     { [ os unix? ] [ "opengl.gl.unix" ] }
     [ unknown-gl-platform ]
-} cond add-use >>
+} cond use-vocab >>
 
 SYMBOL: +gl-function-number-counter+
 SYMBOL: +gl-function-pointers+

basis/ui/pixel-formats/pixel-formats-docs.factor

@@ -1,12 +1,12 @@
 USING: destructors help.markup help.syntax kernel math multiline sequences
-vocabs vocabs.parser words ;
+vocabs vocabs.parser words namespaces ;
 IN: ui.pixel-formats
 
 ! break circular dependency
 <<
     "ui.gadgets.worlds" create-vocab drop
     "world" "ui.gadgets.worlds" create drop
-    "ui.gadgets.worlds" (add-use)
+    "ui.gadgets.worlds" vocab-words use-words
 >>
 
 ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"

basis/ui/tools/listener/listener.factor

@@ -38,13 +38,12 @@ output history flag mailbox thread waiting token-model word-model popup ;
         [ thread>> dup [ thread-registered? ] when ]
     } 1&& not ;
 
-SLOT: vocabs
+SLOT: manifest
 
-M: interactor vocabs>>
+M: interactor manifest>>
     dup interactor-busy? [ drop f ] [
-        use swap
         interactor-continuation name>>
-        assoc-stack
+        manifest swap assoc-stack
     ] if ;
 
 : vocab-exists? ( name -- ? )
@@ -56,7 +55,7 @@ M: vocab-completion (word-at-caret)
     drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
 
 M: word-completion (word-at-caret)
-    vocabs>> assoc-stack ;
+    manifest>> search-manifest ;
 
 M: char-completion (word-at-caret)
     2drop f ;
@@ -300,15 +299,15 @@ M: listener-operation invoke-command ( target command -- )
 : clear-stack ( listener -- )
     [ [ clear ] \ clear ] dip (call-listener) ;
 
-: use-if-necessary ( word seq -- )
+: use-if-necessary ( word manifest -- )
     2dup [ vocabulary>> ] dip and [
-        2dup [ assoc-stack ] keep = [ 2drop ] [
+        manifest [
-            [ vocabulary>> vocab-words ] dip push
+            vocabulary>> use-vocab
-        ] if
+        ] with-variable
     ] [ 2drop ] if ;
 
 M: word accept-completion-hook
-    interactor>> vocabs>> use-if-necessary ;
+    interactor>> manifest>> use-if-necessary ;
 
 M: object accept-completion-hook 2drop ;
 

basis/ui/tools/operations/operations.factor

@@ -131,13 +131,13 @@ M: quotation com-stack-effect infer. ;
 
 M: word com-stack-effect 1quotation com-stack-effect ;
 
-: com-enter-in ( vocab -- ) vocab-name set-in ;
+: com-enter-in ( vocab -- ) vocab-name set-current-vocab ;
 
 [ vocab? ] \ com-enter-in H{
     { +listener+ t }
 } define-operation
 
-: com-use-vocab ( vocab -- ) vocab-name add-use ;
+: com-use-vocab ( vocab -- ) vocab-name use-vocab ;
 
 [ vocab-spec? ] \ com-use-vocab H{
     { +secondary+ t }

core/bootstrap/stage1.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays debugger generic hashtables io assocs
+USING: arrays debugger generic hashtables io assocs kernel.private
-kernel.private kernel math memory namespaces make parser
+kernel math memory namespaces make parser prettyprint sequences
-prettyprint sequences vectors words system splitting
+vectors words system splitting init io.files vocabs vocabs.loader
-init io.files bootstrap.image bootstrap.image.private vocabs
+debugger continuations ;
-vocabs.loader system debugger continuations ;
+QUALIFIED: bootstrap.image.private
 IN: bootstrap.stage1
 
 "Bootstrap stage 1..." print flush
@@ -51,4 +51,4 @@ load-help? off
         ] if
     ] %
 ] [ ] make
-bootstrap-boot-quot set
+bootstrap.image.private:bootstrap-boot-quot set

core/classes/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser words kernel classes compiler.units lexer ;
+USING: parser vocabs.parser words kernel classes compiler.units lexer ;
 IN: classes.parser
 
 : save-class-location ( class -- )

core/init/init.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations continuations.private kernel
-kernel.private sequences assocs namespaces namespaces.private
+kernel.private sequences assocs namespaces namespaces.private ;
-continuations continuations.private ;
 IN: init
 
 SYMBOL: init-hooks

core/io/backend/backend.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting alien ;
+io.encodings.utf8 assocs splitting alien ;
 IN: io.backend
 
 SYMBOL: io-backend

core/parser/parser.factor

@@ -31,16 +31,6 @@ t parser-notes set-global
 
 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
 
-TUPLE: no-current-vocab ;
-
-: no-current-vocab ( -- vocab )
-    \ no-current-vocab boa
-    { { "Define words in scratchpad vocabulary" "scratchpad" } }
-    throw-restarts dup set-in ;
-
-: current-vocab ( -- str )
-    in get [ no-current-vocab ] unless* ;
-
 : create-in ( str -- word )
     current-vocab create dup set-word dup save-location ;
 
@@ -55,7 +45,7 @@ SYMBOL: auto-use?
 : no-word-restarted ( restart-value -- word )
     dup word? [
         dup vocabulary>>
-        [ (add-use) ]
+        [ use-vocab ]
         [ amended-use get dup [ push ] [ 2drop ] if ]
         [ "Added \"" "\" vocabulary to search path" surround note. ]
         tri
@@ -134,8 +124,9 @@ SYMBOL: bootstrap-syntax
 
 : with-file-vocabs ( quot -- )
     [
-        f in set { "syntax" } set-use
+        <manifest> manifest set
-        bootstrap-syntax get [ use get push ] when*
+        "syntax" use-vocab
+        bootstrap-syntax get [ use-words ] when*
         call
     ] with-scope ; inline
 
@@ -195,8 +186,9 @@ SYMBOL: interactive-vocabs
 
 : with-interactive-vocabs ( quot -- )
     [
-        "scratchpad" in set
+        <manifest> manifest set
-        interactive-vocabs get set-use
+        "scratchpad" set-current-vocab
+        interactive-vocabs get only-use-vocabs
         call
     ] with-scope ; inline
 

core/sbufs/sbufs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math strings sequences.private sequences
+USING: accessors kernel math sequences.private sequences
 strings growable strings.private ;
 IN: sbufs
 

core/sequences/sequences.factor

@@ -834,11 +834,20 @@ PRIVATE>
     [ [ 2unclip-slice ] dip [ call ] keep ] dip
     compose 2reduce ; inline
 
-: map-find ( seq quot -- result elt )
+<PRIVATE
-    [ f ] 2dip
+
-    [ [ nip ] dip call dup ] curry find
+: (map-find) ( seq quot find-quot -- result elt )
+    [ [ f ] 2dip [ [ nip ] dip call dup ] curry ] dip call
     [ [ drop f ] unless ] dip ; inline
 
+PRIVATE>
+
+: map-find ( seq quot -- result elt )
+    [ find ] (map-find) ; inline
+
+: map-find-last ( seq quot -- result elt )
+    [ find-last ] (map-find) ; inline
+
 : unclip-last-slice ( seq -- butlast-slice last )
     [ but-last-slice ] [ peek ] bi ; inline
 

core/slots/slots.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays kernel kernel.private math namespaces
-make sequences strings words effects generic generic.standard
+make sequences strings effects generic generic.standard
 classes classes.algebra slots.private combinators accessors
 words sequences.private assocs alien quotations hashtables ;
 IN: slots

core/sorting/sorting.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences vectors math.order
+USING: accessors arrays kernel math vectors math.order
-sequences sequences.private math.order ;
+sequences sequences.private ;
 IN: sorting
 
 ! Optimized merge-sort:

core/syntax/syntax.factor

@@ -41,28 +41,26 @@ IN: bootstrap.syntax
 
     "#!" [ POSTPONE: ! ] define-core-syntax
 
-    "IN:" [ scan set-in ] define-core-syntax
+    "IN:" [ scan set-current-vocab ] define-core-syntax
 
-    "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-core-syntax
+    "<PRIVATE" [ begin-private ] define-core-syntax
 
-    "<PRIVATE" [
+    "PRIVATE>" [ end-private ] define-core-syntax
-        POSTPONE: PRIVATE> in get ".private" append set-in
-    ] define-core-syntax
 
-    "USE:" [ scan add-use ] define-core-syntax
+    "USE:" [ scan use-vocab ] define-core-syntax
 
-    "USING:" [ ";" parse-tokens [ add-use ] each ] define-core-syntax
+    "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
 
     "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
 
     "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
 
     "FROM:" [
-        scan "=>" expect ";" parse-tokens swap add-words-from
+        scan "=>" expect ";" parse-tokens add-words-from
     ] define-core-syntax
 
     "EXCLUDE:" [
-        scan "=>" expect ";" parse-tokens swap add-words-excluding
+        scan "=>" expect ";" parse-tokens add-words-excluding
     ] define-core-syntax
 
     "RENAME:" [
@@ -227,7 +225,7 @@ IN: bootstrap.syntax
         "))" parse-effect parsed
     ] define-core-syntax
 
-    "MAIN:" [ scan-word in get vocab (>>main) ] define-core-syntax
+    "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax
 
     "<<" [
         [

core/vocabs/parser/parser.factor

@@ -2,11 +2,167 @@
 ! 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 ;
+sets strings vocabs sorting accessors arrays compiler.units
+combinators vectors splitting continuations ;
 IN: vocabs.parser
 
 ERROR: no-word-error name ;
 
+TUPLE: manifest
+current-vocab
+{ search-vocabs vector }
+{ qualified-vocabs vector }
+{ extra-words vector } ;
+
+: <manifest> ( -- manifest )
+    manifest new
+        V{ } clone >>search-vocabs
+        V{ } clone >>qualified-vocabs
+        V{ } clone >>extra-words ;
+
+M: manifest clone
+    call-next-method
+        [ clone ] change-search-vocabs
+        [ clone ] change-qualified-vocabs
+        [ clone ] change-extra-words ;
+
+<PRIVATE
+
+: clear-manifest ( -- )
+    manifest get
+    [ search-vocabs>> delete-all ]
+    [ qualified-vocabs>> delete-all ]
+    [ extra-words>> delete-all ]
+    tri ;
+
+: (use-vocab) ( vocab -- vocab seq )
+    load-vocab manifest get search-vocabs>> ;
+
+: (add-qualified) ( qualified -- )
+    manifest get qualified-vocabs>> push ;
+
+: (from) ( vocab words -- vocab words words' assoc )
+    2dup swap load-vocab words>> ;
+
+: (use-words) ( assoc -- assoc seq )
+    manifest get extra-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 ;
+
+PRIVATE>
+
+: set-current-vocab ( name -- )
+    create-vocab manifest get
+    [ (>>current-vocab) ]
+    [ [ words>> ] dip extra-words>> push ]
+    2bi ; 
+
+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 ;
+
+: use-vocab ( vocab -- ) (use-vocab) push ;
+
+: unuse-vocab ( vocab -- ) (use-vocab) delq ;
+
+: only-use-vocabs ( vocabs -- )
+    clear-manifest
+    [ vocab ] V{ } map-as sift
+    manifest get search-vocabs>> push-all ;
+
+TUPLE: qualified vocab prefix words ;
+
+: <qualified> ( vocab prefix -- qualified )
+    2dup
+    [ load-vocab words>> ] [ CHAR: : suffix ] bi*
+    [ swap [ prepend ] dip ] curry assoc-map
+    qualified boa ;
+
+: add-qualified ( vocab prefix -- )
+    <qualified> (add-qualified) ;
+
+TUPLE: from vocab names words ;
+
+: <from> ( vocab words -- from )
+    (from) extract-words from boa ;
+
+: add-words-from ( vocab words -- )
+    <from> (add-qualified) ;
+
+TUPLE: exclude vocab names words ;
+
+: <exclude> ( vocab words -- from )
+    (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
+
+: add-words-excluding ( vocab words -- )
+    <exclude> (add-qualified) ;
+
+TUPLE: rename word vocab words ;
+
+: <rename> ( 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 -- )
+    <rename> (add-qualified) ;
+
+: use-words ( words -- ) (use-words) push ;
+
+: unuse-words ( words -- ) (use-words) delq ;
+
+ERROR: ambiguous-use-error words ;
+
+<PRIVATE
+
+: (vocab-search) ( name assocs -- words n )
+    [ words>> (lookup) ] with map
+    sift dup length ;
+
+: vocab-search ( name manifest -- word/f )
+    search-vocabs>>
+    (vocab-search) {
+        { 0 [ drop f ] }
+        { 1 [ first ] }
+        [ drop ambiguous-use-error ]
+    } case ;
+
+: qualified-search ( name manifest -- word/f )
+    qualified-vocabs>>
+    (vocab-search) 0 = [ drop f ] [ peek ] if ;
+
+: word-search ( name manifest -- word/f )
+    extra-words>> [ (lookup) ] with map-find-last drop ;
+
+PRIVATE>
+
+: search-manifest ( name manifest -- word/f )
+    2dup word-search dup [ 2nip ] [
+        drop 2dup qualified-search dup [ 2nip ] [
+            drop vocab-search
+        ] if
+    ] if ;
+
+: search ( name -- word/f )
+    manifest get search-manifest ;
+
 : word-restarts ( name possibilities -- restarts )
     natural-sort
     [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
@@ -15,58 +171,3 @@ ERROR: no-word-error name ;
 
 : <no-word-error> ( name possibilities -- error restarts )
     [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
-
-SYMBOL: use
-SYMBOL: in
-
-: (add-use) ( vocab -- )
-    vocab-words use get push ;
-
-: add-use ( vocab -- )
-    load-vocab (add-use) ;
-
-: set-use ( seq -- )
-    [ vocab-words ] V{ } map-as sift use set ;
-
-: add-qualified ( vocab prefix -- )
-    [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
-    [ swap [ prepend ] dip ] curry assoc-map
-    use get push ;
-
-: words-named-in ( words assoc -- assoc' )
-    [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
-
-: partial-vocab-including ( words vocab -- assoc )
-    load-vocab vocab-words words-named-in ;
-
-: add-words-from ( words vocab -- )
-    partial-vocab-including use get push ;
-
-: partial-vocab-excluding ( words vocab -- assoc )
-    load-vocab vocab-words [ nip ] [ words-named-in ] 2bi assoc-diff ;
-
-: add-words-excluding ( words vocab -- )
-    partial-vocab-excluding use get push ;
-
-: 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 (add-use) ;
-
-: check-forward ( str word -- word/f )
-    dup forward-reference? [
-        drop
-        use get
-        [ at ] with map sift
-        [ forward-reference? not ] find-last nip
-    ] [
-        nip
-    ] if ;
-
-: search ( str -- word/f )
-    dup use get assoc-stack check-forward ;

core/vocabs/vocabs.factor

@@ -78,7 +78,13 @@ GENERIC: vocabs-changed ( obj -- )
 : notify-vocab-observers ( -- )
     vocab-observers get [ vocabs-changed ] each ;
 
+ERROR: bad-vocab-name name ;
+
+: check-vocab-name ( name -- name )
+    dup string? [ bad-vocab-name ] unless ;
+
 : create-vocab ( name -- vocab )
+    check-vocab-name
     dictionary get [ <vocab> ] cache
     notify-vocab-observers ;
 

core/words/words.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions graphs assocs kernel
+USING: accessors arrays definitions graphs kernel
-kernel.private kernel.private slots.private math namespaces sequences
+kernel.private slots.private math namespaces sequences
 strings vectors sbufs quotations assocs hashtables sorting vocabs
 math.order sets ;
 IN: words
@@ -180,12 +180,12 @@ M: word reset-word
 ERROR: bad-create name vocab ;
 
 : check-create ( name vocab -- name vocab )
-    2dup [ string? ] both?
+    2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
     [ bad-create ] unless ;
 
 : create ( name vocab -- word )
     check-create 2dup lookup
-    dup [ 2nip ] [ drop <word> dup reveal ] if ;
+    dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
 
 : constructor-word ( name vocab -- word )
     [ "<" ">" surround ] dip create ;

extra/infix/infix.factor

@@ -85,12 +85,10 @@ SYNTAX: [infix
     "infix]" [infix-parse parsed \ call parsed ;
 
 <PRIVATE
+
 : parse-infix-locals ( assoc end -- quot )
-    [
+    '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
-        in-lambda? on
+
-        [ dup [ locals set ] [ push-locals ] bi ] dip
-        [infix-parse prepare-operand swap pop-locals
-    ] with-scope ;
 PRIVATE>
 
 SYNTAX: [infix|