#!/usr/bin/perl
#
# a7out: user-mode simulator for PDP-7 Unix applications
#
# (c) 2016 Warren Toomey, GPL3
#
use strict;
use warnings;
use Data::Dumper;

### Global variables ###
my $debug      = 0;    # Debug flag
my $singlestep = 0;    # Are we running in single-step mode?
my %Breakpoint;        # Hash of defined breakpoints
my @Mem;               # 8K 18-bit words of main memory
my @FD;                # Array of open filehandles

# Registers
my $PC   = 0;          # Program counter
my $AC   = 0;          # Accumulator
my $LINK = 0;          # Link register, either 0 or LINKMASK
my $MQ   = 0;          # MQ register

# Constants
use constant MAXINT    => 0777777;     # Biggest unsigned integer
use constant MAXPOSINT => 0377777;     # Biggest signed integer
use constant MAXADDR   => 017777;      # Largest memory address
use constant LINKMASK  => 01000000;    # Mask for LINK register
use constant EAESTEP   => 077;         # EAE step count mask

### Main program ###

# Get any optional arguments
while ( defined( $ARGV[0] ) && ( $ARGV[0] =~ m{^-} ) ) {

    # -d: debug mode
    if ( $ARGV[0] eq "-d" ) {
        $debug = 1; shift(@ARGV);
    }

    # -b: set a breakpoint
    if ( $ARGV[0] eq "-b" ) {
        $singlestep = 1; shift(@ARGV);
        $Breakpoint{ oct( shift(@ARGV) ) } = 1;
    }
}

# Check the arguments
die("Usage: $0 [-d] [-b breakpoint] a.outfile [arg1 arg2 ...]\n")
  if ( @ARGV < 1 );

# Load the a.out file into memory
# and simulate it
load_code( $ARGV[0] );
set_arguments();

#dump_memory(0, MAXADDR, 0);
#exit(0);
simulate();
exit(0);

### Load the a.out file into memory
sub load_code {
    my $filename = shift;

    # Fill all the 8K words in memory with zeroes
    foreach my $i ( 0 .. MAXADDR ) {
        $Mem[$i] = 0;
    }

    # Set up some open filehandles
    $FD[0] = \*STDIN;
    $FD[1] = \*STDOUT;
    $FD[8] = \*STDERR;    # According to cat.s (uses d8 == 8)

    # Open up the PDP-7 executable file
    open( my $IN, "<", $filename ) || die("Unable to open $filename: $!\n");
    while (<$IN>) {
        chomp;

        # Lose any textual stuff after a tab character
        $_ =~ s{\t.*}{};

        # Split into location and value, both in octal
        my ( $loc, $val ) = split( /:\s+/, $_ );

        # Convert from octal and save
        $loc       = oct($loc);
        $val       = oct($val);
        $Mem[$loc] = $val;
    }
    close($IN);
}

### Copy the arguments into the PDP-7 memory space, and build
### an array of pointers to these arguments. Build a pointer
### at MAXADDR that points at the array.
###
### Each argument string is four words long and space padded if the
### string is not eight characters long. These are stored below
### address MAXADDR. Below this is the count of words in the strings.
### Address MAXADDR points at the word count. Graphically (for two arguments):
###
###     +------------+
###  +--|            | Location 017777 (MAXADDR)
###  |  +------------+
###  |  |............|
###  |  |............| argv[2]
###  |  |............|
###  |  +------------+
###  |  |............|
###  |  |............| argv[1]
###  |  |............|
###  |  +------------+
###  |  |............|
###  |  |............| argv[0]
###  |  |............|
###  |  +------------+
###  +->|  argc=12   |
###     +------------+
###
sub set_arguments {

    # Get the number of arguments including the command name
    my $argc = scalar(@ARGV);

    # We now know that argc will appear in memory
    # 4*argc +1 below location MAXADDR
    # Set argc to the number of words
    my $addr = MAXADDR - ( 4 * $argc + 1 );
    $Mem[MAXADDR] = $addr;
    $Mem[ $addr++ ] = $argc * 4;

    # Now start saving the arguments
    foreach (@ARGV) {

        # Truncate and/or space pad the argument
        my $str = sprintf( "%-8s", substr( $_, 0, 8 ) );

        # Store pairs of characters into memory
        for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
            my $c1 = substr( $str, $i,     1 ) || "";
            my $c2 = substr( $str, $i + 1, 1 ) || "";

            #printf("Saving %06o to %06o\n", (ord($c1) << 9 ) | ord($c2), $addr);
            $Mem[ $addr++ ] = ( ord($c1) << 9 ) | ord($c2);
        }
    }
}

### Simulate the machine code loaded into memory
sub simulate {

    # List of opcodes that we can simulate
    my %Oplist = (
        oct("000") => \&cal,
        oct("004") => \&dac,
        oct("010") => \&jms,
        oct("014") => \&dzm,
        oct("020") => \&lac,
        oct("030") => \&add,
        oct("024") => \&xor,
        oct("034") => \&tad,
        oct("044") => \&isz,
        oct("050") => \&and,
        oct("054") => \&sad,
        oct("060") => \&jmp,
        oct("064") => \&eae,
        oct("070") => \&iot,
        oct("074") => \&special,
    );

    # Loop indefinitely
    while (1) {

        # Get the instruction pointed to by PC and decode it
        my $instruction = $Mem[$PC];
        my $opcode      = ( $instruction >> 12 ) & 074;
        my $indirect    = ( $instruction >> 13 ) & 1;
        my $addr        = $instruction & MAXADDR;

        # Work out what any indirect address would be
        my $indaddr = ($indirect) ? $Mem[$addr] & MAXADDR : $addr;

        # If this is a breakpoint, stop now and get a user command
        $singlestep = 1 if ( defined( $Breakpoint{$PC} ) );
        get_user_command() if ($singlestep);
        dprintf( "PC %06o: ", $PC );

        #dprintf("PC %06o: instr %06o, op %03o, in %o, addr %06o indaddr %06o\n",
        #   $PC, $instruction, $opcode, $indirect, $addr, $indaddr );

        # Simulate the instruction. Each subroutine updates the $PC
        if ( defined( $Oplist{$opcode} ) ) {
            $Oplist{$opcode}->( $instruction, $addr, $indaddr );
        } else {
            printf( STDERR "Unknown instruction 0%o at location 0%o\n",
                $instruction, $PC );
            exit(1);
        }
    }
}

# Debug code: dump memory contents
# Print from $start to $end.
# Print empty locations if $yeszero
sub dump_memory {
    my ( $start, $end, $yeszero ) = @_;
    foreach my $i ( $start .. $end ) {
        printf( STDERR "%06o: %06o\n", $i, $Mem[$i] )
          if ( $yeszero || $Mem[$i] != 0 );
    }
}

# Load AC
sub lac {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "lac %06o (value %06o) into AC\n", $indaddr, $Mem[$indaddr] );
    $AC = $Mem[$indaddr];
    $PC++;
}

# Deposit AC
sub dac {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "dac AC (value %06o) into %06o\n", $AC, $indaddr );
    $Mem[$indaddr] = $AC;
    $PC++;
}

# Add to AC, twos complement
sub tad {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "tad AC (value %06o) with addr %06o (%06o)\n",
        $AC, $indaddr, $Mem[$indaddr] );
    $AC   = $AC + $Mem[$indaddr];
    $AC   = $AC & MAXINT;
    $LINK = $AC & LINKMASK;
    $PC++;
}

# Add to AC, ones complement
sub add {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "add AC (value %06o) with addr %06o (%06o)\n",
        $PC, $AC, $indaddr, $Mem[$indaddr] );
    $LINK = 0;
    $AC   = $AC + $Mem[$indaddr];
    if ( $AC & LINKMASK ) {
        $AC++;    # End-around carry
        $LINK = LINKMASK;
    }
    $AC = $AC & MAXINT;
    $PC++;
}

# And AC and Y
sub and {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "and AC (value %06o) with addr %06o (%06o)\n",
        $AC, $indaddr, $Mem[$indaddr] );
    $AC &= $Mem[$indaddr];
    $PC++;
}

# Xor AC and Y
sub xor {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "xor AC (value %06o) with addr %06o (%06o)\n",
        $AC, $indaddr, $Mem[$indaddr] );
    $AC ^= $Mem[$indaddr];
    $PC++;
}

# Skip if AC different to Y
sub sad {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "sad AC %06o cf. %06o\n", $AC, $Mem[$indaddr] );
    $PC += ( $AC != $Mem[$indaddr] ) ? 2 : 1;
}

# Deposit zero in memory
sub dzm {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "dzm into %06o\n", $indaddr );
    $Mem[$indaddr] = 0;
    $PC++;
}

# Index and skip if zero
sub isz {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "isz %06o\n", $Mem[$indaddr] );
    $Mem[$indaddr]++;
    $Mem[$indaddr] &= MAXINT;
    $PC += ( $Mem[$indaddr] == 0 ) ? 2 : 1;
}

# Jump
sub jmp {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "jmp %06o\n", $indaddr );
    $PC = $indaddr;
}

# Jump to subroutine
sub jms {
    my ( $instruction, $addr, $indaddr ) = @_;
    dprintf( "jms %06o\n", $indaddr );

    # Save the LINK and current PC into the $indaddr location
    $Mem[ $indaddr++ ] = $PC + 1 | ( ($LINK) ? 0400000 : 0 );
    $PC = $indaddr;
}

# Special instructions
sub special {
    my $instruction = shift;

    # Deal with each one in turn
    # hlt
    if ( $instruction == 0740040 ) {
        printf( STDERR "PC %06o: program halted\n", $PC );
        dump_memory( 0, MAXADDR, 0 ) if ($debug);
        exit(1);
    }
    if ( $instruction == 0741100 ) {    # spa: skip on positive AC
        dprintf( "spa AC %06o\n", $AC );

        # Because we are dealing with 18 bits, compare the range
        $PC += ( ( $AC >= 0 ) && ( $AC <= MAXPOSINT ) ) ? 2 : 1;
        return;
    }
    if ( $instruction == 0741200 ) {    # sna: skip on non-zero AC
        dprintf( "sna AC %06o\n", $AC );
        $PC += ( $AC != 0 ) ? 2 : 1;
        return;
    }
    if ( $instruction == 0740200 ) {    # sza: skip on zero AC
        dprintf( "sza AC %06o\n", $AC );
        $PC += ( $AC == 0 ) ? 2 : 1;
        return;
    }
    if ( $instruction == 0741400 ) {    # szl: Skip when $LINK is zero
        dprintf( "szl LINK %0o\n", $LINK );
        $PC += ( $LINK == 0 ) ? 2 : 1;
        return;
    }
    if ( $instruction == 0740400 ) {    # snl: Skip when $LINK not zero
        dprintf( "snl LINK %0o\n", $LINK );
        $PC += ( $LINK != 0 ) ? 2 : 1;
        return;
    }
    if ( $instruction == 0741000 ) {    # ska: skip always
        dprintf("skp\n");
        $PC += 2;
        return;
    }

    # ral: rotate left or rcr: clear link then rotate left
    if ( ( $instruction == 0740010 ) || ( $instruction == 0744010 ) ) {
        $LINK = 0 if ( $instruction == 0744010 );
        $AC   = $AC << 1 + ($LINK) ? 1 : 0;
        $LINK = $AC & LINKMASK;
        $AC   = $AC & MAXINT;
        $PC++;
        return;
    }

    # rar: rotate right or rcr: clear link then rotate right
    if ( ( $instruction == 0740020 ) || ( $instruction == 0744020 ) ) {
        $LINK = 0 if ( $instruction == 0744020 );
        my $newlink = ( $AC & 1 ) ? LINKMASK : 0;
        $AC   = ( $LINK | $AC ) >> 1;
        $LINK = $newlink;
        $PC++;
        return;
    }

    # law: load word into AC
    if ( ( $instruction >= 0760000 ) && ( $instruction <= MAXINT ) ) {
        dprintf( "law %06o into AC\n", $instruction );
        $AC = $instruction;
        $PC++;
        return;
    }
    printf( STDERR "PC %06o: unknown instruction %06o\n", $PC, $instruction );
    exit(1);
}

# cal: used for system calls
sub cal {
    my ( $instruction, $addr, $indaddr ) = @_;

    # Syscalls that we can simulate
    my %Syscallist = (
        3  => \&sys_open,
        4  => \&sys_read,
        5  => \&sys_write,
        9  => \&sys_close,
        14 => \&sys_exit,
    );

    # Simulate the syscall. Each syscall updates the $PC
    if ( defined( $Syscallist{$addr} ) ) {
        $Syscallist{$addr}->();
    } else {
        printf( STDERR "PC %06o: Unknown syscall %d\n", $PC, $addr );
        exit(1);
    }
}

# Extended arithmetic element instructions
sub eae {
    my ( $instruction, $addr, $indaddr ) = @_;
    my $step = $instruction & EAESTEP;

    if ( $instruction == 0660500 ) {    # lrss: long right shift, signed
        dprintf( "lrss %06o AC step %d\n", $AC, $step );

        # Save the AC's sign into LINK
        $LINK = ( $AC << 1 ) & LINKMASK;

        # XXX: Do we need to preserve the AC sign?
        $AC = $AC >> $step;
        $PC++;
        return;
    }
    if ( $instruction == 0660711 ) {    # alss: long left shift, signed
        dprintf( "alss %06o AC step %d\n", $AC, $step );

        # Save the AC's sign into LINK
        $LINK = ( $AC << 1 ) & LINKMASK;

        # XXX: Do we need to preserve the AC sign?
        $AC = ( $AC << $step ) & MAXINT;
        $PC++;
        return;
    }
    printf( STDERR "PC %06o: Unknown eae instruction %06o\n",
        $PC, $instruction );
    exit(1);
}

# Exit system call
sub sys_exit {
    dprintf("exit system call\n");
    exit(0);
}

# Close system call
sub sys_close {

    # AC is the file descriptor
    my $fd = $AC;
    dprintf( "close: closing fd %d\n", $fd );

    # Bump up the PC
    $PC += 1;

    # That filehandle is not open, set an error -1 in octal
    if ( !defined( $FD[$fd] ) ) {
        dprint("close: fd $fd is not open\n");
        $AC = MAXINT;
        return;
    }
    close( $FD[$fd] );
    $FD[$fd] = undef;
    $AC = 0;
    return;
}

# Open system call
sub sys_open {
    # Open seems to have 2 arguments: PC+1 is a pointer to the filename.
    # PC+2 seems to be 1 for write, 0 for read.
    # Some programs seem to have a third argument always set to 0.
    # AC is the opened fd on success, or -1 on error

    # Get the start address of the string
    my $start = $Mem[ $PC + 1 ];

    # Bump up the PC
    $PC += 3;

    # Convert this to a sensible ASCII filename
    my $filename = mem2arg($start);
    dprintf( "open: base %06o, file %s\n", $start, $filename );

    # Open the file
    if ( open( my $FH, "<", $filename ) ) {

       # Find a place in the @FD array to store this filehandle. 99 is arbitrary
        foreach my $fd ( 0 .. 99 ) {
            if ( !defined( $FD[$fd] ) ) {
                $FD[$fd] = $FH;
                $AC = $fd;
                last;
            }
        }
        return;
    } else {
        # No filehandle, so it's an error
        dprintf("open failed: $!\n");
        $AC = MAXINT;
        return;
    }
}

# Read system call
sub sys_read {

    # Read seems to have arguments: AC is the file descriptor, PC+1 is
    # the pointer to the buffer and PC+2 is the number of words to read.
    # Return the number of words read in AC on success, or -1 on error.

    # Get the file descriptor, start address and end address
    my $fd    = $AC;
    my $start = $Mem[ $PC + 1 ];
    my $count = $Mem[ $PC + 2 ];
    my $end   = ( $start + $count - 1 ) & MAXADDR;
    die("sys_read: bad start/end addresses $start $end\n") if ( $end < $start );
    dprintf( "read: %d words into %06o from fd %d\n", $count, $start, $fd );

    # Bump up the PC
    $PC += 3;

    # That filehandle is not open, set an error -1 in octal
    if ( !defined( $FD[$fd] ) ) {
        dprint("read: fd $fd is not open\n");
        $AC = MAXINT;
        return;
    }

    # Read each word in
    my $FH = $FD[$fd];
    $count = 0;
    foreach my $addr ( $start .. $end ) {

        # It's a terminal, so convert from ASCII
        if ( -t $FH ) {
            my $c1 = getc($FH);
            last if ( !defined($c1) );    # No character, leave the loop
            my $c2 = getc($FH) || "";     # No character, make it a NUL
            $Mem[$addr] =
              ( ord($c1) << 9 ) | ord($c2);    # Pack both into one word
            $count++;
        } else {
            # otherwise (for now) read in one line and convert to octal
            my $line = <$FH>;
            last if ( !defined($line) );       # No line, leave the loop
            chomp($line);
            $Mem[$addr] = oct($line) & MAXINT;
            $count++;
        }
    }

    # No error
    $AC = $count;
    return;
}

# Write system call
sub sys_write {

    # Write seems to have arguments: AC is the file descriptor, PC+1 is
    # the pointer to the buffer and PC+2 is the number of words to write

    # Get the file descriptor, start address and end address
    my $fd    = $AC;
    my $start = $Mem[ $PC + 1 ];
    my $count = $Mem[ $PC + 2 ];
    my $end   = ( $start + $count - 1 ) & MAXADDR;
    die("sys_write: bad start/end addresses $start $end\n")
      if ( $end < $start );
    dprintf( "write: %d words from %o to fd %d\n", $count, $start, $fd );

    # Bump up the PC
    $PC += 3;

    # That filehandle is not open, set an error -1 in octal
    if ( !defined( $FD[$fd] ) ) {
        dprint("write: fd $fd is not open\n");
        $AC = MAXINT;
        return;
    }

    # Write each word out
    my $FH = $FD[$fd];
    foreach my $addr ( $start .. $end ) {

        # It's a terminal, so convert to ASCII
        # otherwise (for now) print in octal
        if ( -t $FH ) {
            print( $FH word2ascii( $Mem[$addr] ) );
        } else {
            printf( $FH "%06o\n", $Mem[$addr] );
        }
    }

    # No error
    $AC = 0;
    return;
}

# Convert an 18-bit word into two ASCII characters and return them.
# Don't return NUL characters
sub word2ascii {
    my $word   = shift;
    my $c1     = ( $word >> 9 ) & 0177;
    my $c2     = $word & 0177;
    my $result = "";
    $result .= chr($c1) if ($c1);
    $result .= chr($c2) if ($c2);
    return ($result);
}

# Given the address of a four word argument string in
# memory, return a copy of the string in ASCII format.
# Lose any trailing spaces as well.
sub mem2arg {
    my $addr   = shift;
    my $result = "";

    foreach ( 1 .. 4 ) {

        # Stop if the address leave the 8K word address space
        last if ( $addr > MAXADDR );
        my $word = $Mem[ $addr++ ];
        my $c1   = ( $word >> 9 ) & 0177;
        my $c2   = $word & 0177;
        $result .= chr($c1) . chr($c2);
    }
    $result =~ s{ *$}{};
    return ($result);
}

# Given the address of a word in memory, interpret that location
# and those following as a NUL-terminated ASCII string and return
# a copy of this string
# XXX: not sure if I still need this.
sub mem2string {
    my $addr   = shift;
    my $result = "";

    while (1) {

        # Stop when the address leave the 8K word address space
        return ($result) if ( $addr > MAXADDR );

        # Stop when the value there is zero
        my $word = $Mem[$addr];
        return ($result) if ( $word == 0 );

        # Get the top ASCII character, return if NUL
        my $c1 = ( $word >> 9 ) & 0177;
        return ($result) if ( $c1 == 0 );
        $result .= chr($c1);

        # Get the bottom ASCII character, return if NUL
        my $c2 = $word & 0177;
        return ($result) if ( $c2 == 0 );
        $result .= chr($c2);

        # Move up to the next address
        $addr++;
    }
}

# Print out debug messages
sub dprintf {
    printf( STDERR @_ ) if ( ($debug) || ($singlestep) );
}

# Get one or more commands from the user and execute them
sub get_user_command {
    my %Cmdlist = (
        'b'        => \&cmd_setbreak,
        'break'    => \&cmd_setbreak,
        'd'        => \&cmd_dump,
        'dump'     => \&cmd_dump,
        'db'       => \&cmd_delbreak,
        'del'      => \&cmd_delbreak,
        'delete'   => \&cmd_delbreak,
        '?'        => \&cmd_help,
        'h'        => \&cmd_help,
        'help'     => \&cmd_help,
        's'        => \&cmd_step,
        'l'        => \&cmd_listbreak,
        'list'     => \&cmd_listbreak,
        'step'     => \&cmd_step,
        'q'        => \&cmd_exit,
        'x'        => \&cmd_exit,
        'quit'     => \&cmd_exit,
        'exit'     => \&cmd_exit,
        'c'        => \&cmd_continue,
        'continue' => \&cmd_continue,
        'r'        => \&cmd_showregs,
        'regs'     => \&cmd_showregs,
    );

    # Loop until we get a leave result
    while (1) {

        # Get a command from the user
        # and split into command, start and end addresses.
        # Convert addresses from octal
        print("a7out> ");
        chomp( my $line = <STDIN> );
        my ( $cmd, $addr, $endaddr ) = split( /\s+/, $line );
        $addr    = oct($addr)    if ( defined($addr) );
        $endaddr = oct($endaddr) if ( defined($endaddr) );

        # Run the command
        my $leave;
        if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) {
            $leave = $Cmdlist{$cmd}->( $addr, $endaddr );
        } else {
            printf( "%s: unknown command\n", $cmd || "" );
            cmd_help();
        }
        return if ($leave);
    }
}

# Exit the program
sub cmd_exit {
    exit(0);
}

# Continue by disabling single-step
# and break out of the command loop
sub cmd_continue {
    $singlestep = 0;
    return (1);
}

# Step by staying in single-step
# but break out of the command loop
sub cmd_step {
    return (1);
}

# Set a breakpoint
sub cmd_setbreak {
    my $addr = shift;
    $Breakpoint{$addr} = 1;
    return (0);
}

# Delete a breakpoint
sub cmd_delbreak {
    my $addr = shift;
    delete( $Breakpoint{$addr} );
    printf( "Delete breakpoint %06o\n", $addr );
    return (0);
}

sub cmd_help {
    print("  [b]reak <octal>             set a breakpoint\n");
    print("  [c]ontinue                  leave single-step and continue\n");
    print("  [d]ump [<octal>] [<octal>]  dump addresses in range\n");
    print("  db <octal>                  delete a breakpoint\n");
    print("  [del]ete <octal>            delete a breakpoint\n");
    print("  [l]ist                      list breakpoints\n");
    print("  [r]egs                      print PC, LINK, AC and MQ regs\n");
    print("  [s]tep                      single-step next instruction\n");
    print("  ?, h, help                  print this help list\n");
    print("  e[x]it, [q]uit              exit the program\n");
    return (0);
}

sub cmd_showregs {
    my $link = ($LINK) ? 1 : 0;
    printf( "PC: %06o, L.AC %d.%06o, MQ: %06o\n", $PC, $link, $AC, $MQ );
    return (0);
}

sub cmd_dump {
    my ( $start, $end ) = @_;

    # No arguments, so dump everything but not empty locations
    if ( !defined($start) ) {
        dump_memory( 0, MAXADDR, 0 );
        return (0);
    }

    # Dump a limited range
    $end = $start if ( !defined($end) );
    dump_memory( $start, $end, 1 );
    return (0);
}

sub cmd_listbreak {
    print("Breakpoints:\n");
    foreach my $addr ( sort( keys(%Breakpoint) ) ) {
        printf( "  %06o\n", $addr );
    }
    return (0);
}