Patch: assembler deferred output

[Bryan C . Warnock]

Following patch defers output of opcode until the end of an error-free run.
Also introduces a primitive '-c' option to allow checking of assembly only 
(a la Perl).

Index: assemble.pl
===================================================================
RCS file: /home/perlcvs/parrot/assemble.pl,v
retrieving revision 1.6
diff -u -r1.6 assemble.pl
--- assemble.pl 2001/09/10 21:26:08     1.6
+++ assemble.pl 2001/09/11 01:45:34
@@ -5,6 +5,11 @@
 use strict;
 
 my(%opcodes, %labels);
+my ($output, $opt_c);
+if (@ARGV and $ARGV[0] eq "-c") {
+    shift @ARGV;
+    $opt_c = 1;
+}
 
 my %pack_type;
 %pack_type = (i => 'l',
@@ -52,14 +57,16 @@
 
 # Now assemble
 $pc = 0;
+my $line = 0;
 while ($_ = shift @code) {
+    $line++;
     chomp;
     s/,/ /g;
 
     my ($opcode, @args) = split /\s+/, $_;
 
     if (!exists $opcodes{lc $opcode}) {
-       die "No opcode $opcode";
+       die "No opcode $opcode at line $line:\n  <$_>\n";
     }
     if (@args != $opcodes{$opcode}{ARGS}) {
        die "wrong arg count--got ". scalar @args. " needed " . 
$opcodes{$opcode}{ARGS};
@@ -68,25 +75,27 @@
     $args[0] = fixup($args[0])
         if $opcode eq "branch_ic" and $args[0] =~ /[a-zA-Z]/;
 
-#    if ($opcode eq "eq_i_ic" or $opcode eq "lt_i_ic") {
-   if ($opcode =~ /^(eq|ne|lt|le|gt|ge)_i_ic$/) {
+#    if ($opcode eq "eq_i_ic_ic" or $opcode eq "lt_i_ic_ic") {
+    if ($opcode =~ /^(eq|ne|lt|le|gt|ge)_i_ic_ic$/) {
         $args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
         $args[3] = fixup($args[3]) if $args[3] =~ /[a-zA-Z]/;
     }
-    if ($opcode eq "if_i_ic") {
+    if ($opcode eq "if_i_ic_ic") {
         $args[1] = fixup($args[1]) if $args[1] =~ /[a-zA-Z]/;
         $args[2] = fixup($args[2]) if $args[2] =~ /[a-zA-Z]/;
     }
 
-    print pack "l", $opcodes{$opcode}{CODE};
+    $output .= pack "l", $opcodes{$opcode}{CODE};
     foreach (0..$#args) {
        $args[$_] =~ s/^[INPS]?(\d+)$/$1/i;
        my $type = $pack_type{$opcodes{$opcode}{TYPES}[$_]};
-       print pack $type, $args[$_];
+       $output .= pack $type, $args[$_];
     }
     $pc += 1+@args;
 }
 
+print $output unless (defined $opt_c and $opt_c);
+
 sub fixup {
     my $l = shift;
     die "Unknown label $l" unless exists $labels{$l};
@@ -100,10 +109,10 @@
     return $constants{$s} = $#constants;
 }
 
-sub emit_magic { print pack($pack_type{i}, 0x13155a1) }
+sub emit_magic { $output .= pack($pack_type{i}, 0x13155a1) }
 
 # Dummy for now.
-sub emit_fixup_section { print pack($pack_type{i}, 0) }
+sub emit_fixup_section { $output .= pack($pack_type{i}, 0) }
 
 sub emit_constants_section {
     # First, compute how big it's going to be.
@@ -116,17 +125,17 @@
     }
 
     $size += $sizeof_packi if @constants; # That's for the number of 
constants
-    print pack($pack_type{i}, $size);
+    $output .= pack($pack_type{i}, $size);
     return unless @constants; # Zero means end of segment.
 
     # Then spit out how many constants there are, so we can allocate
-    print pack($pack_type{i}, scalar @constants);
+    $output .= pack($pack_type{i}, scalar @constants);
 
     # Now emit each constant
     for (@constants) {
-        print pack($pack_type{i},0) x 3; # Flags, encoding, type
-        print pack($pack_type{i},length($_)); # Strlen followed by that 
many bytes.
-        print $_;
-        print "\0" x (length($_) % $sizeof_packi); # Padding;
+        $output .= pack($pack_type{i},0) x 3; # Flags, encoding, type
+        $output .= pack($pack_type{i},length($_)); # Strlen followed by 
that many bytes.
+        $output .= $_;
+        $output .= "\0" x (length($_) % $sizeof_packi); # Padding;
     }
 }

-- 
Bryan C. Warnock
[EMAIL PROTECTED]