Add parse-quotation hook to parser which locals overrides. '[ and [ use this hook. Fixes locals bug reported by erg

basis/fry/fry.factor

@@ -53,4 +53,4 @@ M: callable deep-fry
 
 M: object deep-fry , ;
 
-: '[ \ ] parse-until fry over push-all ; parsing
+: '[ parse-quotation fry over push-all ; parsing

basis/functors/functors.factor

@@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter
     functor-words use get delq ;
 
 : parse-functor-body ( -- form )
-    t in-lambda? [
+    push-functor-words
-        V{ } clone
+    "WHERE" parse-bindings*
-        push-functor-words
+    [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
-        "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
+    pop-functor-words ;
-        <let*> parsed-lambda
-        pop-functor-words
-        >quotation
-    ] with-variable ;
 
 : (FUNCTOR:) ( -- word def )
-    CREATE
+    CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
-    parse-locals dup push-locals
-    parse-functor-body swap pop-locals <lambda>
-    rewrite-closures first ;
 
 PRIVATE>
 

basis/locals/errors/errors.factor

@@ -29,12 +29,12 @@ ERROR: :>-outside-lambda-error ;
 M: :>-outside-lambda-error summary
     drop ":> cannot be used outside of lambda expressions" ;
 
-ERROR: bad-lambda-rewrite output ;
-
-M: bad-lambda-rewrite summary
-    drop "You have found a bug in locals. Please report." ;
-
 ERROR: bad-local args obj ;
 
 M: bad-local summary
     drop "You have found a bug in locals. Please report." ;
+
+ERROR: bad-rewrite args obj ;
+
+M: bad-rewrite summary
+    drop "You have found a bug in locals. Please report." ;

basis/locals/locals-docs.factor

@@ -134,19 +134,30 @@ $nl
     "ordinary-word-test ordinary-word-test eq? ."
     "t"
 }
-"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+"In a word with locals, literals which do not contain locals still behave in the same way:"
 { $example
     "USE: locals"
     "IN: scratchpad"
     "TUPLE: person first-name last-name ;"
-    ":: ordinary-word-test ( -- tuple )"
+    ":: locals-word-test ( -- tuple )"
     "    T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
-    "ordinary-word-test ordinary-word-test eq? ."
+    "locals-word-test locals-word-test eq? ."
+    "t"
+}
+"However, literals with locals in them actually expand into code for constructing a new object:"
+{ $example
+    "USING: locals splitting ;"
+    "IN: scratchpad"
+    "TUPLE: person first-name last-name ;"
+    ":: constructor-test ( -- tuple )"
+    "    \"Jane Smith\" \" \" split1 :> last :> first"
+    "    T{ person { first-name first } { last-name last } } ;"
+    "constructor-test constructor-test eq? ."
     "f"
 }
 "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
 { $heading "Example" }
-"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+"Here is an implementation of the " { $link 3array } " word which uses this feature:"
 { $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
 
 ARTICLE: "locals-mutable" "Mutable locals"

basis/locals/locals-tests.factor

@@ -357,12 +357,12 @@ ERROR: punned-class x ;
 [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
 
 :: literal-identity-test ( -- a b )
-    { } V{ } ;
+    { 1 } V{ } ;
 
-[ t f ] [
+[ t t ] [
     literal-identity-test
     literal-identity-test
-    swapd [ eq? ] [ eq? ] 2bi*
+    [ eq? ] [ eq? ] bi-curry* bi*
 ] unit-test
 
 :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
@@ -401,9 +401,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
 
 [
-    "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+    "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
+    eval call
 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
-
+    
 :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
 : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
 
@@ -503,8 +504,14 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
 
 ! erg found this problem
-:: erg's-:>-bug ( n ? -- n ) [ n :> n n ] [ n :> b b ] if ;
+:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
 
 [ 3 ] [ 3 f erg's-:>-bug ] unit-test
     
-[ 3 ] [ 3 t erg's-:>-bug ] unit-test
+[ 3 ] [ 3 t erg's-:>-bug ] unit-test
+
+:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
+
+[ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
+    
+[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test

basis/locals/locals.factor

@@ -9,19 +9,13 @@ IN: locals
     scan locals get [ :>-outside-lambda-error ] unless*
     [ make-local ] bind <def> parsed ; parsing
 
-: [| parse-lambda parsed-lambda ; parsing
+: [| parse-lambda over push-all ; parsing
 
-: [let
+: [let parse-let over push-all ; parsing
-    "|" expect "|" parse-bindings
-    \ ] (parse-lambda) <let> parsed-lambda ; parsing
 
-: [let*
+: [let* parse-let* over push-all ; parsing
-    "|" expect "|" parse-bindings*
-    \ ] (parse-lambda) <let*> parsed-lambda ; parsing
 
-: [wlet
+: [wlet parse-wlet over push-all ; parsing
-    "|" expect "|" parse-wbindings
-    \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
 
 : :: (::) define ; parsing
 
@@ -31,6 +25,8 @@ IN: locals
 
 : MEMO:: (::) define-memoized ; parsing
 
+USE: syntax
+
 {
     "locals.macros"
     "locals.fry"

basis/locals/parser/parser.factor

@@ -6,6 +6,11 @@ locals.rewrite.closures locals.types make namespaces parser
 quotations sequences splitting words vocabs.parser ;
 IN: locals.parser
 
+SYMBOL: in-lambda?
+
+: ?rewrite-closures ( form -- form' )
+    in-lambda? get [ 1array ] [ rewrite-closures ] if ;
+
 : make-local ( name -- word )
     "!" ?tail [
         <local-reader>
@@ -20,28 +25,33 @@ IN: locals.parser
     [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
     "local-word-def" set-word-prop ;
 
-SYMBOL: locals
-
 : push-locals ( assoc -- )
     use get push ;
 
 : pop-locals ( assoc -- )
-    use get delete ;
+    use get delq ;
 
-SYMBOL: in-lambda?
+SINGLETON: lambda-parser
 
-: (parse-lambda) ( assoc end -- quot )
+SYMBOL: locals
-    [
+
+: ((parse-lambda)) ( assoc quot -- quot' )
+    '[
         in-lambda? on
-        over locals set
+        lambda-parser quotation-parser set
-        over push-locals
+        [ locals set ] [ push-locals @ ] [ pop-locals ] tri
-        parse-until >quotation
+    ] with-scope ; inline
-        swap pop-locals
+    
-    ] with-scope ;
+: (parse-lambda) ( assoc -- quot )
+    [ \ ] parse-until >quotation ] ((parse-lambda)) ;
 
 : parse-lambda ( -- lambda )
     "|" parse-tokens make-locals
-    \ ] (parse-lambda) <lambda> ;
+    (parse-lambda) <lambda>
+    ?rewrite-closures ;
+
+M: lambda-parser parse-quotation ( -- quotation )
+    H{ } clone (parse-lambda) ;
 
 : parse-binding ( end -- pair/f )
     scan {
@@ -65,6 +75,10 @@ SYMBOL: in-lambda?
 : parse-bindings ( end -- bindings vars )
     [ (parse-bindings) ] with-bindings ;
 
+: parse-let ( -- form )
+    "|" expect "|" parse-bindings
+    (parse-lambda) <let> ?rewrite-closures ;
+
 : parse-bindings* ( end -- words assoc )
     [
         namespace push-locals
@@ -72,6 +86,10 @@ SYMBOL: in-lambda?
         namespace pop-locals
     ] with-bindings ;
 
+: parse-let* ( -- form )
+    "|" expect "|" parse-bindings*
+    (parse-lambda) <let*> ?rewrite-closures ;
+
 : (parse-wbindings) ( end -- )
     dup parse-binding dup [
         first2 [ make-local-word ] keep 2array ,
@@ -81,21 +99,29 @@ SYMBOL: in-lambda?
 : parse-wbindings ( end -- bindings vars )
     [ (parse-wbindings) ] with-bindings ;
 
+: parse-wlet ( -- form )
+    "|" expect "|" parse-wbindings
+    (parse-lambda) <wlet> ?rewrite-closures ;
+
 : parse-locals ( -- vars assoc )
     "(" expect ")" parse-effect
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals ;
 
-: parse-locals-definition ( word -- word quot )
+: parse-locals-definition ( word reader -- word quot )
-    parse-locals \ ; (parse-lambda) <lambda>
+    [ parse-locals ] dip
+    ((parse-lambda)) <lambda>
     [ "lambda" set-word-prop ]
-    [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
+    [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
 
-: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def )
+    CREATE-WORD
+    [ parse-definition ]
+    parse-locals-definition ;
 
 : (M::) ( -- word def )
     CREATE-METHOD
-    [ parse-locals-definition ] with-method-definition ;
+    [
-
+        [ parse-definition ] 
-: parsed-lambda ( accum form -- accum )
+        parse-locals-definition
-    in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;
+    ] with-method-definition ;

basis/locals/rewrite/sugar/sugar.factor

@@ -37,13 +37,13 @@ M: array rewrite-literal? [ rewrite-literal? ] any? ;
 
 M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
 
+M: vector rewrite-literal? [ rewrite-literal? ] any? ;
+
 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
 
-M: hashtable rewrite-literal? drop t ;
+M: hashtable rewrite-literal? >alist rewrite-literal? ;
 
-M: vector rewrite-literal? drop t ;
+M: tuple rewrite-literal? tuple>array rewrite-literal? ;
-
-M: tuple rewrite-literal? drop t ;
 
 M: object rewrite-literal? drop f ;
 
@@ -58,12 +58,16 @@ GENERIC: rewrite-element ( obj -- )
 M: array rewrite-element
     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
-M: vector rewrite-element rewrite-sequence ;
+M: vector rewrite-element
+    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
-M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+M: hashtable rewrite-element
+    dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
 
 M: tuple rewrite-element
-    [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
+    dup rewrite-literal? [
+        [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] %
+    ] [ , ] if ;
 
 M: quotation rewrite-element rewrite-sugar* ;
 

core/parser/parser-tests.factor

@@ -556,3 +556,17 @@ EXCLUDE: qualified.tests.bar => x ;
 
 [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
 [ error>> no-word-error? ] must-fail-with
+
+[ [ ] ] [
+    "IN: parser.tests : was-once-a-word-bug ( -- ) ;"
+    <string-reader> "was-once-a-word-test" parse-stream
+] unit-test
+
+[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+    "IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] (( -- )) define-declared >>"
+    <string-reader> "was-once-a-word-test" parse-stream
+] unit-test
+
+[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test

core/parser/parser.factor

@@ -113,12 +113,16 @@ ERROR: staging-violation word ;
 : parse-until ( end -- vec )
     100 <vector> swap (parse-until) ;
 
+SYMBOL: quotation-parser
+
+HOOK: parse-quotation quotation-parser ( -- quot )
+
+M: f parse-quotation \ ] parse-until >quotation ;
+
 : parsed ( accum obj -- accum ) over push ;
 
 : (parse-lines) ( lexer -- quot )
-    [
+    [ f parse-until >quotation ] with-lexer ;
-        f parse-until >quotation
-    ] with-lexer ;
 
 : parse-lines ( lines -- quot )
     lexer-factory get call (parse-lines) ;

core/syntax/syntax.factor

@@ -94,7 +94,7 @@ IN: bootstrap.syntax
         lexer get skip-blank parse-string <pathname> parsed
     ] define-syntax
 
-    "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
+    "[" [ parse-quotation parsed ] define-syntax
     "{" [ \ } [ >array ] parse-literal ] define-syntax
     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax

extra/literals/literals-tests.factor

@@ -2,11 +2,11 @@ USING: kernel literals math tools.test ;
 IN: literals.tests
 
 <<
-: six-six-six 6 6 6 ;
+: six-six-six ( -- a b c ) 6 6 6 ;
 >>
 
-: five 5 ;
+: five ( -- a ) 5 ;
-: seven-eleven 7 11 ;
+: seven-eleven ( -- b c ) 7 11 ;
 
 [ { 5 } ] [ { $ five } ] unit-test
 [ { 7 11 } ] [ { $ seven-eleven } ] unit-test

extra/literals/literals.factor

@@ -3,4 +3,4 @@ USING: accessors continuations kernel parser words quotations vectors ;
 IN: literals
 
 : $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
-: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
+: $[ parse-quotation with-datastack >vector ; parsing