<PRIVATE
-: push-functor-words ( -- )
- functor-words use-words ;
-
-: pop-functor-words ( -- )
- functor-words unuse-words ;
-
: (parse-bindings) ( end -- words )
[ dup parse-binding dup ]
[ first2 [ make-local ] dip 2array ]
[
building get use-words
(parse-bindings)
- building get unuse-words
] with-bindings ;
: parse-functor-body ( -- form )
- push-functor-words
+ functor-words use-words
"WHERE" parse-bindings
[ [ swap <def> suffix ] { } assoc>map concat ]
- [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
- [ ] append-as
- pop-functor-words ;
+ [ [ \ ;FUNCTOR parse-until >quotation ] with-lambda-scope ] bi*
+ [ ] append-as ;
: (FUNCTOR:) ( -- word def effect )
scan-new-word [ parse-functor-body ] parse-locals-definition ;
IN: locals.parser.tests
<<
-! ((parse-lambda))
-{
- "V{ 99 :> kkk kkk }"
-} [
- [
- "locals" use-vocab
- { "99 :> kkk kkk ;" } <lexer> [
- H{ } clone [ \ ; parse-until ] ((parse-lambda))
- ] with-lexer
- ] with-compilation-unit unparse
-] unit-test
-
! (::)
{
"dobiedoo"
] with-compilation-unit
[ locals>> [ name>> ] map ] [ keys ] bi*
] unit-test
+
+<<
+! with-lambda-scope
+{ t } [
+ qualified-vocabs length
+ H{ } clone [
+ "hey there!" qualified-vocabs push [ ]
+ ] with-lambda-scope drop
+ qualified-vocabs length =
+] unit-test
+
+{
+ "V{ 99 :> kkk kkk }"
+} [
+ [
+ "locals" use-vocab
+ { "99 :> kkk kkk ;" } <lexer> [
+ H{ } clone [ \ ; parse-until ] with-lambda-scope
+ ] with-lexer
+ ] with-compilation-unit unparse
+] unit-test
+>>
SINGLETON: lambda-parser
-: ((parse-lambda)) ( assoc reader-quot: ( -- quot ) -- quot )
+: with-lambda-scope ( assoc reader-quot: ( -- quot ) -- quot )
'[
in-lambda? on
lambda-parser quotation-parser set
- [ use-words @ ] [ unuse-words ] bi
+ manifest [ clone [ clone ] change-qualified-vocabs ] change
+ use-words @
] with-scope ; inline
: (parse-lambda) ( assoc -- quot )
- [ \ ] parse-until >quotation ] ((parse-lambda)) ;
+ [ \ ] parse-until >quotation ] with-lambda-scope ;
: parse-lambda ( -- lambda )
parse-local-defs
in>> [ dup pair? [ first ] when ] map make-locals ;
: (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
- ((parse-lambda)) <lambda>
+ with-lambda-scope <lambda>
[ nip "lambda" set-word-prop ]
[ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
[ drop nip ] 3tri ; inline
{ $description "Adds an assoc mapping word names to words to the current manifest." }
{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ;
-HELP: unuse-words
-{ $values { "assoc" assoc } }
-{ $description "Removes an assoc mapping word names to words from the current manifest." }
-{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ;
-
HELP: ambiguous-use-error
{ $error-description "Thrown when a word name referenced in source file is available in more than one vocabulary in the manifest. Such cases must be explicitly disambiguated using " { $link POSTPONE: FROM: } ", " { $link POSTPONE: EXCLUDE: } ", " { $link POSTPONE: QUALIFIED: } ", or " { $link POSTPONE: QUALIFIED-WITH: } "." } ;
: use-words ( assoc -- )
<extra-words> qualified-vocabs push ;
-: unuse-words ( assoc -- )
- <extra-words> qualified-vocabs remove! drop ;
-
TUPLE: ambiguous-use-error words ;
: <ambiguous-use-error> ( words -- error restarts )