#!/usr/bin/perl
#
# Read in files of PDP-7 assembly code in Ken Thompon's as format
# and convert them into PDP-7 machine code
#
# (c) 2016 Warren Toomey, GPL3
# Tweaked by Phil Budne (line, expression parsing, "list" format)
#
use strict;
use warnings;
use Data::Dumper;
use Getopt::Long qw(GetOptions);

Getopt::Long::Configure qw(gnu_getopt);

### Global variables ###
my %Var;       # Variables such as ., .., t
my %Label;     # Labels that are defined once
my %Rlabel;    # Relative labels, e.g. 1:, 2:
               # with an array of locations for each label

my @Mem;       # Actual PDP-7 memory locations
my @Mline;     # Source lines associated with mem locations
my $origline;  # The original current input line of code
my $line;      # line being parsed
my $stage = 1; # Pass one or pass two
my $errors = 0; # set to non-zero on error
my $line_error = ' ';
my $file;	# current file name
my $lineno;	# current line number

## command line options
my $debug = 0;		# Run in debug mode
my $symbols = 0;	# dump symbols
my $format = 'a7out';	# output format

# keep this near the GetOptions call to make it easy to add documentation!
sub usage {
    die("Usage: $0 [--debug] [--format=a7out|list ] file1.s [file2.s ...]\n")
}

### Main program ###

GetOptions(
    'debug|d' => \$debug,
    'format|f=s' => \$format,
) or usage();

usage() if ( @ARGV < 1 );

# predefine syscall and opcodes as variables
# start with the location counter at zero
%Var = (
    '.'    => 0,
    save   => 1,		# saves core dump & user area!
    getuid => 2,
    open   => 3,
    read   => 4,
    write  => 5,
    creat  => 6,
    seek   => 7,
    tell   => 8,
    close  => 9,
    link   => 10,
    unlink => 11,
    setuid => 12,
    rename => 13,
    exit   => 14,
    time   => 15,
    intrp  => 16,
    chdir  => 17,
    chmod  => 18,
    chown  => 19,
    # 20 removed
    sysloc => 21,		# return system addresses
    # 22 removed
    capt   => 23,		# capture display?
    rele   => 24,		# release display?
    status => 25,		# "stat"
    smes   => 27,
    rmes   => 28,
    fork   => 29,

    # List of instruction names and machine code values
    # These come from https://raw.githubusercontent.com/simh/
    #   simtools/master/crossassemblers/macro7/macro7.c
    # PLB: replace with symbols in "sop.s"?
    sys    => 0000000,		# cal instruction (trap thru 020)
    i      => 0020000,		# indirect bit

    # memory reference instructions
    dac    => 0040000,		# deposit AC
    jms    => 0100000,		# jump to subroutine
    dzm    => 0140000,		# deposit zero in memory
    lac    => 0200000,		# load AC
    xor    => 0240000,		# exclusive or
    add    => 0300000,		# one's complement add
    tad    => 0340000,		# two's complement add
    xct    => 0400000,		# execute
    isz    => 0440000,		# increment and skip if zero
    and    => 0500000,		# AND with contents of Y
    sad    => 0540000,		# skip if AC different from content of Y
    jmp    => 0600000,		# jump to Y

    # Type 177 Extended Arithmetic Element (EAE)
    eae    => 0640000,		# base instruction (nop)
    osc    => 0640001,		# OR SC into AC
    omq    => 0640002,		# OR MQ into AC
    cmq    => 0640004,		# Complement MQ
    div    => 0640323,		# divide
    norm   => 0640444,		# normalize, unsigned
    lls    => 0640600,		# long left shift
    als    => 0640700,		# AC shift
    lrs    => 0640500,		# long right shift
    lacs   => 0641001,		# load AC with SC
    lacq   => 0641002,		# load AC with MQ
    abs    => 0644000,		# absolute value
    divs   => 0644323,		# divide, signed

    clq    => 0650000,		# clear MQ
    frdiv  => 0650323,		# fractional divide
    lmq    => 0652000,		# load MQ from AC
    mul    => 0653122,		# multiply
    idiv   => 0653323,		# integer divide
    idivs  => 0657323,		# integer divide, signed
    frdivs => 0654323,		# fractional divide, signed
    muls   => 0657122,		# multiply, signed

    norms  => 0660444,		# normalize, signed
    gsm    => 0664000,		# get sign and magnitude
    lrss   => 0660500,		# long right shift, signed
    llss   => 0660600,		# long left shift, signed
    alss   => 0660700,		# AC left shift, signed

    # I/OT instructions
    iot    => 0700000,		# base i/o transfer instruction
    clsf   => 0700001,		# skip if RT clock overflow
    iof    => 0700002,		# interrupts off (disable PIC)
    ion    => 0700042,		# interrupts on (enable PIC)
    iton   => 0700062,		# interrupt and trap on
    clof   => 0700004,		# clear clock flag, disable clock
    clon   => 0700044,		# clear clock flag, enable clock

    rsf    => 0700101,		# skip if PTR flag set
    rrb    => 0700112,		# clear PTR flag, OR buffer with AC
    rcf    => 0700102,		# clear PTR flag
    rsa    => 0700104,		# select PTR in alphanumeric mode
    rsb    => 0700144,		# select PTR in binary mode

    psf    => 0700201,		# skip if PTP flag set
    pcf    => 0700202,		# clear PTP flag
    psa    => 0700204,		# punch PTP in alphanumeric mode
    psb    => 0700244,		# punch PTP in binary mode

    ksf    => 0700301,		# skip if KBD flag set
    krb    => 0700312,		# read KBD buffer
    iors   => 0700314,		# input/output read status

    tsf    => 0700401,		# skip if if TTY output flag set
    tcf    => 0700402,		# clear TTY output flag
    tls    => 0700406,		# load TTY output buffer and select

    tts    => 0703301,		# Test Teleprinter and Skip
    skp7   => 0703341,		# skip if processor is PDP-7!
    caf    => 0703302,		# Clear All Flags

    crsf   => 0706701,		# skip if CDR is ready
    crrb   => 0706712,		# read CDR buffer
    crsa   => 0706704,		# select CDR alphanumeric mode
    crsb   => 0706744,		# select CDR binary mode

    # Operate Instructions

    # Group 1 (OPR 1) instructions
    opr    => 0740000,		# base operate instruction (nop)
    nop    => 0740000,
    cma    => 0740001,		# complement accumulator
    cml    => 0740002,		# complement link
    oas    => 0740004,		# inclusive or accumulator switches
    ral    => 0740010,		# rotate (ac, link) left
    rar    => 0740020,		# rotate (ac, link) right
    hlt    => 0740040,		# HALT
    xx     => 0740040,
    sma    => 0740100,		# skip on minus accumulator
    sza    => 0740200,		# skip on zero accumulator
    snl    => 0740400,		# skip on non-zero link

    skp    => 0741000,		# unconditional skip
    spa    => 0741100,		# skip on positive accumulator
    sna    => 0741200,		# skip on negative accumulator
    szl    => 0741400,		# skip on zero link

    rtl    => 0742010,		# rotate two left (ral*2)
    rtr    => 0742020,		# rotate two right (rar*2)

    cll    => 0744000,		# clear link
    stl    => 0744002,		# set link
    rcl    => 0744010,		# clear link, rotate left
    rcr    => 0744020,		# clear link, rotate right

    cla    => 0750000,		# clear accumulator
    clc    => 0750001,		# clear and complement acc
    las    => 0750004,		# load acc from switches
    glk    => 0750010,		# get link

    # Group 2 operate
    law    => 0760000,		# load accumulator with (instruction)
    lam    => 0777777,		# (load accumulator minus)
);

# Parse all the files
foreach my $file (@ARGV) {
    parse_file($file);
}

# Now do it all again, pass two
$Var{'.'} = 0;
$stage = 2;
print("PASS 2\n") if ($debug);
foreach my $file (@ARGV) {
    parse_file($file);
}

if ($format eq 'a7out') {
    # print out the contents of memory
    for my $i ( 0 .. $#Mem ) {
	if ( defined( $Mem[$i] ) ) {
	    printf( "%06o: %06o\t%s\n", $i, $Mem[$i], $Mline[$i] || "" );
	}
    }
}
elsif ($format eq 'list') {
    print "\n";
    print "Labels:\n";
    foreach my $key (sort keys %Label) {
	printf("%-8.8s %#06o\n", $key, $Label{$key});
    }
}
else {
    die("unknown format $format");
}
exit($errors);

# report an assmebly error:
# sets error flag
# reports filename:lineno for emacs m-x compile
sub err {
    $line_error = shift;
    my $msg = shift;

    $errors = 1;		# exit status
    if ($stage == 2) {
	print STDERR "$file:$lineno: $msg\n";
	print "$file:$lineno: $msg\n" if (! -t STDOUT);
    }
    return 0;			# expression value
}

# Open and parse the given file
sub parse_file {
    $file = shift;
    open( my $IN, "<", $file ) || die("Cannot read $file: $!\n");
    $lineno = 0;
    while ( $line = <$IN> ) {
	$lineno++;
        chomp($line);		# Lose the end of line
        $origline = $line;
	print "\t\t$line\n" if ($stage == 2 && $line ne '' && $format eq 'list');
	parse_line();
    }
    close($IN);
}

# process a label and set its value to the location counter
# only called on pass 1;
# if called on pass 2, should check if values are identical
sub process_label {
    my $label = shift;

    # It's a relative label, save its current value in a list
    if ( $label =~ m{^\d+$} ) {
        push( @{ $Rlabel{$label} }, $Var{'.'} );
        printf( "Pushing %#o for relative label %s\n", $Var{'.'}, $label ) if ($debug);
        return;
    }

    # It's a textual label, check if it's been defined before
    if ( defined( $Label{$label} ) ) {
	err('M', "Label $label defined multiple times\n");
    }
    # Otherwise, save its value
    $Label{$label} = $Var{'.'};
    printf( "Set label %s to %#o\n", $label, $Label{$label} ) if ($debug);
}

# Blame Phil for this....
# parses global $line based on prefixes, nibbling of a bit at a time
# (: and ; can appear in char literals)
# handles multiple ';' separated words per line
sub parse_line {
    # Lose any leading whitespace
    $line =~ s{^\s*}{};

    while (1) {
	$line_error = ' ';	# clear listing error indicator

	return if ($line eq '' || $line =~ m{^"}); # empty or comment: quit

	print "parse_line: '$line'\n" if ($debug);

	while ($line =~ s{^([a-z0-9\.]+):\s*}{}) { # labels
	    my $label = $1;

            # First pass: parse the labels
	    # (could check for same value on pass 2)
            if ( $stage == 1 ) {
		process_label($1);
	    }
	}

	if ( $line =~ s{^(\S+)\s*=}{}) { # assignment
	    my $lhs = $1;
	    my $word = parse_expression();
	    printf( "Setting variable %s to 0%o\n", $lhs, $word ) if ($debug);
	    $Var{$lhs} = $word;
	    printf("\t%06o %s\n", $word, $line_error) if ($stage == 2 && $format eq 'list');
	}
	else {	# bare expression
	    # Get its value on pass two and save to memory
	    # Also save the input line that altered memory
	    my $word = parse_expression();
	    if ( $stage == 2 ) {
		my $location  = $Var{'.'};
		$Mem[$location]   = $word;
		$Mline[$location] = $origline;
		$origline = '';
		if ($format eq 'list') {
		    printf( "%06o: %06o %s\n", $location, $word, $line_error);
		}
	    }
	    # Move up to the next location in both passes
	    $Var{'.'}++;
	} # expr

	# eat trailing whitespace and ";", if any
	$line =~ s{^\s*;?}{};
    } # while
}

# Blame Phil for this bit too...
# Parse an expression off $line and return a PDP-7 word
# as a series of whitespace separated "syllables"
# ORed, added, or subtracted
sub parse_expression {
    my $word = 0;

    print "expression: '$line'\n" if ($debug);

    while (1) {
	my $syllable = 0;
	my $op = '|';

	$line =~ s{^\s+}{};

	if ($line eq '' || $line =~ m{^[";]}) { # EOL ; and " terminate expr
	    printf("\tparse_expression => %#o\n", $word) if ($debug);
	    return $word;
	}

	print "    '$line'\n" if ($debug);

	if ($line =~ s{^-}{}) {
	    $op = '-';
	}
        elsif ($line =~ s{^\+}{}) {
	    $op = '+';
	}

	if ($line =~ s{^<(.)}{}) { # <char
	    $syllable = ord($1) << 9;
	}
	elsif ($line =~ s{^(.)>}{}) { # char>
	    $syllable = ord($1)
	}
	elsif ($line =~ s{^>(.)}{}) { # >char !!
	    $syllable = ord($1)
	}
	elsif ($line =~ s{^([a-z\.][a-z0-9\.]*)}{}) {
	    my $sym = $1;
	    print "\tsym: $sym\n" if ($debug);
	    if (defined($Var{$sym})) {
		$syllable = $Var{$sym};
		printf("\tvar: %s: %#o\n", $sym, $syllable) if ($debug);
	    }
	    elsif (defined($Label{$sym})) {
		$syllable = $Label{$sym};
		printf("\tlbl: %s: %#o\n", $sym, $syllable) if ($debug);
	    }
	    elsif ($stage == 2) {
		err('U', "$sym not defined")
	    } # pass 2
	} # symbol
	elsif ( $line =~ s{^(\d+)([fb])}{} ) { # relative label
	    $syllable = find_relative_label( $1, $2 ) if ($stage == 2);
	}
	elsif ( $line =~ s{^(\d+)}{} )  {
	    my $value = $1;
	    if ( $value =~ m{^0} ) {
		$syllable = oct($value);
	    }
	    else {
		$syllable = $value + 0;
	    }
	    $syllable &= 0777777;
	}
	else {
	    # From the BSD fortune file:
	    # Ken Thompson has an automobile which he helped design.
	    # Unlike most automobiles, it has neither speedometer,
	    # nor gas gauge, nor any of the numerous idiot lights
	    # which plague the modern driver. Rather, if the driver
	    # makes any mistake, a giant "?" lights up in the center
	    # of the dashboard. "The experienced driver",
	    # he says, "will usually know what's wrong.
	    err('?', "huh? '$line'");
	    $line = '';		# abort processing
	    return $word;
	}
	if ($op eq '+') {
	    $word += $syllable;
	}
	elsif ($op eq '-') {
	    $word -= $syllable;
	}
	else {
	    $word |= $syllable;
	}
	$word &= 0777777;
	printf("\tsyllable: %#o word: %#o\n", $syllable, $word) if ($debug);
    }
}

# Given a relative label number and a direction,
# return the location of this relative label or
# die if we don't have one
sub find_relative_label {
    my ( $label, $direction ) = @_;
    my $curlocation = $Var{'.'};

    # Error check: no labels at all
    if ( !defined( $Rlabel{$label} ) ) {
	return err('U', "relative label $label not defined\n");
    }

    # Get the list of possible locations for this label
    my $locarray = $Rlabel{$label};

    # Error check: no locations
    return err('U', "No relative labels") if ( @{$locarray} == 0 );

    if ( $direction eq 'f' ) {
	# Search forward for first location larger then the current one
        foreach my $reflocation ( @{$locarray} ) {
	    printf("forward %#o %#o\n", $reflocation, $curlocation) if ($debug);
            return ($reflocation) if ( $reflocation > $curlocation );
        }
    }
    else {
        # Search backwards for first location smaller than the current one
        foreach my $reflocation ( sort( { $b <=> $b } @{$locarray} ) ) {
	    printf("backward %#o %#o\n", $reflocation, $curlocation) if ($debug);
            return ($reflocation) if ( $reflocation < $curlocation );
        }
    }
    return err('U', "No relative label $label");
}