#!/usr/bin/perl -w # asm21: two-pass assembler for HP-21xx minicomputers # $Id: asm21.pl 43 2005-12-06 03:15:39Z eric $ # Copyright 2000, 2002 Eric Smith # Improvements Copyright (c) 2005-2008 - Tim Riker # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License version 2 as # published by the Free Software Foundation. Note that permission is # not granted to redistribute this program under the terms of any # other version of the General Public License. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA use strict; ### Global variables: my ( %mnemtab, # mnemonics table, hash of 2D arrays @files, # array of filenames to process, originally from @ARGV $cond, # defined conditional, ' ', 'N' or 'Z' $cur_cond, # current conditional, ' ', 'N' or 'Z' $pass, # pass (1 or 2) $end, # end directive seen $lines, # total line count $words, # total word count $errors, # error count $warnings, # warning count $fileno, # current file number # $., # current line number (Perl built-in) $pc, # current program pointer $pc_save, # program pointer before org $repcount, # statement repeat count $new_repcount, # new statement repeat count being set on current line $line_base, # address of first object code word for current source line @words, # object code for current source line $listing_en, # listing enable $suppress, # suppress extra object words, controlled by SUP and UNS $sup_one, # suppress for a single source line %symtab, # symbol values %sym_def, # symbol definition lines, hash of array references %sym_ref, # symbol reference lines, hash of array references @object_words, # object code block $object_base, # address of first object code word in object block $leading_nuls, # number of nuls to write at beginning of "tape" $padding_nuls, # number of nuls to write between blocks $trailing_nuls, # number of nuls to write at end of "tape" ); %mnemtab = ( 'abs' => [[ \&pseudo_abs, 0, 0 ]], 'ada' => [[ \&mem_ref, 0, 0040000 ]], 'adx' => [[ \&mx, 0, 0105746 ]], 'ady' => [[ \&mx, 0, 0105756 ]], 'alf' => [[ \&shift_rot_a, 1, 0001700 ], [ \&shift_rot_a, 4, 0000027 ]], 'alr' => [[ \&shift_rot_a, 1, 0001400 ], [ \&shift_rot_a, 4, 0000024 ]], 'als' => [[ \&shift_rot_a, 1, 0001000 ], [ \&shift_rot_a, 4, 0000020 ]], 'adb' => [[ \&mem_ref, 0, 0044000 ]], 'and' => [[ \&mem_ref, 0, 0010000 ]], 'ars' => [[ \&shift_rot_a, 1, 0001100 ], [ \&shift_rot_a, 4, 0000021 ]], 'asc' => [[ \&pseudo_asc, 0, 0 ]], 'asl' => [[ \&eae_shift, 0, 0100020 ]], 'asr' => [[ \&eae_shift, 0, 0101020 ]], 'blf' => [[ \&shift_rot_b, 1, 0005700 ], [ \&shift_rot_b, 4, 0004027 ]], 'blr' => [[ \&shift_rot_b, 1, 0005400 ], [ \&shift_rot_b, 4, 0004024 ]], 'bls' => [[ \&shift_rot_b, 1, 0005000 ], [ \&shift_rot_b, 4, 0004020 ]], 'brs' => [[ \&shift_rot_b, 1, 0005100 ], [ \&shift_rot_b, 4, 0004021 ]], 'bss' => [[ \&pseudo_bss, 0, 0 ]], 'cax' => [[ \&mx, 0, 0101741 ]], 'cay' => [[ \&mx, 0, 0101751 ]], 'cbs' => [[ \&mx, 0, 0105774 ]], 'cbt' => [[ \&mx, 0, 0105766 ]], 'cbx' => [[ \&mx, 0, 0105741 ]], 'cby' => [[ \&mx, 0, 0105751 ]], 'cca' => [[ \&alter_skip_a, 1, 0003400 ]], 'ccb' => [[ \&alter_skip_b, 1, 0007400 ]], 'cce' => [[ \&alter_skip_a, 3, 0002300 ], [ \&alter_skip_b, 3, 0006300 ]], 'cla' => [[ \&alter_skip_a, 1, 0002400 ]], 'clb' => [[ \&alter_skip_b, 1, 0006400 ]], 'clc' => [[ \&iot, 0, 0106700 ]], 'cle' => [[ \&shift_rot_a, 2, 0000040 ], [ \&shift_rot_b, 2, 0004040 ], [ \&alter_skip_a, 3, 0002100 ], [ \&alter_skip_b, 3, 0006100 ]], 'clf' => [[ \&iot, 0, 0103100 ]], 'clo' => [[ \&implicit, 0, 0103101 ]], 'cma' => [[ \&alter_skip_a, 1, 0003000 ]], 'cmb' => [[ \&alter_skip_b, 1, 0007000 ]], 'cme' => [[ \&alter_skip_a, 3, 0002200 ], [ \&alter_skip_b, 3, 0006200 ]], 'cmw' => [[ \&mx, 0, 0105776 ]], 'cpa' => [[ \&mem_ref, 0, 0050000 ]], 'cpb' => [[ \&mem_ref, 0, 0054000 ]], 'cxa' => [[ \&mx, 0, 0101744 ]], 'cxb' => [[ \&mx, 0, 0105744 ]], 'cya' => [[ \&mx, 0, 0101754 ]], 'cyb' => [[ \&mx, 0, 0105754 ]], 'dec' => [[ \&pseudo_dec, 0, 0 ]], 'def' => [[ \&pseudo_def, 0, 0 ]], 'div' => [[ \&eae_mem_ref, 0, 0100400 ]], 'djp' => [[ \&dms, 0, 0105732 ]], 'djs' => [[ \&dms, 0, 0105733 ]], 'dld' => [[ \&eae_mem_ref, 0, 0104200 ]], 'dst' => [[ \&eae_mem_ref, 0, 0104400 ]], 'dsx' => [[ \&mx, 0, 0105761 ]], 'dsy' => [[ \&mx, 0, 0105771 ]], 'ela' => [[ \&shift_rot_a, 1, 0001600 ], [ \&shift_rot_a, 4, 0000026 ]], 'elb' => [[ \&shift_rot_b, 1, 0005600 ], [ \&shift_rot_b, 4, 0004026 ]], 'end' => [[ \&pseudo_end, 0, 0 ]], 'equ' => [[ \&pseudo_equ, 0, 0 ]], 'era' => [[ \&shift_rot_a, 1, 0001500 ], [ \&shift_rot_a, 4, 0000025 ]], 'erb' => [[ \&shift_rot_b, 1, 0005500 ], [ \&shift_rot_b, 4, 0004025 ]], 'fad' => [[ \&floating, 0, 0105000 ]], 'fdv' => [[ \&floating, 0, 0105060 ]], 'fix' => [[ \&floating, 0, 0105100 ]], 'flt' => [[ \&floating, 0, 0105120 ]], 'fmp' => [[ \&floating, 0, 0105040 ]], 'fsb' => [[ \&floating, 0, 0105020 ]], 'hed' => [[ \&pseudo_hed, 0, 0 ]], 'hlt' => [[ \&hlt, 0, 0102000 ]], 'ifn' => [[ \&pseudo_ifn, 0, 0 ]], 'ifz' => [[ \&pseudo_ifz, 0, 0 ]], 'ina' => [[ \&alter_skip_a, 6, 0002004 ]], 'inb' => [[ \&alter_skip_b, 6, 0006004 ]], 'ior' => [[ \&mem_ref, 0, 0030000 ]], 'isx' => [[ \&mx, 0, 0105760 ]], 'isy' => [[ \&mx, 0, 0105770 ]], 'isz' => [[ \&mem_ref, 0, 0034000 ]], 'jly' => [[ \&mx, 0, 0105762 ]], 'jpy' => [[ \&mx, 0, 0105772 ]], 'jmp' => [[ \&mem_ref, 0, 0024000 ]], 'jrs' => [[ \&dms, 0, 0105715 ]], 'jsb' => [[ \&mem_ref, 0, 0014000 ]], 'lax' => [[ \&mx, 0, 0101742 ]], 'lay' => [[ \&mx, 0, 0101752 ]], 'lbt' => [[ \&mx, 0, 0105763 ]], 'lbx' => [[ \&mx, 0, 0105742 ]], 'lby' => [[ \&mx, 0, 0105752 ]], 'lda' => [[ \&mem_ref, 0, 0060000 ]], 'ldb' => [[ \&mem_ref, 0, 0064000 ]], 'ldx' => [[ \&mx, 0, 0105745 ]], 'ldy' => [[ \&mx, 0, 0105755 ]], 'lfa' => [[ \&dms, 0, 0101727 ]], 'lfb' => [[ \&dms, 0, 0105727 ]], 'lia' => [[ \&iot, 0, 0102500 ]], 'lib' => [[ \&iot, 0, 0106500 ]], 'lsl' => [[ \&eae_shift, 0, 0100040 ]], 'lsr' => [[ \&eae_shift, 0, 0101040 ]], 'lst' => [[ \&pseudo_lst, 0, 0 ]], 'mbf' => [[ \&dms, 0, 0105703 ]], 'mbi' => [[ \&dms, 0, 0105702 ]], 'mbt' => [[ \&mx, 0, 0105765 ]], 'mbw' => [[ \&dms, 0, 0105704 ]], 'mia' => [[ \&iot, 0, 0102400 ]], 'mib' => [[ \&iot, 0, 0106400 ]], 'mpy' => [[ \&eae_mem_ref, 0, 0100200 ]], 'mvw' => [[ \&mx, 0, 0105777 ]], 'mwi' => [[ \&dms, 0, 0105705 ]], 'mwf' => [[ \&dms, 0, 0105706 ]], 'mww' => [[ \&dms, 0, 0105707 ]], 'nam' => [[ \&pseudo_nam, 0, 0 ]], 'nop' => [[ \&implicit, 0, 0000000 ]], 'oct' => [[ \&pseudo_oct, 0, 0 ]], 'org' => [[ \&pseudo_org, 0, 0 ]], 'orr' => [[ \&pseudo_orr, 0, 0 ]], 'ota' => [[ \&iot, 0, 0102600 ]], 'otb' => [[ \&iot, 0, 0106600 ]], 'paa' => [[ \&dms, 0, 0101712 ]], 'pab' => [[ \&dms, 0, 0105712 ]], 'pba' => [[ \&dms, 0, 0101713 ]], 'pbb' => [[ \&dms, 0, 0105713 ]], 'ral' => [[ \&shift_rot_a, 1, 0001200 ], [ \&shift_rot_a, 4, 0000022 ]], 'rar' => [[ \&shift_rot_a, 1, 0001300 ], [ \&shift_rot_a, 4, 0000023 ]], 'rbl' => [[ \&shift_rot_b, 1, 0005200 ], [ \&shift_rot_b, 4, 0004022 ]], 'rbr' => [[ \&shift_rot_b, 1, 0005300 ], [ \&shift_rot_b, 4, 0004023 ]], 'rep' => [[ \&pseudo_rep, 0, 0 ]], 'rrl' => [[ \&eae_shift, 0, 0100100 ]], 'rrr' => [[ \&eae_shift, 0, 0101100 ]], 'rsa' => [[ \&dms, 0, 0101730 ]], 'rsb' => [[ \&dms, 0, 0105730 ]], 'rss' => [[ \&alter_skip_a, 8, 0002001 ], [ \&alter_skip_b, 8, 0006001 ]], 'rva' => [[ \&dms, 0, 0101731 ]], 'rvb' => [[ \&dms, 0, 0105731 ]], 'sax' => [[ \&mx, 0, 0101740 ]], 'say' => [[ \&mx, 0, 0101750 ]], 'sbs' => [[ \&mx, 0, 0105773 ]], 'sbt' => [[ \&mx, 0, 0105764 ]], 'sbx' => [[ \&mx, 0, 0105740 ]], 'sby' => [[ \&mx, 0, 0105750 ]], 'sez' => [[ \&alter_skip_a, 2, 0002040 ], [ \&alter_skip_b, 2, 0006040 ]], 'sfb' => [[ \&mx, 0, 0105767 ]], 'sfc' => [[ \&iot, 0, 0102200 ]], 'sfs' => [[ \&iot, 0, 0102300 ]], 'sjp' => [[ \&dms, 0, 0101734 ]], 'sjs' => [[ \&dms, 0, 0105735 ]], 'skp' => [[ \&pseudo_skp, 0, 0 ]], 'sla' => [[ \&shift_rot_a, 3, 0000010 ], [ \&alter_skip_a, 5, 0002010 ]], 'slb' => [[ \&shift_rot_b, 3, 0004010 ], [ \&alter_skip_b, 5, 0006010 ]], 'soc' => [[ \&overflow, 0, 0102201 ]], 'sos' => [[ \&overflow, 0, 0102301 ]], 'spc' => [[ \&pseudo_spc, 0, 0 ]], 'ssa' => [[ \&alter_skip_a, 4, 0002020 ]], 'ssb' => [[ \&alter_skip_b, 4, 0006020 ]], 'ssm' => [[ \&dms, 0, 0101714 ]], 'sta' => [[ \&mem_ref, 0, 0070000 ]], 'stb' => [[ \&mem_ref, 0, 0074000 ]], 'stc' => [[ \&iot, 0, 0102700 ]], 'stf' => [[ \&iot, 0, 0102100 ]], 'sto' => [[ \&implicit, 0, 0102101 ]], 'stx' => [[ \&mx, 0, 0105743 ]], 'sty' => [[ \&mx, 0, 0105753 ]], 'sup' => [[ \&pseudo_sup, 0, 0 ]], 'swp' => [[ \&implicit, 0, 0101100 ]], 'sya' => [[ \&dms, 0, 0101710 ]], 'syb' => [[ \&dms, 0, 0105710 ]], 'sza' => [[ \&alter_skip_a, 7, 0002002 ]], 'szb' => [[ \&alter_skip_b, 7, 0006002 ]], 'tbs' => [[ \&mx, 0, 0105775 ]], 'ujp' => [[ \&dms, 0, 0105736 ]], 'ujs' => [[ \&dms, 0, 0105737 ]], 'unl' => [[ \&pseudo_unl, 0, 0 ]], 'uns' => [[ \&pseudo_uns, 0, 0 ]], 'usa' => [[ \&dms, 0, 0101711 ]], 'usb' => [[ \&dms, 0, 0105711 ]], 'xif' => [[ \&pseudo_xif, 0, 0 ]], 'xax' => [[ \&mx, 0, 0101747 ]], 'xay' => [[ \&mx, 0, 0101757 ]], 'xbx' => [[ \&mx, 0, 0105747 ]], 'xby' => [[ \&mx, 0, 0105757 ]], 'xca' => [[ \&dms, 0, 0101726 ]], 'xcb' => [[ \&dms, 0, 0105726 ]], 'xla' => [[ \&dms, 0, 0101724 ]], 'xlb' => [[ \&dms, 0, 0105724 ]], 'xma' => [[ \&dms, 0, 0101722 ]], 'xmb' => [[ \&dms, 0, 0105722 ]], 'xmm' => [[ \&dms, 0, 0105720 ]], 'xms' => [[ \&dms, 0, 0107721 ]], 'xor' => [[ \&mem_ref, 0, 0020000 ]], 'xsa' => [[ \&dms, 0, 0101725 ]], 'xsb' => [[ \&dms, 0, 0105725 ]], ); @files = @ARGV; $leading_nuls = 5; $padding_nuls = 0; $trailing_nuls = 20; $errors = 0; $pc_save = 0; $warnings = 0; #&define_symbol('A', 0); #&define_symbol('B', 1); my $listing = $files[0]; my $object = 'object'; $listing =~ s/\.[a-z]*//; #print "$listing $files[0]\n"; if ($listing eq $files[0]) { $listing = 'listing'; } else { $object = "$listing.abs"; $listing .= '.lst'; } PASS: for ($pass = 1; $pass <= 2; $pass++) { # printf "pass %d\n", $pass; # last if (($pass == 2) && (! $object_out) && (! $listing_out)) @ARGV = @files; $end = 0; $fileno = 1; $lines = 0; $pc = 0; $words = 0; $repcount = 0; $listing_en = 1; $suppress = 0; $cond = ' '; $cur_cond = ' '; open(LISTING, ">$listing") || die("can't open listing file: \"$listing\""); open(OBJECT, ">$object") || die("can't open object file: \"$object\""); binmode(OBJECT); for (my $i = 0; $i < $leading_nuls; $i++) { printf OBJECT "%c", 0; } while (<>) { if ($end) { close ARGV; next PASS; } $lines++; s/[ \r\n]*$//; # strip trailing spaces and left over \r \n if (($fileno == 1) && ($. == 1) && (substr($_, 0, 5) eq 'ASMB,')) { &process_asmb($_); } else { &process_line($_); } # After each file, reset the line number to 1. # from the Camel book, 2nd edition, page 160 if (eof) { close ARGV; $fileno++; } } } &print_symtab(); print LISTING "$lines lines assembled, $words words generated\n"; print LISTING "$errors errors, $warnings warnings\n"; close LISTING; &close_object(); exit 0; ### end of main program ### sub process_asmb { my ($line) = @_; my $lline = $line; if ($line !~ /^ASMB,([A-Z](,[A-Z])*)([ ]|$)/) { &error('unrecognized ASMB control statement'); return; } for (split /,/, $1) { /^A$/ and do { # A: absolute (vs. relocatable) next; }; /^B$/ and do { # B: binary output next; }; /^C$/ and do { # C: cross-reference output next; }; /^F$/ and do { # F: floating point instructions &error('F in ASMB control statement is unimplemented'); next; }; /^L$/ and do { # L: listing output next; }; /^N$/ and do { # N: include IFN conditionals $cond = 'N'; next; }; /^R$/ and do { # R: relocatable (vs. absolute) (not yet supported) &error('R in ASMB control statement is unimplemented'); next; }; /^T$/ and do { # T: table print next; }; /^X$/ and do { # X: nonextended arithmetic unit (no ASR, ASL, RRR, RRL, LSR, # LSL, SWP. MPY, DIV, DLD, DST replaced by subroutine call) &error('X in ASMB control statement is unimplemented'); next; }; /^Z$/ and do { # Z: include IFZ conditionals $cond = 'Z'; next; }; &error('unrecognized option'); } &print_listing_line($lline); } sub process_line { my ($line) = @_; my $lline = $line; my ($label, $mnem, $args); my (@mnems); my ($func, $opcode); $new_repcount = 0; # deal with entirely blank lines if ($line =~ /^\s*$/) { &warning('repeat of comment') if $repcount; $repcount = 0; &print_listing_line($lline); return; } # deal with comment lines if ($line =~ /^\*/) { &warning('repeat of comment') if $repcount; $repcount = 0; &print_listing_line($lline); return; } do { $line_base = undef; @words = (); $sup_one = 0; undef $label; if ($line =~ s/^([^\s]+)//) { $label = $1; } $line =~ s/\s*([^\s]+)\s*//; $mnem = lc $1; # printf "label '%s', mnemonic '%s', rest '%s'\n", $label, $mnem, $line; @mnems = split /,/, $mnem; if (@mnems < 1) { &error('no mnemonic found'); return; } ($func, $opcode) = &find_opcode(@mnems); if (($cur_cond ne ' ') && ($cur_cond ne $cond) && ($func != \&pseudo_ifn) && ($func != \&pseudo_ifz) && ($func != \&pseudo_xif) && ($func != \&pseudo_end)) { &print_listing_line($lline); } else { &$func($label, $opcode, $line); &print_listing_line($lline); $line = $lline; } } while (--$repcount > 0); $repcount = $new_repcount; } sub print_listing_line { my ($line) = @_; my $i; return if (($pass != 2) || (! $listing_en)); # deal with entirely blank lines if ($line =~ /^\s*$/) { print LISTING "\n"; return; } printf LISTING "%04d", $.; # deal with comment lines if ($line =~ /^\*/) { printf LISTING "%s\n", $line; return; } print LISTING ' '; if ( defined $line_base) { printf LISTING "%05o ", $line_base; } else { print LISTING ' '; } if (scalar(@words) != 0) { printf LISTING "%06o ", $words [0]; } else { printf LISTING ' '; } printf LISTING "%s\n", $line; if ((! $suppress) && (! $sup_one)) { for ($i = 1; $i < scalar(@words); $i++) { printf LISTING " %05o %06o\n", $line_base + $i, $words [$i]; } } } sub write_object_word { my ($val) = @_; print OBJECT pack('CC', $val >> 8, $val & 0xff); } sub emit_object_block { my ($csum) = 0; my $i; write_object_word(scalar(@object_words) << 8); write_object_word($object_base); $csum = ($csum + $object_base) & 0xffff; for ($i = 0; $i < scalar(@object_words); $i++) { write_object_word($object_words [$i]); $csum = ($csum + $object_words [$i]) & 0xffff; } write_object_word($csum); for ($i = 0; $i < $padding_nuls; $i++) { printf OBJECT "%c", 0; } @object_words = (); } sub close_object { my $i; if (scalar(@object_words)) { emit_object_block(); } for ($i = 0; $i < $trailing_nuls; $i++) { printf OBJECT "%c", 0; } close OBJECT; } sub emit_object { my ($val) = @_; if (! scalar(@object_words)) { $object_base = $pc; } if (($pc != ($object_base + scalar(@object_words))) || (scalar(@object_words) >= 27)) { emit_object_block(); $object_base = $pc; } push(@object_words, $val); } sub emit_listing { my ($val) = @_; if (! defined $line_base) { $line_base = $pc; } if ($pc != ($line_base + scalar(@words))) { &error('discontiguous object code'); printf LISTING "pc %06o, line base %06o, %d words\n", $pc, $line_base, @words; } push(@words, $val); } sub emit { my ($val) = @_; if ($pass == 2) { emit_listing($val); emit_object($val); } $pc++; $words++; } sub emit_fp { my ($val) = @_; my $exp = 0; my $neg; my $mant; $mant = $val; $neg = ($mant < 0); $mant = -$mant if $neg; if ($mant == 0) { $exp = 0; } elsif ($mant >= 1.0) { while ($mant >= 1.0) { $mant /= 2.0; $exp++; if ($exp > 127) { &warning('overflow in floating point constant'); $mant = 0.5; $exp = 127; last; } } } elsif ($mant < 0.5) { while ($mant < 0.5) { $mant *= 2.0; $exp--; if ($exp < -127) { &warning('underflow in floating point constant'); $mant = 0; $exp = 0; last; } } } # While the mantissa magnitude of positive numbers is [0.5, 1.0), # apparently the mantissa magnitude of negative numbers is # (0.5, 1.0]. So -4.0 is represented as -1 * 2**2 rather than # -0.5 * 2**3. I don't really understand why they did it this # way, except that it must have made the microcode simpler. if ($neg && ($mant == 0.5)) { $mant *= 2.0; $exp--; } # $$$ Note: the rounding could cause an overflow, and we currently # do not detect this!!! $mant = int($mant * (2**23) + 0.5); $mant = -$mant if $neg; &emit(($mant >> 8) & 0177777); &emit((($mant & 0377) << 8) + (($exp & 0177) << 1) + ($exp < 0)); } sub warning { my ($msg) = @_; printf "%02d/%04d Warning: %s\n", $fileno, $., $msg; printf LISTING "%02d/%04d Warning: %s\n", $fileno, $., $msg; $warnings++; } sub error { my ($msg) = @_; printf "%02d/%04d Error: %s\n", $fileno, $., $msg; printf LISTING "%02d/%04d Error: %s\n", $fileno, $., $msg; $errors++; } sub implicit { my ($label, $opcode, $args) = @_; &define_symbol($label, $pc); &emit($opcode); } sub mem_ref { my ($label, $opcode, $args) = @_; my ($ind, $val, $page); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $ind = ($args =~ s/,[iI]$//); # check for indirect $val = &eval_expr($args); if (!defined $val) { &error("undefined value '$args'") if $pass != 1; $val = 0; } if ($val >= 1024) { if (($val & 0176000) != ($pc & 0176000)) { &error('address not in current page') } $page = 1; $val &= 01777; } else { $page = 0; } &emit(($ind << 15) + $opcode + ($page << 10) + $val); } sub alter_skip_a { my ($label, $opcode, $args) = @_; &define_symbol($label, $pc); &emit($opcode); } sub alter_skip_b { alter_skip_a(@_); } sub shift_rot_a { my ($label, $opcode, $args) = @_; &define_symbol($label, $pc); &emit($opcode); } sub shift_rot_b { shift_rot_a(@_); } sub iot { my ($label, $opcode, $args) = @_; my ($clr, $select); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $clr = ($args =~ s/,[cC]$//); # check for clear $select = &eval_expr($args); if (!defined $select) { &error("undefined value '$args'") if $pass != 1; $select = 0; } if (($select < 0) || ($select > 0100)) { &error('select code out of range'); $select = 0; } &emit($opcode + ($clr << 9) + ($select & 077)); } # hlt is an IOT, but the select code is optional sub hlt { my ($label, $opcode, $args) = @_; my $clr = 0; my $select = 0; &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following if ($args =~ /^$/) { ; } elsif ($args =~ /^[cC]$/) { $clr = 1; } elsif ($args =~ /^[0-9]+$/) { $select = 0 + $args; } else { $clr = ($args =~ s/,[cC]$//); # check for clear $select = &eval_expr($args); } if (!defined $select) { &error("undefined value '$args'") if $pass != 1; $select = 0; } if (($select < 0) || ($select > 0100)) { &error('select code out of range'); $select = 0; } &emit($opcode + ($clr << 9) + ($select & 077)); } sub overflow { my ($label, $opcode, $args) = @_; my $clr; &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $clr = ($args =~ /^[cC]$/); # check for clear &emit($opcode + ($clr << 9)); } sub eae_mem_ref { my ($label, $opcode, $args) = @_; my ($ind, $val); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $ind = ($args =~ s/,[iI]$//); # check for indirect $val = &eval_expr($args); if (!defined $val) { &error("undefined value '$args'") if $pass != 1; $val = 0; } &emit($opcode); &emit(($ind << 15) + $val); } sub eae_shift { my ($label, $opcode, $args) = @_; my $count; &define_symbol($label, $pc); $count = &eval_expr($args); if (!defined $count) { &error('undefined value') if $pass != 1; $count = 16; } if (($count < 1) || ($count > 16)) { &error('shift count out of range'); $count = 16; } &emit($opcode + ($count & 017)); } sub floating { my ($label, $opcode, $args) = @_; &define_symbol($label, $pc); &emit($opcode); } sub mx { my ($label, $opcode, $args) = @_; # just like implicit &define_symbol($label, $pc); &emit($opcode); } sub dms { my ($label, $opcode, $args) = @_; # just like implicit &define_symbol($label, $pc); &emit($opcode); } sub badop { my ($label, $opcode, $args) = @_; } sub pseudo_abs { my ($label, $opcode, $args) = @_; my ($val); &define_symbol($label, $pc); $val = &eval_expr($args); if (!defined $val) { &error('undefined value') if $pass != 1; $val = 0; } &emit($val); } sub pseudo_asc { my ($label, $opcode, $args) = @_; my ($count, $c1, $c2); &define_symbol($label, $pc); if ($args =~ s/^([0-9]+),//) { $count = 0 + $1; } else { &error('count required'); $count = 0; } while ($count--) { $c1 = 040; if (length $args) { $c1 = ord $args; $args = substr $args, 1; } $c2 = 040; if (length $args) { $c2 = ord $args; $args = substr $args, 1; } &emit(($c1 << 8) + $c2); } } sub pseudo_bss { my ($label, $opcode, $args) = @_; my $val; &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $val = &eval_expr($args); $sup_one = 1; $line_base = $pc; $pc = $pc + $val; } sub pseudo_dec { my ($label, $opcode, $args) = @_; my (@args, $arg); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following @args = split /,/, $args; if (@args < 1) { &error("no argument(s)"); return; } foreach $arg (@args) { if ($arg =~ /^[+\-]?[0-9]+$/) { &emit((0 + $arg) & 0177777); } elsif ($arg =~ /^[+\-]?(([0-9]+\.[0-9]*)|(\.[0-9]+)|((([0-9]+(\.[0-9]*)?)|(\.[0-9]+))[eE][+\-]?[0-9]+))$/) { &emit_fp((0 + $arg)); } else { &error("invalid decimal contant '$arg'"); &emit(0); } } } sub pseudo_def { my ($label, $opcode, $args) = @_; my ($ind, $val); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following $ind = ($args =~ s/,[iI]$//); # check for indirect $val = &eval_expr($args); if (!defined $val) { &error('undefined value') if $pass != 1; $val = 0; } &emit(($ind << 15) + $val); } sub pseudo_end { my ($label, $opcode, $args) = @_; # $$$ should make sure no label $end = 1; } sub pseudo_equ { my ($label, $opcode, $args) = @_; my ($val); $val = &eval_expr($args); if (defined $val) { &define_symbol($label, $val); $line_base = $val & 077777; # HP shows value in address field :-( } else { &error('undefined value') if $pass != 1; } } sub pseudo_hed { my ($label, $opcode, $args) = @_; # $$$ should make sure no label } sub pseudo_ifn { my ($label, $opcode, $args) = @_; # $$$ should make sure no label if ($cur_cond ne ' ') { &warning('nested conditional'); } $cur_cond = 'N'; } sub pseudo_ifz { my ($label, $opcode, $args) = @_; # $$$ should make sure no label if ($cur_cond != ' ') { &warning('nested conditional'); } $cur_cond = 'Z'; } sub pseudo_lst { my ($label, $opcode, $args) = @_; $listing_en++; } sub pseudo_nam { my ($label, $opcode, $args) = @_; } sub pseudo_oct { my ($label, $opcode, $args) = @_; my (@args, $arg, $sign, $val); &define_symbol($label, $pc); $args =~ s/\s.*//; # drop whitespace and anything following @args = split /,/, $args; if (@args < 1) { &error("no argument(s)"); return; } foreach $arg (@args) { $sign = ($arg =~ s/^-//) ? -1 : 1; if ($arg =~ /[0-7]+/) { $val = oct $arg; } else { &error("invalid octal contant '$arg'"); $val = 0; } &emit(($sign * $val) & 0177777); } } sub pseudo_org { my ($label, $opcode, $args) = @_; my $val; $val = &eval_expr($args); if (defined $val) { $pc_save = $pc if ($pc_save == 0); $pc = $val; $line_base = $val; &define_symbol($label, $pc); } else { &error('undefined org value'); } } sub pseudo_orr { my ($label, $opcode) = @_; $pc = $pc_save; $line_base = $pc_save; &define_symbol($label, $pc); $pc_save = 0; } sub pseudo_rep { my ($label, $opcode, $args) = @_; &define_symbol($label, $pc); $new_repcount = 0 + &eval_expr($args); } sub pseudo_skp { my ($label, $opcode, $args) = @_; # $$$ should make sure no label # $$$ page eject } sub pseudo_spc { my ($label, $opcode, $args) = @_; # $$$ should make sure no label # $$$ skip $args lines of output; don't include SPC in listing } sub pseudo_sup { my ($label, $opcode, $args) = @_; # $$$ should make sure no label $suppress = 1; } sub pseudo_unl { my ($label, $opcode, $args) = @_; $listing_en--; } sub pseudo_uns { my ($label, $opcode, $args) = @_; # $$$ should make sure no label # &warning('UNS without SUP') if ($suppress == 0); $suppress = 0; } sub pseudo_xif { my ($label, $opcode, $args) = @_; # $$$ should make sure no label if ($cur_cond eq ' ') { &warning('unexpected XIF'); } $cur_cond = ' '; } sub define_symbol { my ($sym, $val) = @_; return if ! defined ($sym); if (defined($val)) { # allow redef to same value - is this a good idea? # right now we're doing it mostly to allow the symbol to # be set during both passes. if ((defined $symtab {$sym}) && ($symtab {$sym} != $val)) { &error("redefined symbol '$sym'") ; } $symtab {$sym} = $val; } if ($pass == 2) { if (! defined $sym_def{$sym}) { $sym_def{$sym} = []; } push(@{$sym_def{$sym}}, ($fileno << 16) + $.); } } sub lookup_symbol { my ($sym) = @_; if (! exists $symtab {$sym}) { $symtab {$sym} = undef; } if ($pass == 2) { if (! defined $sym_ref {$sym}) { $sym_ref {$sym} = []; } push(@{$sym_ref {$sym}}, ($fileno << 16) + $.); } return $symtab {$sym}; } sub print_symtab { my ($sym, $val, $file, $line, $refs); my $symcnt = 0; my $undefs = 0; my $unrefs = 0; my $undef_refs = 0; my $refcnt; my $sympad=0; foreach $sym (sort keys %symtab) { if (length($sym) > $sympad) { $sympad=int((length($sym) + 7) / 8) * 8; } } foreach $sym (sort keys %symtab) { $symcnt++; $val = $symtab {$sym}; # Previously used the following while loop instead of the foreach and # hash lookup above, but that resulted in random ordering. # while (($sym, $val) = each (%symtab)) { printf LISTING "%-*s", $sympad, $sym; if (defined $val) { printf LISTING "%06o", $val; } else { print LISTING 'undef '; $undefs++; } print LISTING ' '; &print_refs($sym_def{$sym}); print LISTING ' --'; $refcnt = &print_refs($sym_ref {$sym}); if (! defined $val) { $undef_refs += $refcnt; } $unrefs += ($refcnt == 0); if ($refcnt == 0) { print LISTING ' unreferenced'; } print LISTING "\n"; } printf LISTING "%d symbols", $symcnt; printf LISTING " %d unreferenced", $unrefs if ($unrefs); printf LISTING "\n"; printf LISTING "%d undefined symbols, %d references\n", $undefs, $undef_refs if ($undefs); } sub print_refs { my ($reflist) = @_; my $ref; foreach $ref (@$reflist) { printf LISTING " %02d/%04d", $ref >> 16, $ref & ((1 << 16) - 1); } return scalar(@$reflist); } sub eval_expr { my ($str) = @_; my ($sign, $val, $sum, $sym); $str =~ s/\s.*//; # drop whitespace and anything following if ($str !~ /^[-]/) { $str = "+" . $str; } $sum = 0; while (length($str)) { $val = 0; if ($str =~ s/^-//) { $sign = -1; } elsif ($str =~ s/^\+//) { $sign = 1; } else { &error('unrecognized expression operator'); return undef; } if ($str =~ s/^\*//) { $val = $pc; } elsif ($str =~ s/^([0-7]+[bB])//) { $val = oct $1; } elsif ($str =~ s/^([0-9]+)//) { $val = 0 + $1; } elsif ($str =~ s/^([a-zA-Z_.?%\#\$\&\[\/@\^\!][0-9a-zA-Z.?%\/=\#\$\&\[\/@\^\!]*)//) { $val = &lookup_symbol($1); } else { &error('unrecognized expression term'); return undef; } if (! defined $val) { # print "undefined term\n"; $sum = undef; } elsif (defined $sum) { $sum += $sign * $val; $sum += 65536 if $sum < 0; $sum &= 65535; } } return $sum; } # This huge mess determines whether there is a compatible # combination of the mnemonics the user specified, and returns the # base opcode and the handler function for the class. sub find_opcode { my @mnems = @_; my $i; my @entries; my @foo; my @index; my $opcode; # build an array of the mnemtab entries for the mnemonics # I had hoped to just say something like # @entries = @mnemtab {@mnems} # and check for undef elements in the resulting array, but # it doesn't seem to work. @entries = (); for ($i = 0; $i < scalar(@mnems); $i++) { if (exists $mnemtab {$mnems [$i]}) { @entries = (@entries, $mnemtab {$mnems [$i]}); } else { &error("invalid mnemonic '$mnems[$i]'"); return(\&badop, -1); } } $i = 0; @index = (-1) x @entries; @foo = (); while (($i >= 0) && ($i < @entries)) { $index [$i]++; if ($index [$i] >= scalar(@{$entries [$i]})) { $index [$i] = -1; $i--; } else { $foo [$i] = $entries[$i][$index[$i]]; $i++ if ($i == 0) || &compatible($foo [$i-1], $foo [$i]) } } if ($i < 0) { &error('invalid combination of mnemonics'); return(\&badop, -1); } $opcode = 0; for ($i = 0; $i < @entries; $i++) { $opcode |= $foo [$i][2]; } return($foo [0][0], $opcode) } sub compatible { my $i; return 0 if $_[0][0] != $_[1][0]; # classes don't match # This test is not necessary, the following one takes care of it. # return 0 if ($_[0][1] == 0) || ($_[1][1] == 0); # operations not combinable return 0 if $_[1][1] <= $_[0][1]; # bad ordering return 1; # combinable }