1N/A

1N/Apackage B::Assembler;

1N/Ause Exporter;

1N/Ause B qw(ppname);

1N/Ause B::Asmdata qw(%insn_data @insn_name);

1N/Ause Config qw(%Config);

1N/Arequire ByteLoader; # we just need its $VERSIOM

1N/A

1N/Ano warnings; # XXX

1N/A

1N/A@ISA = qw(Exporter);

1N/A@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);

1N/A$VERSION = 0.07;

1N/A

1N/Ause strict;

1N/Amy %opnumber;

1N/Amy ($i, $opname);

1N/Afor ($i = 0; defined($opname = ppname($i)); $i++) {

1N/A $opnumber{$opname} = $i;

1N/A}

1N/A

1N/Amy($linenum, $errors, $out); # global state, set up by newasm

1N/A

1N/Asub error {

1N/A my $str = shift;

1N/A warn "$linenum: $str\n";

1N/A $errors++;

1N/A}

1N/A

1N/Amy $debug = 0;

1N/Asub debug { $debug = shift }

1N/A

1N/Asub limcheck($$$$){

1N/A my( $val, $lo, $hi, $loc ) = @_;

1N/A if( $val < $lo || $hi < $val ){

1N/A error "argument for $loc outside [$lo, $hi]: $val";

1N/A $val = $hi;

1N/A }

1N/A return $val;

1N/A}

1N/A

1N/A

1N/Asub B::Asmdata::PUT_U8 {

1N/A my $arg = shift;

1N/A my $c = uncstring($arg);

1N/A if (defined($c)) {

1N/A if (length($c) != 1) {

1N/A error "argument for U8 is too long: $c";

1N/A $c = substr($c, 0, 1);

1N/A }

1N/A } else {

1N/A $arg = limcheck( $arg, 0, 0xff, 'U8' );

1N/A $c = chr($arg);

1N/A }

1N/A return $c;

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_U16 {

1N/A my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );

1N/A pack("S", $arg);

1N/A}

1N/Asub B::Asmdata::PUT_U32 {

1N/A my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );

1N/A pack("L", $arg);

1N/A}

1N/Asub B::Asmdata::PUT_I32 {

1N/A my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );

1N/A pack("l", $arg);

1N/A}

1N/Asub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)

1N/A # may not even be portable between compilers

1N/Asub B::Asmdata::PUT_objindex { # could allow names here

1N/A my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );

1N/A pack("L", $arg);

1N/A}

1N/Asub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }

1N/Asub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }

1N/Asub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }

1N/A

1N/Asub B::Asmdata::PUT_strconst {

1N/A my $arg = shift;

1N/A my $str = uncstring($arg);

1N/A if (!defined($str)) {

1N/A error "bad string constant: $arg";

1N/A $str = '';

1N/A }

1N/A if ($str =~ s/\0//g) {

1N/A error "string constant argument contains NUL: $arg";

1N/A $str = '';

1N/A }

1N/A return $str . "\0";

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_pvcontents {

1N/A my $arg = shift;

1N/A error "extraneous argument: $arg" if defined $arg;

1N/A return "";

1N/A}

1N/Asub B::Asmdata::PUT_PV {

1N/A my $arg = shift;

1N/A my $str = uncstring($arg);

1N/A if( ! defined($str) ){

1N/A error "bad string argument: $arg";

1N/A $str = '';

1N/A }

1N/A return pack("L", length($str)) . $str;

1N/A}

1N/Asub B::Asmdata::PUT_comment_t {

1N/A my $arg = shift;

1N/A $arg = uncstring($arg);

1N/A error "bad string argument: $arg" unless defined($arg);

1N/A if ($arg =~ s/\n//g) {

1N/A error "comment argument contains linefeed: $arg";

1N/A }

1N/A return $arg . "\n";

1N/A}

1N/Asub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above

1N/Asub B::Asmdata::PUT_none {

1N/A my $arg = shift;

1N/A error "extraneous argument: $arg" if defined $arg;

1N/A return "";

1N/A}

1N/Asub B::Asmdata::PUT_op_tr_array {

1N/A my @ary = split /\s*,\s*/, shift;

1N/A return pack "S*", @ary;

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_IV64 {

1N/A return pack "Q", shift;

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_IV {

1N/A $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_PADOFFSET {

1N/A $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;

1N/A}

1N/A

1N/Asub B::Asmdata::PUT_long {

1N/A $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;

1N/A}

1N/A

1N/Amy %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",

1N/A b => "\b", f => "\f", v => "\013");

1N/A

1N/Asub uncstring {

1N/A my $s = shift;

1N/A $s =~ s/^"// and $s =~ s/"$// or return undef;

1N/A $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;

1N/A return $s;

1N/A}

1N/A

1N/Asub strip_comments {

1N/A my $stmt = shift;

1N/A # Comments only allowed in instructions which don't take string arguments

1N/A # Treat string as a single line so .* eats \n characters.

1N/A $stmt =~ s{

1N/A ^\s* # Ignore leading whitespace

1N/A (

1N/A [^"]* # A double quote '"' indicates a string argument. If we

1N/A # find a double quote, the match fails and we strip nothing.

1N/A )

1N/A \s*\# # Any amount of whitespace plus the comment marker...

1N/A .*$ # ...which carries on to end-of-string.

1N/A }{$1}sx; # Keep only the instruction and optional argument.

1N/A return $stmt;

1N/A}

1N/A

1N/A

1N/Asub gen_header {

1N/A my $header = "";

1N/A

1N/A $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'

1N/A $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');

1N/A $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);

1N/A $header .= B::Asmdata::PUT_U32($Config{ivsize});

1N/A $header .= B::Asmdata::PUT_U32($Config{ptrsize});

1N/A $header;

1N/A}

1N/A

1N/Asub parse_statement {

1N/A my $stmt = shift;

1N/A my ($insn, $arg) = $stmt =~ m{

1N/A ^\s* # allow (but ignore) leading whitespace

1N/A (.*?) # Instruction continues up until...

1N/A (?: # ...an optional whitespace+argument group

1N/A \s+ # first whitespace.

1N/A (.*) # The argument is all the rest (newlines included).

1N/A )?$ # anchor at end-of-line

1N/A }sx;

1N/A if (defined($arg)) {

1N/A if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {

1N/A $arg = hex($arg);

1N/A } elsif ($arg =~ s/^0(?=[0-7]+$)//) {

1N/A $arg = oct($arg);

1N/A } elsif ($arg =~ /^pp_/) {

1N/A $arg =~ s/\s*$//; # strip trailing whitespace

1N/A my $opnum = $opnumber{$arg};

1N/A if (defined($opnum)) {

1N/A $arg = $opnum;

1N/A } else {

1N/A error qq(No such op type "$arg");

1N/A $arg = 0;

1N/A }

1N/A }

1N/A }

1N/A return ($insn, $arg);

1N/A}

1N/A

1N/Asub assemble_insn {

1N/A my ($insn, $arg) = @_;

1N/A my $data = $insn_data{$insn};

1N/A if (defined($data)) {

1N/A my ($bytecode, $putsub) = @{$data}[0, 1];

1N/A my $argcode = &$putsub($arg);

1N/A return chr($bytecode).$argcode;

1N/A } else {

1N/A error qq(no such instruction "$insn");

1N/A return "";

1N/A }

1N/A}

1N/A

1N/Asub assemble_fh {

1N/A my ($fh, $out) = @_;

1N/A my $line;

1N/A my $asm = newasm($out);

1N/A while ($line = <$fh>) {

1N/A assemble($line);

1N/A }

1N/A endasm();

1N/A}

1N/A

1N/Asub newasm {

1N/A my($outsub) = @_;

1N/A

1N/A die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';

1N/A die <<EOD if ref $out;

1N/A (perhaps you forgot an endasm()?)

1N/A

1N/A $linenum = $errors = 0;

1N/A $out = $outsub;

1N/A

1N/A $out->(gen_header());

1N/A}

1N/A

1N/Asub endasm {

1N/A if ($errors) {

1N/A die "There were $errors assembly errors\n";

1N/A }

1N/A $linenum = $errors = $out = 0;

1N/A}

1N/A

1N/Asub assemble {

1N/A my($line) = @_;

1N/A my ($insn, $arg);

1N/A $linenum++;

1N/A chomp $line;

1N/A if ($debug) {

1N/A my $quotedline = $line;

1N/A $quotedline =~ s/\\/\\\\/g;

1N/A $quotedline =~ s/"/\\"/g;

1N/A $out->(assemble_insn("comment", qq("$quotedline")));

1N/A }

1N/A if( $line = strip_comments($line) ){

1N/A ($insn, $arg) = parse_statement($line);

1N/A $out->(assemble_insn($insn, $arg));

1N/A if ($debug) {

1N/A $out->(assemble_insn("nop", undef));

1N/A }

1N/A }

1N/A}

1N/A

1N/A

1N/Asub asm {

1N/A return if $_[0] =~ /\s*\W/;

1N/A if (defined $_[1]) {

1N/A return if $_[1] eq "0" and

1N/A $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;

1N/A return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;

1N/A }

1N/A assemble "@_";

1N/A}

1N/A

1N/A1;

1N/A

1N/A