On Thu, 2001-09-13 at 02:23, Simon Cozens wrote:
> On Wed, Sep 12, 2001 at 11:23:27PM -0500, Brian Wheeler wrote:
> > I've been having tons of problems with labels in the current
> > assembler...so I wrote my own. It should provide all of the features
> > that the current assembler has. I'ved tested and ran all of the current
> > t/*.pasm files.
> >
> > Here it is...feedback is always welcome.
>
> Cool. Now, if it only handled abbreviated op names, I'd apply it... :)
>
> Simon
You, sir, are a very picky man. :)
Here it is...I tested it on this euclid.pasm:
MAIN: set I1, 96
set I2, 64
set I3, 0
set S1, "Algorithm E (Euclid's algorithm)"
print S1
E1: mod I4, I1, I2
E2: eq I4, I3, DONE, E3
E3: set I1, I2
set I2, I4
branch E1
DONE: print I2
end
Enjoy!
Brian
#! /usr/bin/perl -w
#
# pasm.pl - take a parrot assembly file and spit out a bytecode file
# This is based heavily on assemble.pl
# Brian Wheeler ([EMAIL PROTECTED])
use strict;
my $opt_c;
if (@ARGV and $ARGV[0] eq "-c") {
shift @ARGV;
$opt_c = 1;
}
# define data types
my(%pack_type)=('i'=>'l','n'=>'d');
my(%real_type)=('I'=>'i','i'=>'i',
'N'=>'i','n'=>'n',
'S'=>'i','s'=>'i',
'D'=>'i');
# compute sizes
my(%sizeof);
foreach (keys(%real_type)) {
$sizeof{$_}=length(pack($pack_type{$real_type{$_}},0));
}
# get opcodes from guts.
open GUTS, "interp_guts.h";
my %opcodes;
while (<GUTS>) {
next unless /\tx\[(\d+)\] = ([a-z_]+);/;
$opcodes{$2}{CODE} = $1;
}
close GUTS;
# get opcodes and their arg lists
open OPCODES, "<opcode_table" or die "Can't get opcode table, $!/$^E";
while (<OPCODES>) {
next if /^\s*#/;
chomp;
s/^\s+//;
next unless $_;
my ($name, $args, @types) = split /\s+/, $_;
my @rtypes=@types;
@types=map { $_ = $real_type{$_}} @types;
$opcodes{$name}{ARGS} = $args;
$opcodes{$name}{TYPES} = [@types];
$opcodes{$name}{RTYPES}=[@rtypes];
}
close OPCODES;
# read source and assemble
my $pc=0; my $op_pc=0;
my ($bytecode,%label,%fixup,%constants,@constants);
my $line=0;
while(<>) {
$line++;
chomp;
s/^\s*//;
s/\s*$//;
next if(/^\#/ || $_ eq "");
if(m/^((\S+):)?\s*(.+)?/) {
my($label,$code)=($2,$3);
if(defined($label) && $label ne "") {
if(exists($label{$label})) {
error("'$label' already defined!");
}
if(exists($fixup{$label})) {
# backpatch everything with this PC.
while(scalar(@{$fixup{$label}})) {
my $op_pc=shift(@{$fixup{$label}});
my $offset=shift(@{$fixup{$label}});
substr($bytecode,$offset,4)=pack('l',($pc-$op_pc)/4);
}
delete($fixup{$label});
}
$label{$label}=$pc; # store it.
}
next if(!defined($code));
1 while $code=~s/\"([^\\\"]*(?:\\.[^\\\"]*)*)\"/constantize($1)/eg;
$code=~s/,/ /g;
my($opcode,@args)=split(/\s+/,$code);
$opcode=lc($opcode);
if (!exists $opcodes{$opcode}) {
# try to determine _real_ opcode.
my @arg_t=();
foreach (@args) {
if(m/^([INPS])\d+$/) {
# a register.
push @arg_t,lc($1);
} elsif(m/^\d+$/) {
# a constant of some sort
push @arg_t,'(ic|nc|sc)';
} else {
# a label
push @arg_t,'ic';
}
}
my $test;
my($first,$last)=($arg_t[0],$arg_t[-1]);
if($first ne $last) {
$test="$opcode\_$first\_$last";
} else {
$test="$opcode\_$first";
}
my($found_op)=0;
foreach my $op (grep($_=~/^$opcode/,keys(%opcodes))) {
if($op=~/$test/) {
$opcode=$op;
$found_op=1;
last;
}
}
error("No opcode $opcode in <$_>") if(!$found_op);
}
if (@args != $opcodes{$opcode}{ARGS}) {
error("Wrong arg count--got ".scalar(@args)." needed
".$opcodes{$opcode}{ARGS});
}
$bytecode .= pack "l", $opcodes{$opcode}{CODE};
$op_pc=$pc;
$pc+=4;
foreach (0..$#args) {
my($rtype)=$opcodes{$opcode}{RTYPES}[$_];
my($type)=$opcodes{$opcode}{TYPES}[$_];
if($rtype eq "I" || $rtype eq "N" || $rtype eq "P" || $rtype eq
"S") {
# its a register argument
$args[$_]=~s/^[INPS](\d+)$/$1/i;
$pc+=$sizeof{$rtype}
} elsif($rtype eq "D") {
# a destination
if(!exists($label{$args[$_]})) {
# we have not seen it yet...put it on the fixup list
push(@{$fixup{$args[$_]}},$op_pc,$pc);
$args[$_]=0xffffffff;
} else {
$args[$_]=($label{$args[$_]}-$op_pc)/4;
}
$pc+=$sizeof{$rtype};
} else {
$args[$_]=oct($args[$_]) if($args[$_]=~/^0/);
$pc+=$sizeof{$rtype};
}
$bytecode .= pack $type, $args[$_];
}
}
}
my $output;
# build file in memory
# MAGIC COOKIE
$output=pack($pack_type{i},0x13155a1);
# FIXUP
if(keys(%fixup)) {
print STDERR "SQUAWK! These symbols were referenced but not
defined:\n";
foreach (sort(keys(%fixup))) {
print STDERR "\t$_ at pc: ";
foreach my $pc (@{$fixup{$_}}) {
print STDERR sprintf("%08x ",$pc);
}
print STDERR "\n";
}
exit;
} else {
# dump empty header
$output.=pack($pack_type{i},0);
}
# CONSTANTS
if(@constants) {
my($const);
# Then spit out how many constants there are, so we can allocate
$const .= pack($pack_type{i}, scalar @constants);
# Now emit each constant
for (@constants) {
$const .= pack($pack_type{i},0) x 3; # Flags, encoding, type
$const .= pack($pack_type{i},length($_)); # Strlen followed by that many bytes.
$const .= $_;
my $pad=(length($_) % $sizeof{i});
if($pad) {
$const .= "\0" x ($sizeof{i}-(length($_) % $sizeof{i})); # Padding;
}
}
$output.=pack($pack_type{i},length($const));
$output.=$const;
} else {
# no constants, dump empty header.
$output.=pack($pack_type{i},0);
}
## BYTECODE
$output.=$bytecode;
if(!$opt_c) {
print $output;
}
sub error {
my($message)=@_;
print STDERR "Error ($line): $message\n";
exit;
}
sub constantize {
my $s = shift;
return $constants{$s} if exists $constants{$s};
push @constants, $s;
return $constants{$s} = $#constants;
}
