implement negated charrange on parrot and jvm

jvm part is still b0rked, though
Raku · Nov 11, 2013 · 8e4f995 · 8e4f995
1 parent 8f0d8f4
commit 8e4f995
Show file tree

Hide file tree

Showing 3 changed files with 36 additions and 15 deletions.
diff --git a/src/QRegex/P6Regex/Actions.nqp b/src/QRegex/P6Regex/Actions.nqp
@@ -641,12 +641,13 @@ class QRegex::P6Regex::Actions is HLL::Actions {
                     $str := $str ~ (%*RX<i> ?? nqp::lc($c) ~ nqp::uc($c) !! $c);
                 }
             }
-            if nqp::elems(@alts) == 0 && $use-range == 1 && nqp::chars($str) && $<sign> ne '-' {
+            if nqp::elems(@alts) == 0 && $use-range == 1 && nqp::chars($str) {
                 $qast := QAST::Regex.new(
                                   $str,
                                   QAST::IVal.new( :value($lower) ),
-                                  QAST::IVal.new( :value($upper) )
-                                  , :rxtype<charrange>, :node($/) );
+                                  QAST::IVal.new( :value($upper) ),
+                                  :negate( $<sign> eq '-' ),
+                                  :rxtype<charrange>, :node($/) );
             } else {
                 @alts.push(QAST::Regex.new( $str, :rxtype<enumcharlist>, :node($/), :negate( $<sign> eq '-' ) ))
                     if nqp::chars($str);

diff --git a/src/vm/jvm/QAST/Compiler.nqp b/src/vm/jvm/QAST/Compiler.nqp
@@ -4895,16 +4895,30 @@ class QAST::CompilerJAST {
             $TYPE_STR, 'codePointAt', 'Integer', 'Integer' ));
         $il.append($I2L);
         $il.append($DUP);
+
         $il.append(JAST::PushIVal.new( :value($node[1].value) ));
         $il.append($LCMP);
-        $il.append(JAST::Instruction.new( :op('ifge'), $succeed ));
-        $il.append($POP);
-        $il.append(JAST::Instruction.new( :op('goto'), %*REG<fail>));
 
-        $il.append($succeed);
-        $il.append(JAST::PushIVal.new( :value($node[2].value) ));
-        $il.append($LCMP);
-        $il.append(JAST::Instruction.new( :op('ifgt'), %*REG<fail> ));
+        if $node.negate {
+            my $succeed_and_pop := JAST::Label.new(:name(self.unique('charrange_succeed_pop_')));
+            $il.append(JAST::Instruction.new( :op('iflt'), $succeed_and_pop ));
+            $il.append(JAST::PushIVal.new( :value($node[2].value) ));
+            $il.append($LCMP);
+            $il.append(JAST::Instruction.new( :op('ifge'), $succeed ));
+            $il.append(JAST::Instruction.new( :op('goto'), %*REG<fail> ));
+            $il.append($succeed_and_pop);
+            $il.append($POP);
+            $il.append($succeed);
+        } else {
+            $il.append(JAST::Instruction.new( :op('ifge'), $succeed ));
+            $il.append($POP);
+            $il.append(JAST::Instruction.new( :op('goto'), %*REG<fail>));
+
+            $il.append($succeed);
+            $il.append(JAST::PushIVal.new( :value($node[2].value) ));
+            $il.append($LCMP);
+            $il.append(JAST::Instruction.new( :op('ifgt'), %*REG<fail> ));
+        }
 
         unless $node.subtype eq 'zerowidth' {
             $il.append(JAST::Instruction.new( :op('lload'), %*REG<pos> ));

diff --git a/src/vm/parrot/QAST/Compiler.nqp b/src/vm/parrot/QAST/Compiler.nqp
@@ -1436,13 +1436,19 @@ class QAST::Compiler is HLL::Compiler {
 
     method charrange($node) {
         my $ops := self.post_new('Ops', :result(%*REG<cur>));
+        $ops.push_pirop('ge', %*REG<pos>, %*REG<eos>, %*REG<fail>);
         if $node.negate {
-            die("negated charrange NYI");
+            my $succeed  := self.post_new('Label', :name(self.unique('succeed_')));
+            $ops.push_pirop('ord', '$I11', %*REG<tgt>, %*REG<pos>);
+            $ops.push_pirop('gt', '$I11', $node[2].value, $succeed);
+            $ops.push_pirop('lt', '$I11', $node[1].value, $succeed);
+            $ops.push_pirop('goto', %*REG<fail>);
+            $ops.push($succeed);
+        } else {
+            $ops.push_pirop('ord', '$I11', %*REG<tgt>, %*REG<pos>);
+            $ops.push_pirop('lt', '$I11', $node[1].value, %*REG<fail>);
+            $ops.push_pirop('gt', '$I11', $node[2].value, %*REG<fail>);
         }
-        $ops.push_pirop('ge', %*REG<pos>, %*REG<eos>, %*REG<fail>);
-        $ops.push_pirop('ord', '$I11', %*REG<tgt>, %*REG<pos>);
-        $ops.push_pirop('lt', '$I11', $node[1].value, %*REG<fail>);
-        $ops.push_pirop('gt', '$I11', $node[2].value, %*REG<fail>);
         $ops.push_pirop('inc', %*REG<pos>) unless $node.subtype eq 'zerowidth';
         $ops;
     }