#!/usr/bin/perl
# 
# Copyright © 2015-2020 by Vincent Slyngstad
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS LISTED ABOVE BE LIABLE
# FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# 
# Except as contained in this notice, the names of the authors above
# shall not be used in advertising or otherwise to promote the sale, use
# or other dealings in this Software without prior written authorization
# from those authors.

@rem = '
@echo off
c:\perl5\bin\perl %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
@rem ' if @rem;

#
# Speed improvement:
#   Possibly store DF, IF left shifted 12 for faster EA
#     computation.
#   EA also (often) depends on (pc & 07600), so may
#     wish to cache that.

#
# Emit code to initialize simulation.
$boiler = <<'!HERE!';
//
// Fast C implementation of PDP-8 code.
#include <stdlib.h>
#include <stdio.h>
#include <termios.h>
#include <unistd.h>
#include <fcntl.h>

// Boilerplate startup.

// Main memory
int core[8*4096]; // As ints
typedef void (*code_t)(void);
code_t code[8*4096]; // As function pointers.

int IF = 0; // Capitalize to avoid keyword
int df = 0;
// IF is in pc, CIF sets ib.
int pc = 00200;
int npc; // Next pc
int ib = 0;
int swr = 07777;
int hlt = 0;
int ion = 0; // Interrupts are off
int ionn = 0; // ... and stay off
int inh = 0;
int um = 0;
int rib = 0;
int rif = 0;
// LINK is in lac.
int lac = 0;
int mq = 0;
int modeb = 0;
int sc = 0;
int gt = 0;
// I/O Devices.
int ttof = 0; // Teleprinter flag is clear
int ttofn = 0; // ... and stays clear
int ttie = 1; // Imput interrupts are enabled
int ttif = 0; // Keyboard input flag is clear
int ttit; // Input character temporary buffer
int ttib; // Input character buffer for KRS, KRB
int ttid; // Instructions until next input check
// Run-time behavior.
int interact = 0; // Not interactive
int trace = 0; // 1 iff trace output desired
int echar = 0205; // Usually ^E
// Temporaries
int skp;
int irq;

void emul8();

//
// Compiled code:
!HERE!

#
# Compiler command line parsing.  Command lines can use:
# =0nnnnn to specify a starting address to the run-time.
# %0nnnnn to specify run-time switch register contents.
# !0nnnnn to specify a run-time exit character other than ^E.
# -i to activate interaction after HLT by default.
# -t to activate trace output on stderr by default.
@files = ();
foreach (@ARGV) {
  $npc = "$1" if /\=(0\d+)/;
  $boiler =~ s/pc = 00200/pc = $npc/ if s/\=(0\d+)//;
  $nswr = "$1" if /\%(0\d+)/;
  $boiler =~ s/swr = 07777/swr = $nswr/ if s/\%(0\d+)//;
  $echar = "$1" if /\!(0\d+)/;
  $boiler =~ s/echar = 0205/echar = $echar/ if s/\!(0\d+)//;
  die "Number is not octal: '$1'\n" if s/([=\%!]\d+)//;
  next if $_ eq '';
  $boiler =~ s/interact = 0/interact = 1/ if $_ eq "-i";
  next if $_ eq "-i";
  $boiler =~ s/trace = 0/trace = 1/ if $_ eq "-t";
  next if $_ eq "-t";
  die "Unsupported option '$_'\n" if /^-(.*)/;
  # Must be a filename.
  push(@files, $_);
}

# BUGBUG: Load more input files?  Name the output file better?
die "Need just one file to load: @files\n" unless $#files == 0;
&readBin($files[0], *core);

open(STDOUT, ">foo.c") || die "foo.c: $!";
select STDOUT; $| = 1; # Unbuffered, please

print $boiler;

#
# Read a file in BIN loader format.
sub readBin {
  local($file, *core) = @_;
  #
  # Open the input file in binary mode and read it in.
  open(INPUT, $file) || die "$file: $!";
  binmode(INPUT);
  @core = ();
  $isbin = 0;   # Might be RIM format (no checksum)
  for (;;) {
    $field = 0;
    $loc = $store = undef;
    $sum = $add = 0;
    while (read(INPUT, $top, 1)) {
      $top = unpack("C", $top);
      return if $top == 0232; # Stop at ^Z
      last unless $top == 0200;
    }
    # EOF leaves $top eq ''
    last if $top eq '';
    # At the top of this loop the first character has been read
    for (;;) {
      last if $top == 0200;	# Trailer
      # No trailer, so store data (if any)
      if (defined($store)) {
        $core[$field*010000 + $loc] = $store;
        $store = undef;
        $loc = ($loc + 1) & 07777;
        $sum += $add; # Update checksum
        $isbin = 1 unless $top & 0100;
        $fortran = 0;
      }
      if (($top&0300) == 0300) {
        # Set data field and we're done. 
        $field = ($top & 070) >> 3;
#print "Loading into field $field\n";
        $isbin = 1;     # Can't be RIM format
        $fortran = 1 if $top == 00340;
      } else {
        # Assemble a word
        read(INPUT, $bot, 1) || die "read: $! $top at ", tell(INPUT);
        $bot = unpack("C", $bot);
        die "$file: not in bin format at ", tell(INPUT) unless $bot <= 077;
        $word = ($top << 6) + $bot;
        $add = $top + $bot; # Calculate Checksum delta
        if ($word > 07777) {
          #
          # Change location counter
          $loc = $word & 07777;
          $sum += $add; # Update checksum
        } else {
          # Remember store in case this is the checksum, not data.
          die "$file: no location counter" unless defined($loc);
          $store = $word;
        }
      }
      last unless read(INPUT, $top, 1);
      $top = unpack("C", $top);
    }
    die "No trailer!" unless $top == 0200;
    if ($isbin) {
      if ($fortran) {
        printf STDERR "$file: 4K Fortran binary!\n";
        $sum += 0640; # Fortran loader counts 0300 and 0340;
      }
      $sum = ($sum - $store) & 07777;
      printf STDERR "$file: Checksum error -- %04o\n", $sum if $sum;
    } else {
      # Last frame of what looks like a RIM tape!
      printf STDERR "Found a RIM tape segment ending at %05o\n",
                        $field*010000 + $loc;
      $core[$field*010000 + $loc] = $store;
    }
  }
  close(INPUT);
}

#
# Pass 1:
# Scan the program and remember which locations are used as data, subroutines,
# or possible branch targets.
# BUGBUG: This is currently wasted, as pass 2 doesn't really use it!
@ref = ();
$DREF = 1; # A direct data reference ("Dxxxx")
$IREF = 2; # An indirect reference ("Pxxxx")
$LREF = 4; # A direct branch reference ("Lxxxx")
$RREF = 8; # Return reference (JMP I xxxx target)
$SREF = 16; # A JMS reference (possible "Sxxxx")
# Kludge: location zero is a subroutine (ISR), if included.
$ref[0000] = $SREF|$DREF|$RREF if defined $core[0000];
$usedfpp = $fpp = 0;
foreach ($loc = 0; $loc <= $#core; $loc++) {
  next unless defined $core[$loc];
  $op = $core[$loc] >> 9;
  # Note: Direct EA is always in the current field!
  $ea = $loc & 070000;
  $ea += $core[$loc] & 0177;
  $ea += $loc & 07600 if $core[$loc] & 0200; # Page bit set
  $ind = $core[$loc] & 0400; # Indirect reference
  if ($fpp) {
    if (($op > 0) && ($op < 7)) {
      #
      # Data reference implied by effective address
      if ($ind) {
        $ref[$ea] |= $IREF;
        $ea = $core[$ea];
        # Flag non-zero referent as a DREF
        $ref[$ea] |= $DREF if $ea;
      } else {
        $ref[$ea] |= $DREF;
      }
    }
    $fpp = 0 if $core[$loc] == 0;
  } elsif ($op <= 3) {
    #
    # Data reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF;
      $ea = $core[$ea];
      # Flag non-zero referent as a DREF
      $ref[$ea] |= $DREF if $ea;
    } else {
      $ref[$ea] |= $DREF;
    }
  } elsif ($op == 4) {
    #
    # Subroutine reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF;
      $ea = $core[$ea];
    }
    # Kludge: Make note if JMS I 7 (04407) is encountered.
    $usedfpp = $fpp = 1 if $core[$loc] == 04407;
    # Kludge: Qualify the target -- it should contain 0 or $ea.
    next unless ($core[$ea] == 0)  || ($core[$ea] == $ea);
    # Mark the entry point as a possible entry point and as data.
    $ref[$ea] |= $SREF|$DREF;
  } elsif ($op == 5) {
    #
    # Branch reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF|$RREF;
      $ea = $core[$ea];
      $ref[$ea] |= $LREF if $ea;
    } else {
      $ref[$ea] |= $LREF;
    }
  }
}

#
# Use $ref[] flags to compute the label, if any for a given EA.
sub ref {
  local($ea) = @_;
  local($oea) = sprintf("%05o", $ea);
  # If it's a target of a JMS and a return, it's a subroutine.
  return "S".$oea if ($ref[$ea] & ($SREF|$RREF)) == ($SREF|$RREF);
  # If it's a pointer to code or data, label it a pointer.
  return "P".$oea if $ref[$ea] & $IREF;
  # If it's the target of a branch, label it as code
  return "L".$oea if $ref[$ea] & $LREF;
  # If it's the target of a data instruction, label it as data.
  return "D".$oea if $ref[$ea] & $DREF;
  # Otherwise, return null label.
  return "";
}

#
# Pass 2:
# Print the Perl equivalent for each location that was loaded.
foreach ($loc = 0; $loc <= $#core; $loc++) {
  next unless defined $core[$loc];
  # Give this location a name.
  $name = &ref($loc);
  # If the name is null, it can be appended to the previous.
# BUGBUG: Skip doing that, for now.
  $oea = sprintf('%05o', $loc);
  $name = "I" . $oea if $name eq '';
  print "void $name() { ";
  # Now generate some Perl.
  if ($fpp) {
    &fpp;
# } elsif ($linc) {
#   &linc;
  } else {
    &pdp;
  }
  print " }\n";
}
print "void preinit() {\n";
foreach ($loc = 0; $loc <= $#core; $loc++) {
  next unless defined $core[$loc];
  # Give this location a name.
  $name = &ref($loc);
  # If the name is null, it can be appended to the previous.
# BUGBUG: Skip doing that, for now.
  $oea = sprintf('%05o', $loc);
  $name = "I" . $oea if $name eq '';
  $i = sprintf('%05o', $core[$loc]);
  print "  core[0$oea] = $i; code[0$oea] = &$name;\n";
}
print "}\n";

sub pdp {
  #
  # Compile as a normal PDP-8 instruction.
  $op = $core[$loc] >> 9;
  if ($op <= 5) {
    #
    # Operation refences memory
    # Note: Direct EA is always in the current IF!
    $ea = $loc & 070000;
    $ea += $core[$loc] & 0177;
    $ea += $loc & 07600 if $core[$loc] & 0200; # Page bit set
    if ($core[$loc] & 0400) { # Indirect reference
      if (($ea&07770) == 0010) { # Autoindex
        $ea = sprintf("%06o", $ea);
        print "if (++core[$ea] == 010000) core[$ea] = 0000;";
      }
      if ($op < 4) {
        $ea = '(df<<12)+core['.$ea.']';
      } else {
        $ea = '(ib<<12)+core['.$ea.']';
      }
    } else {
      $ea = sprintf("%06o", $ea);
    }
    if ($op == 0) { # AND
      print 'lac &= (010000|core['.$ea.']); ';
    } elsif ($op == 1) { # TAD
      print 'lac += core['.$ea.']; ';
    } elsif ($op == 2) { # ISZ
      print 'if (++core[',$ea,'] == 010000) { core[',$ea,'] = 0; npc++; }; ';
      print 'code[',$ea,'] = &emul8; ';
    } elsif ($op == 3) { # DCA
      print 'core[',$ea,'] = lac & 07777; lac &= 010000; ';
      print 'code[',$ea,'] = &emul8; ';
    } elsif ($op == 4) {  # JMS
      $i = sprintf("%05o", $loc+1);
      print 'core[',$ea,'] = ',$i,'; npc = ',$ea,'+1; ';
      print 'code[',$ea,'] = &emul8; inh = 0; ';
    } else { # JMP
      print 'npc = ',$ea,'; inh = 0; ';
    }
    # Make a note of calls to the floating point package
    $fpp = 1 if $core[$loc] == 04407;
  } elsif ($op == 6) {
    #
    # IOTs are generally hard.
    # Punt to &emul8, for now.
    print "emul8(); ";
  } else {
    # Must be an OPR.
    $op = $core[$loc];
    if (($op & 0400) == 0000) {
      #
      # Group 1 -- shifts, clears, complements
      # These are clearest when printed in chronological order.
      # The timing is model dependent, with the PDP-8I having the
      # strictest ordering.
      print 'lac &= 010000; ' if $op & 0200; # T1 CLA
      print 'lac &= 07777; '  if $op & 0100; # T1 CLL
      print 'lac ^= 010000; ' if $op & 0020; # T2 CML
      print 'lac ^= 07777; '  if $op & 0040; # T2 CMA
      print 'lac++; '  if ($op & 0001) == 001; # T3 IAC
      print 'lac = (lac<<1) + ((lac>>12)&1); ' if ($op & 0006) == 004; # T4 RAL
      print 'lac = (lac<<2) + ((lac>>11)&3); ' if ($op & 0006) == 006; # T4 RTL
      print 'lac = ((lac&017777)>>1) + ((lac&1)<<12); ' if ($op & 0012) == 010; # T4 RAR
      print 'lac = ((lac&017777)>>2) + ((lac&3)<<11); ' if ($op & 0012) == 012; # T4 RTR
      print 'lac = (lac&010000) + ((lac&077)<<6) + ((lac>>6)&077); ' if ($op & 0016) == 002; # T4 BSW
    } elsif (($op & 0401) == 0400) {
      #
      # Group 2 -- Skips, hlt, read switches
      # These are clearest when printed in chronological order.
      # The timing here is not model dependent.
      print 'skp = 0; '  if ($op & 0170) != 0000; # T1 may skip
      print 'if (!(lac&07777)) skp = 1; '  if $op & 0040; # T1 SZA
      print 'if (lac&04000) skp = 1; '  if $op & 0100; # T1 SMA
      print 'if (lac&010000) skp = 1; '  if $op & 0020; # T1 SNL
      print 'skp = !skp; '  if $op & 0010; # T1 SKP
      print 'npc += skp; ' if ($op & 0170) != 0000; # T1 SKP
      print 'lac &= 010000; ' if $op & 0200; # T2 CLA
      print 'lac |= swr; '  if ($op & 0004); # T3 OSR
      print 'hlt = 1; '   if ($op & 0002); # T4 HLT
    } else {
      #
      # Group 3 -- Extended Arithmetic Unit
      # Because the behavior depends on the mode (A or B), we punt these to &emul8.
      print "emul8(); ";
      return;
    }
  }
}

#
# Don't compile fpp for now, just use &emul8.
sub fpp {
  print "&emul8; ";
  $fpp = 0 if $core[$loc] == 0000;
  return;
# The rest of this is just notes.
  #
  # Disassemble as a floating point instruction.
  if ($op && $op <= 6) {
    local(@mri) = ("FADD", "FSUB", "FMPY", "FDIV", "FGET", "FPUT");
    #
    # Operation refences memory
    # Note: Direct EA is always in the current field!
    $ea = $loc & 070000;
    $ea += $core[$loc] & 0177;
    $ea += $loc & 07600 if $core[$loc] & 0200; # Page bit set
    if ((($ea&07777) < 0200) &&  ($core[$loc] & 0200)) {
      # Assembler never generates on-page references to page 0,
      # so just output octal.
      printf "%04o", $core[$loc];
      return;
    }
    $ind = $core[$loc] & 0400; # Indirect reference
    print $mri[$op-1], " ";
    print "I " if $ind;
    $oea = &ref($ea);
    print $oea if $oea;
    printf "%04o", $ea&07777 unless $oea;
  } elsif ($op == 0) {
    $op = $core[$loc];
    if (($op & 07760) == 0000) {
      #
      # Special functions
      $fpp = 0      if ($op & 017) == 000;
      print "FEXT"  if ($op & 017) == 000;
      print "FSQR"  if ($op & 017) == 001;
      print "FSQT"  if ($op & 017) == 002;
      print "FSIN"  if ($op & 017) == 003;
      print "FCOS"  if ($op & 017) == 004;
      print "FATN"  if ($op & 017) == 005;
      print "FEXP"  if ($op & 017) == 006;
      print "FLOG"  if ($op & 017) == 007;
      print "FNEG"  if ($op & 017) == 010;
      print "FINP"  if ($op & 017) == 011;
      print "FOUT"  if ($op & 017) == 012;
      print "0013"  if ($op & 017) == 013;
      print "0014"  if ($op & 017) == 014;
      print "0015"  if ($op & 017) == 015;
      print "0016"  if ($op & 017) == 016;
      print "0017"  if ($op & 017) == 017;
      return;
    }
    printf "%04o", $op;
    return;
  } else { # $op == 7
    $op = $core[$loc];
    print "FNOR"  if $op == 07000;
    return if $op == 07000;
    #
    # FNOR with operand??
    printf "%04o", $op;
  }
}

print <<'!HERE!';
// End of compiled code.

//
// More boilerplate.

//
// Emulate the hard stuff:
//   IOT instructions.
//   Group 3 OPR instructions (dependent on mode A or B).
//   Code modified at runtime.
void emul8() {
  register int op, ea;
  register int inst = core[pc];

  op = inst >> 9;
  if (op < 6) {
    //
    // Operation refences memory
    // Note: Direct EA is always in the current field!
    ea = pc & 070000;
    ea += inst & 0177;
    if (inst & 0200) ea += pc & 07600; // Page bit set
    if (inst & 0400) { // Indirect reference
      if ((ea&07770) == 0010) { // Autoindex
        if (++core[ea] == 010000) core[ea] = 0000;
      }
      if (op < 4) {
        ea = (df<<12)+core[ea];
      } else {
        ea = (ib<<12)+core[ea];
      }
    }
    if (op == 0) { // AND
      lac &= (010000|core[ea]);
    } else if (op == 1) { // TAD
      lac += core[ea];
    } else if (op == 2) { // ISZ
      if (++core[ea] == 010000) {
        core[ea] = 0;
        npc++;
      }
      code[ea] = &emul8;
    } else if (op == 3) { // DCA
      core[ea] = lac & 07777;
      lac &= 010000;
      code[ea] = &emul8;
    } else if (op == 4) { // JMS
      core[ea] = npc & 07777;
      npc = ea + 1;
      if ((ea & 07777) == 07777) npc -= 010000;
      code[ea] = &emul8;
      inh = 0;
    } else { // JMP
      npc = ea;
      inh = 0;
    }
  } else if (op == 6) {
    //
    // IOT -- hair ensues.
// BUGBUG: Should do more here.
    if ((inst&07770) == 06000) { // Interrupt control
      if ((inst&07) == 00) { // SKON
        npc += ion;
        ion = ionn = 0;
      } else if ((inst&07) == 01) { // ION
        ionn = 1;
      } else if ((inst&07) == 02) { // IOF
        ion = ionn = 0;
      } else if ((inst&07) == 03) { // SRQ
        npc += irq;
      } else if ((inst&07) == 04) { // GTF
        lac = (lac&010000)+((lac>>1)&04000)+(gt<<10)+(irq<<9)+(inh<<8)+(ion<<7)+rif;
      } else if ((inst&07) == 05) { // RTF
        int l = lac&04000;
        gt = !!(lac&02000);
        inh = !!(lac&0400);
        // Contrary to documentation, RTF ignores IE and enables interrupts.
        ionn = 1|!!(lac&0200);
        rif = lac&0177;
        lac = l<<1 | (lac&07777);
      } else if ((inst&07) == 06) { // SGT
        npc += gt;
      } else if ((inst&07) == 07) { // CAF
        lac = ion = ionn = ttof = ttofn = ttif = modeb = 0;
      }
    } else if ((inst&07700) == 06200) { // MMU
      int fld = (inst>>3) & 07;
      if (inst & 04) { // More decoding based on fld
        if (fld == 01) { // RDF
          lac |= df<<3;
        } else if (fld == 02) { // RIF
          lac |= pc>>12;
        } else if (fld == 03) { // RIB
          lac |= ib;
        } else if (fld == 04) { // RMF
          um = rif>>6;
          ib = (rif>>3)&07;
          df = rif&07;
        }
      } else { // fld is new IB, DF, or both
        if (inst & 01) { // CDF
          df = fld;
        }
        if (inst & 02) { // CIF
          ib = fld; // Save for next JMP, JMS
          inh = 1; // CIF sets inhibit to delay interrupts.
        }
      }
    } else if ((inst&07770) == 06010) { // High speed reader
    } else if ((inst&07770) == 06020) { // High speed punch
    } else if ((inst&07770) == 06030) { // Keyboard device
      if (inst == 06030) { // Clear input flag, no rrun
        ttif = 0;
      }
      if (inst & 01) { // Skip if ready
        npc += ttif;
      }
      if (inst & 02) { // Clear flag, set rrun
        lac &= 010000;
        ttif = 0;
      }
      if ((inst&05) == 04) { // OR in the last character
        lac |= ttib;
      } else if ((inst&05) == 05) { // TTY interrupt enable
        ttie = lac & 01;
      }
    } else if ((inst&07770) == 06040) { // Teleprinter device
      if (inst == 06040) { // Set printer flag
        ttof = ttofn = 1;
      } else if (inst == 06041) { // Skip if ready
        npc += ttof;
      } else if (inst == 06042) { // Clear flag
        ttof = ttofn = 0;
      }
      if (inst & 04) { // TLS, TPC Output a character
        ttofn = lac & 0177; // Borrow ttofn
//fprintf(stderr, "TLS %o\n", ttofn);
        write(1, &ttofn, 1);
        ttofn = 1;
      }
    } else if ((inst&07770) == 06070) { // VC8/I
    } else if ((inst&07770) == 06100) { // Memory Parity, Power Low
    } else if ((inst&07740) == 06140) { // 6140-6177 LINC, Type 338 display
    } else if ((inst&07770) == 06330) { // LAB-8
    } else if ((inst&07770) == 06340) { // LAB-8
    } else if ((inst&07700) == 06400) { // PT08
    } else if ((inst&07760) == 06760) { // 6760-6777 DECTape
    } else {
      fprintf(stderr, "IOT %05o treated as NOP\r\n", inst);
    }
  } else { // op == 7
    // Must be an OPR.
    if ((inst & 0400) == 0000) {
      //
      // Group 1 -- shifts, clears, complements
      // These are clearest when printed in chronological order.
      // The timing is model dependent, with the PDP-8I having the
      // strictest ordering.
      if (inst & 0200) lac &= 010000; // T1 CLA
      if (inst & 0100) lac &= 07777; // T1 CLL
      if (inst & 0020) lac ^= 010000; // T2 CML
      if (inst & 0040) lac ^= 07777; // T2 CMA
      if (inst & 0001) lac++; // T3 IAC
      if ((inst & 0006) == 004) lac = (lac<<1) + ((lac>>12)&1); // T4 RAL
      if ((inst & 0006) == 006) lac = (lac<<2) + ((lac>>11)&3); // T4 RTL
      if ((inst & 0012) == 010) lac = ((lac&017777)>>1) + ((lac&1)<<12); // T4 RAR
      if ((inst & 0012) == 012) lac = ((lac&017777)>>2) + ((lac&3)<<11); // T4 RTR
      if ((inst & 0016) == 002) lac = (lac&010000) + ((lac&077)<<6) + ((lac>>6)&077); // T4 BSW
    } else if ((inst & 0401) == 0400) {
      //
      // Group 2 -- Skips, hlt, read switches
      // These are clearest when printed in chronological order.
      // The timing here is not model dependent.
      skp = 0; // T1 may skip
      if (inst & 0040) skp = !(lac&07777); // T1 SZA
      if (inst & 0100) skp |= (lac&04000); // T1 SMA
      if (inst & 0020) skp |= (lac&010000); // T1 SNL
      if (inst & 0010) skp = !skp; // T1 SKP
      npc += !!skp; // T1 SKP
      if (inst & 0200) lac &= 010000; // T2 CLA
      if (inst & 0004) lac |= swr; // T3 OSR
      if (inst & 0002) hlt = 1; // T4 HLT
    } else {
      //
      // Group 3 -- Extended Arithmetic Unit
      // Where to find the operand (if any) depends on the mode (A or B).
      if (inst & 0200) lac &= 010000; // T1 CLA
      if ((inst & 0120) == 0100) {
        lac |= mq; // T2 MQA
      } else if ((inst & 0120) == 0020) {
        mq = lac & 07777; // T2 MQL
        lac &= 010000;
        if (inst & 010) modeb = 1; // SWAB=7431
      } else if ((inst & 0120) == 0120) {
        ea = lac; // Borrow 'ea' as temporary
        lac = (lac&010000) + mq;
        mq = ea & 07777; // T2 SWP
      }
      if ((inst & 0376) == 0046) modeb = gt = 0; // SWBA=7447
// BUGBUG: This EAE stuff is surely still wrong.
      if (modeb) {
        op = inst & 056;
	// Mode B EAE operations fetch a 24 bit operand whose
	// address is in the next word of the instruction stream.
        if (op == 000) { // T3 NOP
        } else if (op == 002) { // T3 ASC
          sc = lac & 037; lac &= 010000;
        } else if (op == 004) { // T3 MUY
//fprintf(stderr, "EAE Mode B MUY @%05o\r\n", pc);
          ea = (df<<12) + core[npc++]; // Address in DF
	  // The operand is single precision.
          op  = core[ea];
          op = ((lac<<12)+mq) * op;
          lac = op >> 12;
          mq  = op & 07777;
        } else if (op == 006) { // T3 DVI
//fprintf(stderr, "EAE Mode B DVI @%05o\r\n", pc);
          ea = (df<<12) + core[npc++]; // Address in DF
	  // The operand is single precision.
          op  = core[ea];
          lac &= 07777;
          ea  = (lac<<12)+mq;
          if (!op) {
            mq = 010000; // Force divide overflow
          } else {
            mq = ea / op;
          }
          if (mq & ~07777) {
            lac |= 010000;
            mq = (2*ea&07777) + 1;
            sc = 037;
          } else {
            lac  = ea % op;
          }
        } else if (op == 010) { // T3 NMI (must not set CLA, MQA, or MQL)
//fprintf(stderr, "EAE Mode B NMI @%05o\r\n", pc);
          sc = 0;
          lac = (lac<<12)+mq;
          if (lac == 040000000) lac = 0; // Negative zero?
          // 00000+02000 = 02000
          // 02000+02000 = 04000
          // 04000+02000 = 06000
          // 06000+02000 = 00000
          while ((lac & 017777777) && (~(lac+020000000) & 040000000)) {
            lac = lac << 1; // shl and try again
            sc++;
          }
          mq  = lac & 07777;
          lac = lac >> 12;
        } else if (op == 012) { // T3 SHL
//fprintf(stderr, "EAE Mode B SHL @%05o\r\n", pc);
          lac = (lac<<12) + mq;
          // Note one less shift than mode A
          lac = lac << core[npc++];
          mq  = lac & 07777;
          lac = lac >> 12;
          sc = 037;
        } else if (op == 014) { // T3 ASR
//fprintf(stderr, "EAE Mode B ASR @%05o\r\n", pc);
          lac &= 07777;
          if (lac & 04000) lac |= 03770000; // Sign extend
          lac = (lac<<13) + (mq<<1) + gt;
          // Note one less shift than mode A
          lac = lac >> core[npc++];
          gt = lac & 1;
          mq  = (lac>>1) & 07777;
          lac = lac >> 13;
          sc = 037;
        } else if (op == 016) { // T3 LSR
//fprintf(stderr, "EAE Mode B LSR @%05o\r\n", pc);
          lac &= 07777; // Don't shift in from link
          // Note one less shift than mode A
          lac = (lac<<13) + (mq<<1) + gt;
          lac = lac >> core[npc++];
          gt = lac & 1;
          mq  = (lac>>1) & 07777;
          lac = lac >> 13;
          sc = 037;
        } else if (op == 040) { // T3 SCA
          lac |= sc;
        } else if (op == 042) { // T3 DAD
//fprintf(stderr, "EAE Mode B DAD @%05o\r\n", pc);
          ea = (df<<12) + core[npc++]; // Address in DF
          op  = core[ea++]; // Least significant first
          op += core[ea]<<12;
          lac &= 07777; // Clear link
          lac = (lac<<12) + mq + op; // Carry out sets Link
          mq  = lac & 07777;
          lac = lac >> 12;
        } else if (op == 044) { // T3 DST
          ea = (df<<12) + core[npc++]; // Address in DF
          core[ea++] = mq; // Least significant first
          core[ea] = lac;
        } else if (op == 046) { // T3 SWBA
          modeb = 0;
        } else if (op == 050) { // T3 DPSZ
          if (((lac&07777)|mq) == 0) npc++;
        } else if (op == 052) { // T3 DPIC (must set MQA and MQL)
          // This is microcoded with MQA and MQL set.
          // As a result, MQ and LAC were swapped above, and
          // We need to swap them back here.
          lac = (mq<<12) + (lac&07777) + 1;
//fprintf(stderr, "EAE Mode B DPIC @%05o\r\n", pc);
          mq  = lac & 07777;
          lac = lac >> 12;
        } else if (op == 054) { // T3 DCM (must set MQA and MQL)
          // This is microcoded with MQA and MQL set.
          // As a result, MQ and LAC were swapped above, and
          // We need to swap them back here.
          lac &= 07777;
          lac = (~((mq<<12)+lac) & 077777777) + 1;
//fprintf(stderr, "EAE Mode B DCM @%05o\r\n", pc);
          mq  = lac & 07777;
          lac = (lac >> 12) & 017777;
        } else if (op == 056) { // T3 SAM
          lac &= 07777;
//fprintf(stderr, "EAE Mode B SAM @%05o\r\n", pc);
          gt  = (mq &04000)? mq  | 037777770000 : mq;
          gt -= (lac&04000)? lac | 037777770000 : lac;
          gt = gt >= 0;
          lac = mq + (~lac & 07777) + 1;
        }
//fprintf(stderr, "EAE Mode B %05o treated as NOP\r\n", inst);
      } else { // mode A
        if (inst & 0040) lac |= sc; // T2 SCA
	// Mode A EAE operations fetch an operand from the
        // next word of the instruction stream.
        if ((inst & 016) == 002) { // T3 SCL
          sc = (~core[npc++]) & 037;
        } else if ((inst & 016) == 004) { // T3 MUY
//fprintf(stderr, "EAE Mode A MUY @%05o\r\n", pc);
          op  = mq*core[npc] + (lac&07777);
//fprintf(stderr, "EAE Mode A MUY got %05o\r\n", op);
          lac = op >> 12;
          mq  = op & 07777;
          npc++;
        } else if ((inst & 056) == 006) { // T3 DVI, w/no SCA
          // SWBA executed in Mode A should not skip!
          // Previously, SWBA decoded as SCA DVI, which caused
          // it to skip the DVI operand.
//fprintf(stderr, "EAE Mode A DVI @%05o\r\n", pc);
          op = core[npc];
          lac &= 07777;
          ea  = (lac<<12)+mq;
          // Set link, first subtract
          if (!op) {
            mq = 010000; // Force divide overflow
          } else {
            mq = ea / op;
          }
          if (mq & ~07777) {
            //lac = 010000 | op;
            lac |= 010000;
            mq = (2*ea&07777) + 1;
            sc = 037;
          } else {
            lac  = ea % op;
          }
          npc++;
        } else if ((inst & 016) == 010) { // T3 NMI
//fprintf(stderr, "EAE Mode A NMI @%05o\r\n", pc);
          sc = 0;
          lac = (lac<<12)+mq;
          // 00000+02000 = 02000
          // 02000+02000 = 04000
          // 04000+02000 = 06000
          // 06000+02000 = 00000
          while ((lac & 017777777) && (~(lac+020000000) & 040000000)) {
            lac = lac << 1; // shl and try again
            sc++;
          }
          mq  = lac & 07777;
          lac = (lac >> 12) & 017777;
        } else if ((inst & 016) == 012) { // T3 SHL
//fprintf(stderr, "EAE Mode A SHL @%05o\r\n", pc);
          op = 1 + core[npc++];
          op = op > 31? 31 : op;
          lac = ((lac<<12)+mq) << op;
//fprintf(stderr, "EAE Mode A SHL partial result %08o\r\n", lac);
          gt = 0;
          mq  = lac & 07777;
          lac = (lac >> 12) & 017777;
        } else if ((inst & 016) == 014) { // T3 ASR
//fprintf(stderr, "EAE Mode A ASR @%05o\r\n", pc);
          op = 1 + core[npc++];
          op = op > 31? 31 : op;
          lac &= 07777;
          if (lac & 04000) lac |= 03770000; // Sign extend
          lac = ((lac<<12)+mq) >> op;
          gt = 0;
          mq  = lac & 07777;
          lac = lac >> 12;
        } else if ((inst & 016) == 016) { // T3 LSR
//fprintf(stderr, "EAE Mode A LSR @%05o\r\n", pc);
          op = 1 + core[npc++];
          op = op > 31? 31 : op;
          lac &= 07777; // Shift in zeroes
          lac = ((lac<<12)+mq) >> op;
          gt = 0;
          mq  = lac & 07777;
          lac = lac >> 12;
        }
      }
    }
  }
}

struct termios origtty;
struct termios rawtty;

void rawmode(void) {
  // Let these all silently fail is stdin is not a tty.
  tcgetattr(0, &origtty); // Save this for later
  tcgetattr(0, &rawtty); // Starts out the same
  cfmakeraw(&rawtty); // but is mangled hare
  tcsetattr(0, TCSAFLUSH, &rawtty);
  fcntl(0, F_SETFL, O_NONBLOCK);
}

void oldmode(void) {
  tcsetattr(0, TCSAFLUSH, &origtty);
  fcntl(0, F_SETFL, 0);
}

int main(int argc, char **argv) {
  int i;
  register code_t *f;
  //
  // Run-time Command line parsing.  Command lines can use:
  // =0nnnnn to specify a starting address.
  // %0nnnnn to specify switch register contents.
  // !0nnnnn to specify an exit character other than ^E.
  // -i to activate interaction after HLT.
  // -t to activate trace output on stderr.
  // Other stuff on the command line is retained with the intent
  //   to eventually add code to pass file specs to USR when OS/8
  //   support is added.
//@usr = ();
  for (i = 1; i < argc; i++) {
// BUGBUG: These overlap shell meta characters.  Shouldn't use #, !, etc.
    if (*argv[i] == '=') {
      sscanf(argv[i]+1, "%o", &pc);
    } else if (*argv[i] == '%') {
      sscanf(argv[i]+1, "%o", &swr);
    } else if (*argv[i] == '!') {
      sscanf(argv[i]+1, "%o", &echar);
    } else if (*argv[i] == '-') {
      if (argv[i][1] == 'i') {
        interact = 1;
      } else if (argv[i][1] == 't') {
        trace = 1;
      } else {
        fprintf(stderr, "Unsupported option '%s'\n", argv[i]);
        exit(1);
      }
    } else {
      // Save this one for USR
#if 0
    s/_/</; # Sneaks '<' past the shell
    y/A-Z/a-z/; # Monocase for USR
    push(@usr, $_);
#endif
    }
  }
  preinit(); // Initialize memory.
  rawmode(); // Set input to "raw" mode.
  atexit(&oldmode);

  //
  // The main execution loop.
  while (!hlt) {
    // Return if we are halted
// hlt = 1 if ++vrs > 100000;
    if (hlt) break;
    // This cruft is here because interrupt based programs don't
    // necessarily poll the input device.
    // What we want is to allow (but not encourage) over-run, 
    // with the new character replacing the old.
    // Note that we don't get here at all until the program
    // asks about keyboard ready..
    if (!ttid) {
      ttit = read(0, &ttib, 1);
      if (ttit > 0) {
        ttib |= 0200; // Fix up the character
        ttif = 1; // ... and set the flag.
        if (ttib == echar) { // Type ^E to hlt
          hlt++;
        }
      } else {
        ttid = 1000; // No input, again in 1000 instructions.
      }
    } else {
      ttid--;
    }
    irq = (ttie&ttof) | (ttie&ttif); // TODO: OR in others here too.
    if (ion && !inh) {
      // Interrupts are allowed, so do them.
      if (irq) {
        // Interrupt does a JMS 00000.
        rib = (um<<6)+(lac>>9)+df;
        core[00000] = pc & 07777;
        pc = 00001;
        ion = ionn = 0;
      }
    } 
    ion = ionn; // Allow one instruction after ION.
    ttof = ttofn; // Allow at least one after TLS, before interrupt.
    f = code + pc;
    npc = pc + 1; // Default next instruction
    if (trace || !*f) {
      fprintf(stderr, "%05o %04o %02o %05o:%04o\r\n", lac, mq, sc, pc, core[pc]);
    }
    // Check for code[pc] == 0.
    if (!*f) {
      fprintf(stderr, "Unitialized code fetched at %05o\r\n", pc);
      hlt = 1;
    } else {
      // This deals with PC wrap-around.
      // (D0CC actually depends on wrap for "false carry" tests.)
      if ((npc & 07777) == 0) npc -= 010000;
      (*f)(); // Call some compiled code
    }
    pc = npc;
  }
  //
  // Break means a HLT was done.
  exit(lac & 07777);
}

!HERE!
close(STDOUT);

#chmod(0755, "foo.pl") || die "foo.pl: $!";

__END__
:endofperl