Implement handling of state variables in list assignment

[p5sagit/p5-mst-13.2.git] / ext / B / B / Stackobj.pm

diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm
index 35e04e2..b17dfb8 100644 (file)
--- a/ext/B/B/Stackobj.pm
+++ b/ext/B/B/Stackobj.pm
@@ -6,17 +6,20 @@
 #      License or the Artistic License, as specified in the README file.
 #
 package B::Stackobj;  
+
+our $VERSION = '1.00';
+
 use Exporter ();
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
                VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
 %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
                flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
-                            REGISTER TEMPORARY)]);
+                            VALID_UNSIGNED REGISTER TEMPORARY)]);
 
 use Carp qw(confess);
 use strict;
-use B qw(class SVf_IOK SVf_NOK);
+use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
 
 # Types
 sub T_UNKNOWN () { 0 }
@@ -26,10 +29,14 @@ sub T_SPECIAL () { 3 }
 
 # Flags
 sub VALID_INT ()       { 0x01 }
-sub VALID_DOUBLE ()    { 0x02 }
-sub VALID_SV ()                { 0x04 }
-sub REGISTER ()                { 0x08 } # no implicit write-back when calling subs
-sub TEMPORARY ()       { 0x10 } # no implicit write-back needed at all
+sub VALID_UNSIGNED ()  { 0x02 }
+sub VALID_DOUBLE ()    { 0x04 }
+sub VALID_SV ()                { 0x08 }
+sub REGISTER ()                { 0x10 } # no implicit write-back when calling subs
+sub TEMPORARY ()       { 0x20 } # no implicit write-back needed at all
+sub SAVE_INT ()        { 0x40 } #if int part needs to be saved at all
+sub SAVE_DOUBLE ()     { 0x80 } #if double part needs to be saved at all
+
 
 #
 # Callback for runtime code generation
@@ -44,7 +51,7 @@ sub runtime { &$runtime_callback(@_) }
 
 sub write_back { confess "stack object does not implement write_back" }
 
-sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
+sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
 
 sub as_sv {
     my $obj = shift;
@@ -59,7 +66,7 @@ sub as_int {
     my $obj = shift;
     if (!($obj->{flags} & VALID_INT)) {
        $obj->load_int;
-       $obj->{flags} |= VALID_INT;
+       $obj->{flags} |= VALID_INT|SAVE_INT;
     }
     return $obj->{iv};
 }
@@ -68,7 +75,7 @@ sub as_double {
     my $obj = shift;
     if (!($obj->{flags} & VALID_DOUBLE)) {
        $obj->load_double;
-       $obj->{flags} |= VALID_DOUBLE;
+       $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
     }
     return $obj->{nv};
 }
@@ -134,17 +141,18 @@ sub minipeek {
 # set_numeric and set_sv are only invoked on legal lvalues.
 #
 sub set_int {
-    my ($obj, $expr) = @_;
+    my ($obj, $expr,$unsigned) = @_;
     runtime("$obj->{iv} = $expr;");
     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
-    $obj->{flags} |= VALID_INT;
+    $obj->{flags} |= VALID_INT|SAVE_INT;
+    $obj->{flags} |= VALID_UNSIGNED if $unsigned; 
 }
 
 sub set_double {
     my ($obj, $expr) = @_;
     runtime("$obj->{nv} = $expr;");
     $obj->{flags} &= ~(VALID_SV | VALID_INT);
-    $obj->{flags} |= VALID_DOUBLE;
+    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
 }
 
 sub set_numeric {
@@ -170,6 +178,8 @@ sub set_sv {
 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
 sub B::Stackobj::Padsv::new {
     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+    $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
+    $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
     bless {
        type => $type,
        flags => VALID_SV | $extra_flags,
@@ -186,14 +196,23 @@ sub B::Stackobj::Padsv::load_int {
     } else {
        runtime("$obj->{iv} = SvIV($obj->{sv});");
     }
-    $obj->{flags} |= VALID_INT;
+    $obj->{flags} |= VALID_INT|SAVE_INT;
 }
 
 sub B::Stackobj::Padsv::load_double {
     my $obj = shift;
     $obj->write_back;
     runtime("$obj->{nv} = SvNV($obj->{sv});");
-    $obj->{flags} |= VALID_DOUBLE;
+    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+sub B::Stackobj::Padsv::save_int {
+    my $obj = shift;
+    return $obj->{flags} & SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::save_double {
+    my $obj = shift;
+    return $obj->{flags} & SAVE_DOUBLE;
 }
 
 sub B::Stackobj::Padsv::write_back {
@@ -201,7 +220,11 @@ sub B::Stackobj::Padsv::write_back {
     my $flags = $obj->{flags};
     return if $flags & VALID_SV;
     if ($flags & VALID_INT) {
-       runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+        if ($flags & VALID_UNSIGNED ){
+            runtime("sv_setuv($obj->{sv}, $obj->{iv});");
+        }else{
+            runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+        }     
     } elsif ($flags & VALID_DOUBLE) {
        runtime("sv_setnv($obj->{sv}, $obj->{nv});");
     } else {
@@ -228,7 +251,12 @@ sub B::Stackobj::Const::new {
        if ($svflags & SVf_IOK) {
                $obj->{flags} = VALID_INT|VALID_DOUBLE;
                $obj->{type} = T_INT;
-               $obj->{nv} = $obj->{iv} = $sv->IV;
+                if ($svflags & SVf_IVisUV){
+                    $obj->{flags} |= VALID_UNSIGNED;
+                    $obj->{nv} = $obj->{iv} = $sv->UVX;
+                }else{
+                    $obj->{nv} = $obj->{iv} = $sv->IV;
+                }
        } elsif ($svflags & SVf_NOK) {
                $obj->{flags} = VALID_INT|VALID_DOUBLE;
                $obj->{type} = T_DOUBLE;
@@ -250,13 +278,21 @@ sub B::Stackobj::Const::write_back {
 
 sub B::Stackobj::Const::load_int {
     my $obj = shift;
-    $obj->{iv} = int($obj->{sv}->PV);
+    if (ref($obj->{sv}) eq "B::RV"){
+       $obj->{iv} = int($obj->{sv}->RV->PV);
+    }else{
+       $obj->{iv} = int($obj->{sv}->PV);
+    }
     $obj->{flags} |= VALID_INT;
 }
 
 sub B::Stackobj::Const::load_double {
     my $obj = shift;
-    $obj->{nv} = $obj->{sv}->PV + 0.0;
+    if (ref($obj->{sv}) eq "B::RV"){
+        $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
+    }else{
+        $obj->{nv} = $obj->{sv}->PV + 0.0;
+    }
     $obj->{flags} |= VALID_DOUBLE;
 }