From: Vishal Bhatia Date: Sat, 12 Jun 1999 08:23:59 +0000 (-0700) Subject: applied patch after demunging headers with appropriate paths X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0ca044874fec3bf87bea6955f6263e103e6744a8;p=p5sagit%2Fp5-mst-13.2.git applied patch after demunging headers with appropriate paths Message-ID: Subject: [Patch 5.005_57] unsigned arithmetic (Compiler) p4raw-id: //depot/perl@3622 --- diff --git a/cc_runtime.h b/cc_runtime.h index bb0e07a..110b106 100644 --- a/cc_runtime.h +++ b/cc_runtime.h @@ -52,7 +52,7 @@ case 2: JMPENV_POP; JMPENV_JUMP(2); \ case 3: \ JMPENV_POP; \ - if (PL_restartop != nxt) \ + if (PL_restartop && PL_restartop != nxt) \ JMPENV_JUMP(3); \ } \ PL_op = nxt; \ diff --git a/ext/B/B.xs b/ext/B/B.xs index 7e32d01..1777b21 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -797,6 +797,11 @@ IV SvIVX(sv) B::IV sv +UV +SvUVX(sv) + B::IV sv + + MODULE = B PACKAGE = B::IV #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index 5a143bc..eb67bcf 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -896,9 +896,9 @@ BEGIN { # XXX The standard perl PP code has extra handling for # some special case arguments of these operators. # - sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) } - sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) } - sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) } + sub pp_add { numeric_binop($_[0], $plus_op) } + sub pp_subtract { numeric_binop($_[0], $minus_op) } + sub pp_multiply { numeric_binop($_[0], $multiply_op) } sub pp_divide { numeric_binop($_[0], $divide_op) } sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's @@ -944,7 +944,7 @@ sub pp_sassign { ($src, $dst) = ($dst, $src) if $backwards; my $type = $src->{type}; if ($type == T_INT) { - $dst->set_int($src->as_int); + $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); } elsif ($type == T_DOUBLE) { $dst->set_numeric($src->as_numeric); } else { @@ -957,7 +957,11 @@ sub pp_sassign { my $type = $src->{type}; runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); if ($type == T_INT) { - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + if ($src->{flags} & VALID_UNSIGNED){ + runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); + }else{ + runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + } } elsif ($type == T_DOUBLE) { runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); } else { diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm index 123b2fc..0db3e33 100644 --- a/ext/B/B/Stackobj.pm +++ b/ext/B/B/Stackobj.pm @@ -8,15 +8,15 @@ package B::Stackobj; 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,12 +26,13 @@ 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 SAVE_INT () { 0x20 } #if int part needs to be saved at all -sub SAVE_DOUBLE () { 0x40 } #if double part needs to be saved 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 # @@ -47,7 +48,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; @@ -137,10 +138,11 @@ 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|SAVE_INT; + $obj->{flags} |= VALID_UNSIGNED if $unsigned; } sub set_double { @@ -215,7 +217,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 { @@ -242,7 +248,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; diff --git a/ext/B/defsubs.h.PL b/ext/B/defsubs.h.PL index c04c1a3..2129c8c 100644 --- a/ext/B/defsubs.h.PL +++ b/ext/B/defsubs.h.PL @@ -8,7 +8,8 @@ open(OUT,">$out") || die "Cannot open $file:$!"; print "Extracting $out . . .\n"; foreach my $const (qw(AVf_REAL HEf_SVKEY - SVf_IOK SVf_NOK SVf_POK SVf_ROK SVp_IOK SVp_POK )) + SVf_IOK SVf_IVisUV SVf_NOK SVf_POK + SVf_ROK SVp_IOK SVp_POK )) { doconst($const); } diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index b1ec063..65970cf 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -29,6 +29,7 @@ HV * T_HVREF CV * T_CVREF IV T_IV +UV T_UV I32 T_IV I16 T_IV I8 T_IV diff --git a/t/harness b/t/harness index ead3ebe..c46a870 100644 --- a/t/harness +++ b/t/harness @@ -15,23 +15,38 @@ use Test::Harness; $Test::Harness::switches = ""; # Too much noise otherwise $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; +#fudge DATA for now. +%datahandle = qw( + lib/bigint.t 1 + lib/bigintpm.t 1 + lib/bigfloat.t 1 + lib/bigfloatpm.t 1 + op/gv.t 1 + lib/complex.t 1 + lib/ph.t 1 + lib/soundex.t 1 + op/misc.t 1 + op/runlevel.t 1 + op/tie.t 1 + op/lex_assign.t 1 + pragma/subs.t 1 + ); + +foreach (keys %datahandle) { + unlink "$_.t"; +} + @tests = @ARGV; @tests = unless @tests; Test::Harness::runtests @tests; exit(0) unless -e "../testcompile"; -#fudge DATA for now. %infinite = qw ( - op/bop.t 1 - lib/hostname.t 1 - ); - -%datahandle = qw( - lib/bigint.t 1 - lib/bigintpm.t 1 - lib/bigfloat.t 1 - lib/bigfloatpm.t 1 + op/bop.t 1 + lib/hostname.t 1 + op/lex_assign.t 1 + lib/ph.t 1 ); my $dhwrapper = <<'EOT'; @@ -42,7 +57,7 @@ EOT @tests = grep (!$infinite{$_}, @tests); @tests = map { my $new = $_; - if ($datahandle{$_}) { + if ($datahandle{$_} && !( -f $new.t) ) { $new .= '.t'; local(*F, *T); open(F,"<$_") or die "Can't open $_: $!";