From 48138d548a8b049be5a31729910476bc5bacadf9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Mon, 8 Jun 2015 13:53:59 +0200
Subject: [PATCH] locals.parser: small refactorings and unit tests
---
basis/locals/parser/parser-tests.factor | 63 +++++++++++++++++++++++++
basis/locals/parser/parser.factor | 19 ++++----
2 files changed, 72 insertions(+), 10 deletions(-)
create mode 100644 basis/locals/parser/parser-tests.factor
diff --git a/basis/locals/parser/parser-tests.factor b/basis/locals/parser/parser-tests.factor
new file mode 100644
index 0000000000..fef17b7cd5
--- /dev/null
+++ b/basis/locals/parser/parser-tests.factor
@@ -0,0 +1,63 @@
+USING: accessors assocs compiler.units kernel lexer locals.backend
+locals.parser parser prettyprint sequences tools.test ;
+IN: locals.parser.tests
+
+SYMBOL: dobiedoo
+
+! (::)
+{
+ dobiedoo
+ [ 1 load-locals 1 drop-locals ]
+ ( x -- y )
+} [
+ [
+ { "dobiedoo ( x -- y ) ;" } <lexer> [ (::) ] with-lexer
+ ] with-compilation-unit
+] unit-test
+
+! ((parse-lambda))
+{
+ "V{ 99 :> kkk kkk }"
+} [
+ [ { "99 :> kkk kkk ;" } <lexer> [
+ H{ } clone [ \ ; parse-until ] ((parse-lambda)) ] with-lexer
+ ] with-compilation-unit unparse
+] unit-test
+
+! check-local-name
+{ "hello" } [
+ "hello" check-local-name
+] unit-test
+
+! make-locals
+{ { "a" "b" "c" } } [
+ [ { "a" "b" "c" } make-locals ] with-compilation-unit
+ nip values [ name>> ] map
+] unit-test
+
+! parse-def
+{ "um" { "um" } } [
+ [ "um" H{ } clone [ parse-def ] keep ] with-compilation-unit
+ [ local>> name>> ] [ keys ] bi*
+] unit-test
+
+! parse-local-defs
+{ { "tok1" "tok2" } } [
+ [
+ { "tok1 tok2 |" } <lexer> [ parse-local-defs ] with-lexer
+ ] with-compilation-unit
+ nip values [ name>> ] map
+] unit-test
+
+! parse-multi-def
+{
+ { "v1" "tok1" "tok2" }
+ { "tok1" "tok2" }
+} [
+ [
+ { "tok1 tok2 )" } <lexer> [
+ H{ { "v1" t } } clone dup parse-multi-def
+ ] with-lexer
+ ] with-compilation-unit
+ [ keys ] [ locals>> [ name>> ] map ] bi*
+] unit-test
diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor
index e59b6a8fc5..ae096404b6 100644
--- a/basis/locals/parser/parser.factor
+++ b/basis/locals/parser/parser.factor
@@ -27,13 +27,13 @@ ERROR: invalid-local-name name ;
[ [ make-local ] map ] H{ } make ;
: parse-local-defs ( -- words assoc )
- [ "|" [ make-local ] map-tokens ] H{ } make ;
+ "|" parse-tokens make-locals ;
SINGLETON: lambda-parser
SYMBOL: locals
-: ((parse-lambda)) ( assoc quot -- quot' )
+: ((parse-lambda)) ( assoc reader-quot -- quot )
'[
in-lambda? on
lambda-parser quotation-parser set
@@ -51,14 +51,13 @@ SYMBOL: locals
?rewrite-closures ;
: parse-multi-def ( locals -- multi-def )
- [ [ ")" [ make-local ] map-tokens ] H{ } make ] dip
- swap assoc-union! drop <multi-def> ;
+ ")" parse-tokens make-locals swapd assoc-union! drop <multi-def> ;
+
+: parse-single-def ( name locals -- def )
+ swap [ make-local ] H{ } make swapd assoc-union! drop <def> ;
: parse-def ( name/paren locals -- def )
- over "(" =
- [ nip parse-multi-def ]
- [ [ [ make-local ] H{ } make ] dip swap assoc-union! drop <def> ]
- if ;
+ over "(" = [ nip parse-multi-def ] [ parse-single-def ] if ;
M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ;
@@ -77,13 +76,13 @@ M: lambda-parser parse-quotation ( -- quotation )
dup
in>> [ dup pair? [ first ] when ] map make-locals ;
-: (parse-locals-definition) ( effect vars assoc reader -- word quot effect )
+: (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
((parse-lambda)) <lambda>
[ nip "lambda" set-word-prop ]
[ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
[ drop nip ] 3tri ; inline
-: parse-locals-definition ( word reader -- word quot effect )
+: parse-locals-definition ( word reader-quot -- word quot effect )
[ parse-locals ] dip (parse-locals-definition) ; inline
: parse-locals-method-definition ( word reader -- word quot effect )