Make smartmatching sanity test happy

S03-smartmatch/00-sanity.t is now passing completely.
rakudo · Nov 23, 2022 · 7fb3c8c · 7fb3c8c
1 parent 1ba87d3
commit 7fb3c8c
Showing 1 changed file with 31 additions and 18 deletions.
diff --git a/src/Raku/ast/expressions.rakumod b/src/Raku/ast/expressions.rakumod
@@ -126,7 +126,7 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
 
     method PRODUCE-IMPLICIT-LOOKUPS() {
         self.IMPL-WRAP-LIST([
-            RakuAST::Type::Setting.new(RakuAST::Name.from-identifier('Regex')),
+            RakuAST::Type::Setting.new(RakuAST::Name.from-identifier('Match')),
         ])
     }
 
@@ -189,6 +189,8 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
 
     method IMPL-INFIX-COMPILE(RakuAST::IMPL::QASTContext $context,
             RakuAST::Expression $left, RakuAST::Expression $right) {
+        # Hash value is negation flag
+        my constant OP-SMARTMATCH := nqp::hash( '~~', 0, '!~~', 1 );
         my str $op := $!operator;
         if $op eq ':=' {
             if $left.can-be-bound-to {
@@ -198,6 +200,9 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
                 nqp::die('Cannot compile bind to ' ~ $left.HOW.name($left));
             }
         }
+        elsif nqp::existskey(OP-SMARTMATCH, $op) {
+            self.IMPL-SMARTMATCH-QAST($context, $left, $right, nqp::atkey(OP-SMARTMATCH, $op));
+        }
         else {
             self.IMPL-INFIX-QAST: $context, $left.IMPL-TO-QAST($context),
                 $right.IMPL-TO-QAST($context)
@@ -222,31 +227,39 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
             return QAST::Op.new( :op($qast-op), $left-qast, $right-qast );
         }
 
-        # Others are compiler special forms.
-        if $op eq '~~' {
-            return self.IMPL-SMARTMATCH-QAST($context, $left-qast, $right-qast, 0);
-        }
-        elsif $op eq '!~~' {
-            return self.IMPL-SMARTMATCH-QAST($context, $left-qast, $right-qast, 1);
-        }
-
         # Otherwise, it's called by finding the lexical sub to call, and
         # compiling it as chaining if required.
         my $name := self.resolution.lexical-name;
         my str $call-op := $!properties.chaining ?? 'chain' !! 'call';
         QAST::Op.new( :op($call-op), :$name, $left-qast, $right-qast )
     }
 
-    method IMPL-SMARTMATCH-QAST(RakuAST::IMPL::QASTContext $context, Mu $left-qast,
-            Mu $right-qast, int $negate) {
-        my @lookups := self.IMPL-UNWRAP-LIST(self.get-implicit-lookups());
-        my $regex-type := @lookups[0].resolution.compile-time-value;
-        my $rhs-local := QAST::Node.unique('sm-rhs');
-        my $lhs-local := QAST::Node.unique('sm-lhs');
+    method IMPL-SMARTMATCH-QAST( RakuAST::IMPL::QASTContext $context,
+                                 RakuAST::Expression $left,
+                                 RakuAST::Expression $right,
+                                 int $negate ) {
+        # Handle cases of s/// or m// separately. For a non-negating smartmatch this case could've been reduced to
+        # plain topic localization except that we must ensure a False returned when there is no match.
+        if nqp::istype($right, RakuAST::RegexThunk)
+            && (!nqp::can($right, 'match-immediately') || $right.match-immediately)
+        {
+            my @lookups := self.IMPL-UNWRAP-LIST(self.get-implicit-lookups());
+            my $match-type := @lookups[0].resolution.compile-time-value;
+            my $result-local := QAST::Node.unique('!sm-result');
+            my $rhs := $right.IMPL-EXPR-QAST($context);
+            return self.IMPL-TEMPORARIZE-TOPIC(
+                $left.IMPL-TO-QAST($context),
+                $negate
+                    ?? QAST::Op.new( :op<callmethod>, :name<not>, $rhs)
+                    !! 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-qast);
+                        $left.IMPL-TO-QAST($context));
         my $accepts-call := QAST::Op.new(
             :op('callmethod'), :name('ACCEPTS'),
             QAST::Var.new(:name($rhs-local), :scope<local>),
@@ -260,7 +273,7 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
                 QAST::Op.new(
                     :op<istype>,
                     QAST::Var.new( :name($rhs-local), :scope<local> ),
-                    QAST::WVal.new( :value($regex-type) )),
+                    QAST::WVal.new( :value(Regex) )),
                 $accepts-call,
                 QAST::Op.new(
                     :op<callmethod>,
@@ -271,7 +284,7 @@ class RakuAST::Infix is RakuAST::Infixish is RakuAST::Lookup {
             QAST::Op.new(
                 :op('bind'),
                 QAST::Var.new(:name($rhs-local), :scope<local>, :decl<var>),
-                $right-qast ),
+                $right.IMPL-TO-QAST($context) ),
             self.IMPL-TEMPORARIZE-TOPIC( $lhs, $accepts-call ))
     }