Changeset 21632 for perl5

Timestamp:

07/30/08 14:26:09 (5 months ago)

Author:

fglock

Message:

[v6.pm] more operators

Location:

perl5/Pugs-Compiler-Perl6/lib/Pugs

Files:

• Emitter/Perl6/Perl5.pm (modified) (2 diffs)
• Grammar/Infix.pm (modified) (1 diff)

perl5/Pugs-Compiler-Perl6/lib/Pugs/Emitter/Perl6/Perl5.pm

@@ -661 +661 @@
     if ( exists $n->{op1} && $n->{op1} eq 'call' ) {
         #warn "call: ",Dumper $n;
+
+        if ( exists $n->{sub}{code} && exists $n->{param} && exists $n->{param}{op1} && $n->{param}{op1} eq 'call' ) {
+            # &infix<=>.(...)
+            my $fixity = $n->{sub}{code};
+            my $operator = $n->{param}{sub}{single_quoted};
+            if ( $fixity && $operator && exists $n->{param}{param}{exp1} ) {
+                $fixity =~ s/^&//;
+                print Dumper( $n->{param}{param} );
+                return _emit(
+                    {
+                      'exp1' => $n->{param}{param}{exp1}{list}[0],
+                      'exp2' => $n->{param}{param}{exp1}{list}[1],
+                      'fixity' => $fixity,
+                      'op1' => $operator,
+                    }                
+                );
+            }
+        }
+        if ( exists $n->{sub}{bareword} && exists $n->{param} && exists $n->{param}{op1} && $n->{param}{op1} eq 'call' ) {
+            # infix<=>(...)
+            my $fixity = $n->{sub}{bareword};
+            my $operator = $n->{param}{sub}{single_quoted};
+            if ( $fixity && $operator && exists $n->{param}{param}{exp1} ) {
+                $fixity =~ s/^&//;
+                print Dumper( $n->{param}{param} );
+                return _emit(
+                    {
+                      'exp1' => $n->{param}{param}{exp1}{list}[0],
+                      'exp2' => $n->{param}{param}{exp1}{list}[1],
+                      'fixity' => $fixity,
+                      'op1' => $operator,
+                    }                
+                );
+            }
+        }
 
         if ($n->{sub}{scalar} || $n->{sub}{exp1} || $n->{sub}{statement}) {
@@ -1430 +1465 @@
         return _emit( $n->{exp1} ) . ' .= ' . _emit_str( $n->{exp2} );
     }
+    if ( $n->{op1} eq '+&=' ) {
+        return _emit( $n->{exp1} ) . ' &= ' . _emit_str( $n->{exp2} );
+    }
+    if ( $n->{op1} eq '+|=' ) {
+        return _emit( $n->{exp1} ) . ' |= ' . _emit_str( $n->{exp2} );
+    }
+    if ( $n->{op1} eq '+^=' ) {
+        return _emit( $n->{exp1} ) . ' ^= ' . _emit_str( $n->{exp2} );
+    }
+
+    if ( $n->{op1} eq '~&=' ) {
+        return
+             'do { my $_V6_TMP1 = "" . ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = $_V6_TMP1 & ( "" . ' . _emit( $n->{exp2} ) 
+            . ' ); } ';
+    }
+    if ( $n->{op1} eq '~|=' ) {
+        return
+             'do { my $_V6_TMP1 = "" . ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = $_V6_TMP1 | ( "" . ' . _emit( $n->{exp2} ) 
+            . ' ); } ';
+    }
+    if ( $n->{op1} eq '~^=' ) {
+        return
+             'do { my $_V6_TMP1 = "" . ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = $_V6_TMP1 ^ ( "" . ' . _emit( $n->{exp2} ) 
+            . ' ); } ';
+    }
+
+    if ( $n->{op1} eq '?&=' ) {
+        return
+             'do { my $_V6_TMP1 = ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = ( $_V6_TMP1 && ' . _emit( $n->{exp2} ) 
+            . ' ) ? 1 : 0; } ';
+    }
+    if ( $n->{op1} eq '?|=' ) {
+        return
+             'do { my $_V6_TMP1 = ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = ( $_V6_TMP1 || ' . _emit( $n->{exp2} ) 
+            . ' ) ? 1 : 0; } ';
+    }
+    if ( $n->{op1} eq '?^=' ) {
+        return
+             'do { my $_V6_TMP1 = ' . _emit( $n->{exp1} ) . '; ' 
+                . _emit( $n->{exp1} ) . ' = ( $_V6_TMP1 xor ' . _emit( $n->{exp2} ) 
+            . ' ) ? 1 : 0; } ';
+    }
+
+    if ( $n->{op1} eq '+<=' ) {
+        return _emit( $n->{exp1} ) . ' <= ' . _emit_str( $n->{exp2} );
+    }
+    if ( $n->{op1} eq '+>=' ) {
+        return _emit( $n->{exp1} ) . ' >= ' . _emit_str( $n->{exp2} );
+    }
+
+    if ( $n->{op1} eq '~<=' ) {
+        return _emit( $n->{exp1} ) . ' le ' . _emit_str( $n->{exp2} );
+    }
+    if ( $n->{op1} eq '~>=' ) {
+        return _emit( $n->{exp1} ) . ' ge ' . _emit_str( $n->{exp2} );
+    }
+
+    if ( $n->{op1} eq '^^=' ) {
+        # XXX
+        return _emit( $n->{exp1} ) . ' ^= ' . _emit_str( $n->{exp2} );
+    }
     if ( $n->{op1} eq '//'  ||
          $n->{op1} eq 'orelse' ) {

perl5/Pugs-Compiler-Perl6/lib/Pugs/Grammar/Infix.pm

@@ -111 +111 @@
     );
     __PACKAGE__->add_same_precedence_ops({ assoc => 'right'}, qw(
-        = := ::= => += -= 
+        = := ::= => += -= +>= +<= ~>= ~<= 
         *= **= 
         /= //=