All --
Attached is a diff for assemble.pl that does a somewhat messy job of
solving the problem posed in the TODO file. It does it by parsing
the root of each opcode when parsing the opcode table and creating a
hash with the opcode root and the formal argument types (qualifiers)
so that, e.g. $opqual{'add'}{'i:ic'} == 'add_i_ic'.
This appears to work. I've tested the output of assembling euclid.pasm
and got the same results as before. YMMV.
I left some debugging printfs in the file but commented out. A cooler
approach would do some sort of partial matching if you specified some
qualifiers, such as "add_i I4, I4, 3" mapping to "add_i_ic I4, I4, 3".
Anyway, enjoy.
Regards,
-- Gregor
_____________________________________________________________________
/ perl -e 'srand(-2091643526); print chr rand 90 for (0..4)' \
Gregor N. Purdy [EMAIL PROTECTED]
Focus Research, Inc. http://www.focusresearch.com/
8080 Beckett Center Drive #203 513-860-3570 vox
West Chester, OH 45069 513-860-3579 fax
\_____________________________________________________________________/
Index: assemble.pl
===================================================================
RCS file: /home/perlcvs/parrot/assemble.pl,v
retrieving revision 1.8
diff -u -r1.8 assemble.pl
--- assemble.pl 2001/09/12 09:54:46 1.8
+++ assemble.pl 2001/09/12 21:13:55
@@ -4,7 +4,7 @@
use strict;
-my(%opcodes, %labels);
+my(%opcodes, %opqual, %labels);
my ($output, $opt_c);
if (@ARGV and $ARGV[0] eq "-c") {
shift @ARGV;
@@ -24,6 +24,14 @@
's'=>'i',
'D'=>'i');
+my %qual_type=('i'=>'ic',
+ 'n'=>'nc',
+ 'N'=>'n',
+ 'I'=>'i',
+ 'S'=>'s',
+ 's'=>'sc',
+ 'D'=>'ic');
+
my $sizeof_packi = length(pack($pack_type{i},1024));
open GUTS, "interp_guts.h";
@@ -45,8 +53,19 @@
$opcodes{$name}{ARGS} = $args;
$opcodes{$name}{TYPES} = [@types];
$opcodes{$name}{RTYPES}=[@rtypes];
+
+ my ($root, @qual) = split /_/, $name;
+ my $qual = join(':', map { $qual_type{$_} } @rtypes);
+ $opqual{$root}{$qual} = $name;
}
+#print STDERR "Opcode Table:\n";
+#foreach my $op (sort keys %opqual) {
+# foreach my $qual (sort keys %{$opqual{$op}}) {
+# printf STDERR " %-10s %-15s %-10s\n", $op, $qual, $opqual{$op}{$qual};
+# }
+#}
+
my $pc = 0;
my @code;
my %constants;
@@ -77,6 +96,46 @@
my ($opcode, @args) = split /\s+/, $_;
+ if ($opcode =~ m/^[a-z]+$/i and ref $opqual{$opcode}) { # If it doesn't have
+any argument qualifiers
+# print STDERR "Seeking opcode for '$opcode'...\n";
+ my @qual = ();
+
+ my $arg;
+ foreach $arg (@args) { # Scan arguments after destination register
+# print STDERR " ... Arg: $arg\n";
+
+ if ($arg =~ m/^I\d+$/) { # Treat integer registers as 'i'
+ push @qual, 'i';
+ } elsif ($arg =~ m/^N\d+$/) { # Treat numeric registers as 'n'
+ push @qual, 'n';
+ } elsif ($arg =~ m/^S\d+$/) { # Treat numeric registers as 'n'
+ push @qual, 's';
+ } elsif ($arg =~ m/^\d+$/) { # Treat manifest integers as 'ic'
+ push @qual, 'ic';
+ } elsif ($arg =~ m/^\d+\.\d*$/) { # Treat manifest decimals as 'nc'
+ push @qual, 'nc';
+ } elsif ($arg =~ m/^\$/) { # Treat manifest strings as 'sc'
+ push @qual, 'sc';
+ $arg =~ s/^\$//; # Strip off the constant tag
+ } elsif ($labels{$arg}) { # Treat labels as 'ic'
+ push @qual, 'ic';
+ } else {
+ die "Unrecognizable argument: '$arg'!";
+ }
+ }
+
+ if (@qual) {
+ my $qual = join(':', @qual);
+# print STDERR "Qualifiers: $qual\n";
+ my $name = $opqual{$opcode}{$qual};
+ die "Cannot find opcode for root '$opcode' and qualifiers ($qual)!" unless
+$name;
+ $opcode = $name;
+ } else {
+ die "Cannot determine qualifiers for root '$opcode' and arguments (" .
+join(', ', @args) . ")!"
+ if $opcodes{$opcode}{ARGS};
+ }
+ }
+
if (!exists $opcodes{lc $opcode}) {
die "No opcode $opcode at line $line:\n <$_>\n";
}
@@ -111,7 +170,8 @@
my $s = shift;
return $constants{$s} if exists $constants{$s};
push @constants, $s;
- return $constants{$s} = $#constants;
+ $constants{$s} = $#constants;
+ return '$' . $constants{$s}; # We use the '$' prefix later to identify strings.
}
sub emit_magic { $output .= pack($pack_type{i}, 0x13155a1) }
