Skip to content

Commit

Permalink
Make more test in S03-smartmatch pass
Browse files Browse the repository at this point in the history 
Get the specced cases of topic used on RHS work. This commit also makes
the following to be illegal:

    "aaa" ~~ $_ given /\d+/;

Because now $_ is `"aaa"`, not `/\d+/`. Looks like it's working with the
legacy compiler is just accidental. Perhaps due to optimizations kicking
in.
  • Loading branch information
@vrurg
vrurg committed Nov 23, 2022
1 parent 7fb3c8c commit 5ea53b3
Show file tree
Hide file tree
Showing 2 changed files with 66 additions and 76 deletions.
35 changes: 18 additions & 17 deletions src/Raku/ast/expressions.rakumod
View file
Expand Up @@ -254,25 +254,30 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
!! QAST::Op.new( :op<unless>, $rhs, QAST::WVal.new( :value(False) )));
}

my $rhs-local := QAST::Node.unique('!sm-rhs');
my $lhs-local := QAST::Node.unique('!sm-lhs');
my $lhs := QAST::Op.new(
:op<bind>,
QAST::Var.new(:name($lhs-local), :scope<local>, :decl<var>),
$left.IMPL-TO-QAST($context));
my $accepts-call := QAST::Op.new(
:op('callmethod'), :name('ACCEPTS'),
QAST::Var.new(:name($rhs-local), :scope<local>),
QAST::Var.new(:name($lhs-local), :scope<local>));
my $accepts-call;
if $negate {
$accepts-call := QAST::Op.new( :op<callmethod>, :name<not>, $accepts-call );
$accepts-call := QAST::Op.new(
:op<callmethod>, :name<not>,
QAST::Op.new(
:op('callmethod'), :name('ACCEPTS'),
$right.IMPL-TO-QAST($context),
QAST::Var.new(:name<$_>, :scope<lexical>)));
}
else {
my $rhs-local := QAST::Node.unique('!sm-rhs');
$accepts-call := QAST::Op.new(
:op('callmethod'), :name('ACCEPTS'),
QAST::Var.new( :name($rhs-local), :scope<local> ),
QAST::Var.new(:name<$_>, :scope<lexical>));
$accepts-call := QAST::Op.new(
:op<if>,
QAST::Op.new(
:op<istype>,
QAST::Var.new( :name($rhs-local), :scope<local> ),
QAST::Op.new(
:op<bind>,
QAST::Var.new( :name($rhs-local), :scope<local>, :decl<var> ),
$right.IMPL-TO-QAST($context),
),
QAST::WVal.new( :value(Regex) )),
$accepts-call,
QAST::Op.new(
Expand All @@ -281,11 +286,7 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
$accepts-call ));
}
QAST::Stmts.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new(:name($rhs-local), :scope<local>, :decl<var>),
$right.IMPL-TO-QAST($context) ),
self.IMPL-TEMPORARIZE-TOPIC( $lhs, $accepts-call ))
self.IMPL-TEMPORARIZE-TOPIC( $left.IMPL-TO-QAST($context), $accepts-call ))
}

method IMPL-LIST-INFIX-QAST(RakuAST::IMPL::QASTContext $context, Mu $operands) {
Expand Down
107 changes: 48 additions & 59 deletions t/12-rakuast/regex.t
View file
Expand Up @@ -11,6 +11,22 @@ sub ast(RakuAST::Regex:D $body --> Nil) {
diag $ast.DEPARSE.chomp;
}

sub match-ok($haystack, $expected) is test-assertion {
subtest "matches" => {
plan 2;
is $haystack ~~ EVAL($ast), $expected, 'EVAL over RakuAST';
is $haystack ~~ EVAL($ast.DEPARSE), $expected, 'EVAL over deparsed AST';
}
}

sub match-nok($haystack) is test-assertion {
subtest "doesn't match" => {
plan 2;
nok $haystack ~~ EVAL($ast), 'EVAL over RakuAST';
nok $haystack ~~ EVAL($ast.DEPARSE), 'EVAL over deparsed AST';
}
}

subtest 'Simple literal regex' => {
# / foo /
ast RakuAST::Regex::Literal.new('foo');
Expand All @@ -28,8 +44,7 @@ subtest 'Sequential alternation takes first match even if second is longer' => {
RakuAST::Regex::Literal.new('bc')
);

is "abcd" ~~ $_, 'b'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "b";
}

subtest 'Sequential alternation takes second match if first fails' => {
Expand All @@ -39,8 +54,7 @@ subtest 'Sequential alternation takes second match if first fails' => {
RakuAST::Regex::Literal.new('bc')
);

is "abcd" ~~ $_, 'bc'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "bc";
}

subtest 'Sequential alternation fails if no alternative matches' => {
Expand All @@ -50,8 +64,7 @@ subtest 'Sequential alternation fails if no alternative matches' => {
RakuAST::Regex::Literal.new('y')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'LTM alternation takes longest match even if it is not first' => {
Expand All @@ -61,8 +74,7 @@ subtest 'LTM alternation takes longest match even if it is not first' => {
RakuAST::Regex::Literal.new('bc')
);

is "abcd" ~~ $_, 'bc'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "bc";
}

subtest 'Alternation takes second match if first fails' => {
Expand All @@ -72,8 +84,7 @@ subtest 'Alternation takes second match if first fails' => {
RakuAST::Regex::Literal.new('bc')
);

is "abcd" ~~ $_, 'bc'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "bc";
}

subtest 'Alternation fails if no alternative matches' => {
Expand All @@ -83,8 +94,7 @@ subtest 'Alternation fails if no alternative matches' => {
RakuAST::Regex::Literal.new('y')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'Conjunction matches when both items match' => {
Expand All @@ -94,8 +104,7 @@ subtest 'Conjunction matches when both items match' => {
RakuAST::Regex::Literal.new('c')
);

is "abcd" ~~ $_, 'c'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "c";
}

subtest 'Conjunction fails when one item does not match' => {
Expand All @@ -105,8 +114,7 @@ subtest 'Conjunction fails when one item does not match' => {
RakuAST::Regex::Literal.new('x')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'Conjunction fails when items match different lengths' => {
Expand All @@ -116,8 +124,7 @@ subtest 'Conjunction fails when items match different lengths' => {
RakuAST::Regex::Literal.new('cd')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'Sequence needs one thing to match after the other (pass case)' => {
Expand All @@ -127,8 +134,7 @@ subtest 'Sequence needs one thing to match after the other (pass case)' => {
RakuAST::Regex::Literal.new('d')
);

is "abcd" ~~ $_, 'cd'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "cd";
}

subtest 'Sequence needs one thing to match after the other (failure case)' => {
Expand All @@ -138,8 +144,7 @@ subtest 'Sequence needs one thing to match after the other (failure case)' => {
RakuAST::Regex::Literal.new('a')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'Beginning of string anchor works (pass case)' => {
Expand All @@ -149,8 +154,7 @@ subtest 'Beginning of string anchor works (pass case)' => {
RakuAST::Regex::CharClass::Any.new
);

is "abcd" ~~ $_, 'a'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcd", "a";
}

subtest 'Beginning of string anchor works (failure case)' => {
Expand All @@ -160,8 +164,7 @@ subtest 'Beginning of string anchor works (failure case)' => {
RakuAST::Regex::Literal.new('b')
);

nok "abcd" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcd";
}

subtest 'End of string anchor works (pass case)' => {
Expand All @@ -171,8 +174,7 @@ subtest 'End of string anchor works (pass case)' => {
RakuAST::Regex::Anchor::EndOfString.new
);

is "abcde" ~~ $_, 'e'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "abcde", "e";
}

subtest 'End of string anchor works (failure case)' => {
Expand All @@ -182,8 +184,7 @@ subtest 'End of string anchor works (failure case)' => {
RakuAST::Regex::Anchor::EndOfString.new
);

nok "abcde" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "abcde";
}

subtest 'Right word boundary works' => {
Expand Down Expand Up @@ -221,8 +222,7 @@ subtest 'Quantified built-in character class matches' => {
quantifier => RakuAST::Regex::Quantifier::OneOrMore.new
);

is "99cents" ~~ $_, '99'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "99cents", "99";
}

subtest 'Quantified negated built-in character class matches' => {
Expand All @@ -232,8 +232,7 @@ subtest 'Quantified negated built-in character class matches' => {
quantifier => RakuAST::Regex::Quantifier::OneOrMore.new
);

is "99cents" ~~ $_, 'cents'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "99cents", "cents";
}

subtest 'Quantified built-in character class matches (frugal mode)' => {
Expand All @@ -245,8 +244,7 @@ subtest 'Quantified built-in character class matches (frugal mode)' => {
)
);

is "99cents" ~~ $_, '9'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "99cents", "9";
}

subtest 'Quantified negated built-in character class matches (frugal mode)' => {
Expand All @@ -258,8 +256,7 @@ subtest 'Quantified negated built-in character class matches (frugal mode)' => {
)
);

is "99cents" ~~ $_, 'c'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "99cents", 'c';
}

subtest 'Greedy quantifier will backtrack' => {
Expand All @@ -273,8 +270,7 @@ subtest 'Greedy quantifier will backtrack' => {
RakuAST::Regex::Literal.new('9')
);

is "99cents" ~~ $_, '99'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "99cents", '99';
}

subtest 'Ratchet quantifier will not backtrack' => {
Expand All @@ -290,45 +286,41 @@ subtest 'Ratchet quantifier will not backtrack' => {
RakuAST::Regex::Literal.new('9')
);

nok "99cents" ~~ $_,
for EVAL($ast), EVAL($ast.DEPARSE);
match-nok "99cents";
}

subtest 'Separator works (non-trailing case)' => {
# / \d+ % ',' /
# / \d+ % ',' /
ast RakuAST::Regex::QuantifiedAtom.new(
atom => RakuAST::Regex::CharClass::Digit.new,
quantifier => RakuAST::Regex::Quantifier::OneOrMore.new,
separator => RakuAST::Regex::Literal.new(',')
);

is "values: 1,2,3,4,stuff" ~~ $_, '1,2,3,4'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "values: 1,2,3,4,stuff", '1,2,3,4';
}

subtest 'Separator works (trailing case)' => {
# / \d+ %% ',' /
# / \d+ %% ',' /
ast RakuAST::Regex::QuantifiedAtom.new(
atom => RakuAST::Regex::CharClass::Digit.new,
quantifier => RakuAST::Regex::Quantifier::OneOrMore.new,
separator => RakuAST::Regex::Literal.new(','),
trailing-separator => True
);

is "values: 1,2,3,4,stuff" ~~ $_, '1,2,3,4,'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "values: 1,2,3,4,stuff", '1,2,3,4,';
}

subtest 'Separator must be between every quantified item' => {
# / \d+ % ',' /
# / \d+ % ',' /
ast RakuAST::Regex::QuantifiedAtom.new(
atom => RakuAST::Regex::CharClass::Digit.new,
quantifier => RakuAST::Regex::Quantifier::OneOrMore.new,
separator => RakuAST::Regex::Literal.new(',')
);

is "values: 1,2,33,4,stuff" ~~ $_, '1,2,3'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "values: 1,2,33,4,stuff", '1,2,3';
}

subtest 'Regex groups compile correctly' => {
Expand Down Expand Up @@ -552,8 +544,7 @@ subtest 'Match from and match to markers works' => {
RakuAST::Regex::Literal.new('c')
);

is "a1b2c" ~~ $_, '2'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "a1b2c", '2';
}

subtest 'Match involving a quoted string literal works' => {
Expand All @@ -564,8 +555,7 @@ subtest 'Match involving a quoted string literal works' => {
)
);

is "believe" ~~ $_, 'lie'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "believe", 'lie';
}

subtest 'Match involving a quoted string with interpolation works' => {
Expand All @@ -581,8 +571,8 @@ subtest 'Match involving a quoted string with interpolation works' => {
)
);

is "believe" ~~ $_, 'eve'
for EVAL($ast), EVAL($ast.DEPARSE);
is "believe" ~~ EVAL($ast), 'eve', 'EVAL over RakuAST';
is "believe" ~~ EVAL($ast.DEPARSE), 'eve', 'EVAL over deparsed AST';
}

subtest 'Match involving quote words works' => {
Expand All @@ -594,8 +584,7 @@ subtest 'Match involving quote words works' => {
)
);

is "slinky sprint" ~~ $_, 'linky'
for EVAL($ast), EVAL($ast.DEPARSE);
match-ok "slinky sprint", 'linky';
}

# vim: expandtab shiftwidth=4

0 comments on commit 5ea53b3

Please sign in to comment.