diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index e62a42749f..9ffad43cf4 100644 --- a/basis/fry/fry.factor +++ b/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 diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 0b9c9caa45..6592a3c4f2 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter functor-words use get delq ; : parse-functor-body ( -- form ) - t in-lambda? [ - V{ } clone - push-functor-words - "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda) - parsed-lambda - pop-functor-words - >quotation - ] with-variable ; + push-functor-words + "WHERE" parse-bindings* + [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) 1quotation + pop-functor-words ; : (FUNCTOR:) ( -- word def ) - CREATE - parse-locals dup push-locals - parse-functor-body swap pop-locals - rewrite-closures first ; + CREATE-WORD [ parse-functor-body ] parse-locals-definition ; PRIVATE> diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor index d11405ddb5..e7b4c5a884 100644 --- a/basis/locals/errors/errors.factor +++ b/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." ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index a4a9ca448b..0998d84530 100644 --- a/basis/locals/locals-docs.factor +++ b/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" diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 08c667447c..2f5c72a53c 100644 --- a/basis/locals/locals-tests.factor +++ b/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 \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index f745f6243f..190be61e23 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -9,19 +9,13 @@ IN: locals scan locals get [ :>-outside-lambda-error ] unless* [ make-local ] bind parsed ; parsing -: [| parse-lambda parsed-lambda ; parsing +: [| parse-lambda over push-all ; parsing -: [let - "|" expect "|" parse-bindings - \ ] (parse-lambda) parsed-lambda ; parsing +: [let parse-let over push-all ; parsing -: [let* - "|" expect "|" parse-bindings* - \ ] (parse-lambda) parsed-lambda ; parsing +: [let* parse-let* over push-all ; parsing -: [wlet - "|" expect "|" parse-wbindings - \ ] (parse-lambda) parsed-lambda ; parsing +: [wlet parse-wlet over push-all ; parsing : :: (::) define ; parsing @@ -31,6 +25,8 @@ IN: locals : MEMO:: (::) define-memoized ; parsing +USE: syntax + { "locals.macros" "locals.fry" diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index f6baaf9ba7..d987e2c91d 100644 --- a/basis/locals/parser/parser.factor +++ b/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 [ @@ -20,28 +25,33 @@ IN: locals.parser [ [ 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 - over push-locals - parse-until >quotation - swap pop-locals - ] with-scope ; + lambda-parser quotation-parser set + [ locals set ] [ push-locals @ ] [ pop-locals ] tri + ] with-scope ; inline + +: (parse-lambda) ( assoc -- quot ) + [ \ ] parse-until >quotation ] ((parse-lambda)) ; : parse-lambda ( -- lambda ) "|" parse-tokens make-locals - \ ] (parse-lambda) ; + (parse-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) ?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) ?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) ?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 \ ; (parse-lambda) +: parse-locals-definition ( word reader -- word quot ) + [ parse-locals ] dip + ((parse-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 ; - -: parsed-lambda ( accum form -- accum ) - in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ; + [ + [ parse-definition ] + parse-locals-definition + ] with-method-definition ; \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index f0b8ac7240..87568d596a 100755 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/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? drop t ; +M: tuple rewrite-literal? tuple>array rewrite-literal? ; 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* ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3fcf489413..9284f8949b 100644 --- a/core/parser/parser-tests.factor +++ b/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 ( -- ) ;" + "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 >>" + "was-once-a-word-test" parse-stream +] unit-test + +[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cbf8754821..e39422945e 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -113,12 +113,16 @@ ERROR: staging-violation word ; : parse-until ( end -- vec ) 100 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) ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index af5fa38aeb..8ee8b27fbc 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -94,7 +94,7 @@ IN: bootstrap.syntax lexer get skip-blank parse-string 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 diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 0e933d5209..024c94e4f2 100644 --- a/extra/literals/literals-tests.factor +++ b/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 ; -: seven-eleven 7 11 ; +: five ( -- a ) 5 ; +: seven-eleven ( -- b c ) 7 11 ; [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index d3cfcaae23..6bff666f07 100644 --- a/extra/literals/literals.factor +++ b/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