Change PerlIO::Scalar and Via to scalar and via.

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

diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm
index 5e798ce..429405f 100644 (file)
--- a/ext/B/B/Assembler.pm
+++ b/ext/B/B/Assembler.pm
@@ -14,7 +14,7 @@ require ByteLoader;           # we just need its $VERSIOM
 
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(assemble_fh newasm endasm assemble);
-$VERSION = 0.02;
+$VERSION = 0.04;
 
 use strict;
 my %opnumber;
@@ -34,6 +34,15 @@ sub error {
 my $debug = 0;
 sub debug { $debug = shift }
 
+sub limcheck($$$$){
+    my( $val, $lo, $hi, $loc ) = @_;
+    if( $val < $lo || $hi < $val ){
+        error "argument for $loc outside [$lo, $hi]: $val";
+        $val = $hi;
+    }
+    return $val;
+}
+
 #
 # First define all the data conversion subs to which Asmdata will refer
 #
@@ -47,32 +56,46 @@ sub B::Asmdata::PUT_U8 {
            $c = substr($c, 0, 1);
        }
     } else {
+        $arg = limcheck( $arg, 0, 0xff, 'U8' );
        $c = chr($arg);
     }
     return $c;
 }
 
-sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
-sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
-sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
+sub B::Asmdata::PUT_U16 {
+    my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
+    pack("S", $arg);
+}
+sub B::Asmdata::PUT_U32 {
+    my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
+    pack("L", $arg);
+}
+sub B::Asmdata::PUT_I32 {
+    my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
+    pack("l", $arg);
+}
 sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
                                                   # may not even be portable between compilers
-sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
+sub B::Asmdata::PUT_objindex { # could allow names here
+    my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
+    pack("L", $arg);
+} 
 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
 sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
 
 sub B::Asmdata::PUT_strconst {
     my $arg = shift;
-    $arg = uncstring($arg);
-    if (!defined($arg)) {
+    my $str = uncstring($arg);
+    if (!defined($str)) {
        error "bad string constant: $arg";
-       return "";
+       $str = '';
     }
-    if ($arg =~ s/\0//g) {
+    if ($str =~ s/\0//g) {
        error "string constant argument contains NUL: $arg";
+        $str = '';
     }
-    return $arg . "\0";
+    return $str . "\0";
 }
 
 sub B::Asmdata::PUT_pvcontents {
@@ -82,9 +105,12 @@ sub B::Asmdata::PUT_pvcontents {
 }
 sub B::Asmdata::PUT_PV {
     my $arg = shift;
-    $arg = uncstring($arg);
-    error "bad string argument: $arg" unless defined($arg);
-    return pack("L", length($arg)) . $arg;
+    my $str = uncstring($arg);
+    if( ! defined($str) ){
+        error "bad string argument: $arg";
+        $str = '';
+    }
+    return pack("L", length($str)) . $str;
 }
 sub B::Asmdata::PUT_comment_t {
     my $arg = shift;
@@ -111,9 +137,14 @@ sub B::Asmdata::PUT_op_tr_array {
     return pack("S256", @ary);
 }
 # XXX Check this works
+# Note: $arg >> 32 is a no-op on 32-bit systems
 sub B::Asmdata::PUT_IV64 {
     my $arg = shift;
-    return pack("LL", $arg >> 32, $arg & 0xffffffff);
+    return pack("LL", ($arg >> 16) >>16 , $arg & 0xffffffff);
+}
+
+sub B::Asmdata::PUT_IV {
+    $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
 }
 
 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
@@ -129,9 +160,8 @@ sub uncstring {
 sub strip_comments {
     my $stmt = shift;
     # Comments only allowed in instructions which don't take string arguments
+    # Treat string as a single line so .* eats \n characters.
     $stmt =~ s{
-       (?sx)   # Snazzy extended regexp coming up. Also, treat
-               # string as a single line so .* eats \n characters.
        ^\s*    # Ignore leading whitespace
        (
          [^"]* # A double quote '"' indicates a string argument. If we
@@ -139,7 +169,7 @@ sub strip_comments {
        )
        \s*\#   # Any amount of whitespace plus the comment marker...
        .*$     # ...which carries on to end-of-string.
-    }{$1};     # Keep only the instruction and optional argument.
+    }{$1}sx;   # Keep only the instruction and optional argument.
     return $stmt;
 }
 
@@ -164,14 +194,13 @@ sub gen_header {
 sub parse_statement {
     my $stmt = shift;
     my ($insn, $arg) = $stmt =~ m{
-       (?sx)
        ^\s*    # allow (but ignore) leading whitespace
        (.*?)   # Instruction continues up until...
        (?:     # ...an optional whitespace+argument group
            \s+         # first whitespace.
            (.*)        # The argument is all the rest (newlines included).
        )?$     # anchor at end-of-line
-    }; 
+    }sx;
     if (defined($arg)) {
        if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
            $arg = hex($arg);
@@ -247,11 +276,12 @@ sub assemble {
        $quotedline =~ s/"/\\"/g;
        $out->(assemble_insn("comment", qq("$quotedline")));
     }
-    $line = strip_comments($line) or next;
-    ($insn, $arg) = parse_statement($line);
-    $out->(assemble_insn($insn, $arg));
-    if ($debug) {
-       $out->(assemble_insn("nop", undef));
+    if( $line = strip_comments($line) ){
+        ($insn, $arg) = parse_statement($line);
+        $out->(assemble_insn($insn, $arg));
+        if ($debug) {
+           $out->(assemble_insn("nop", undef));
+        }
     }
 }