clc

#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;

# A very rudimentary compiler for a
# high-ish level language down to the
# Crazy Small CPU assembly language.
# (c) 2017 Warren Toomey, GPL3.

my $OUT;

# List of operators and instructions
my %ALUop = (
    '+' => 'ADDM',
    '-' => 'SUBM',
    '&' => 'ANDM',
    '|' => 'ORM',
    '^' => 'XORM',
);

# Stack of instructions to emit at the end of each if or loop
# Each entry is a 3-element list: type, code and end loop label.
# End loop label is undef for if statements. First element
# is "LOOP", "IF", "FUNC".
my @Loopstack;

# Function variables: name of current function or undef
my $funcname;

# Name of function's parameters
my %Funcparam;

# Next available caller id for each function
my %Funccaller;

# Get a new caller id for the named function
sub getcallerid {
    my $name = shift;
    die("Unknown function $name\n") if ( !exists( $Funccaller{$name} ) );
    die("Too many $name callers\n") if ( $Funccaller{$name} == 15 );
    $Funccaller{$name}++;
    return ( $Funccaller{$name} );
}

# Get a new jump label
my $nextlabel = 0;

sub newlabel {
    return ( "L" . $nextlabel++ );
}

my $varlocn = 0;    # Next location to use for variables
my %Var;            # List of known variables

# Allocate space for a new variable. Prepend the current function name
sub addvar {
    my $var = shift;
    $var = $funcname . "." . $var;

    die("$var previously defined\n") if ( defined( $Var{$var} ) );
    printf( $OUT "%shi:\tEQU %d\n", $var, $varlocn++ );
    printf( $OUT "%slo:\tEQU %d\n", $var, $varlocn++ );
    $Var{$var} = 1;
}

# Check if a variable exists. Die if 2nd argument is true
# Return the full variable name or undef
sub checkvar {
    my ( $var, $stop ) = @_;
    $var = $funcname . "." . $var;

    if ( !defined( $Var{$var} ) ) {
        die("$var does not exist\n") if ($stop);
        return (undef);
    }
    return ($var);
}

# Given a number, convert to two 4-bit values and return then
sub num2nibbles {
    my $N = shift;
    die("$N oversized\n") if ( ( $N < -128 ) || ( $N > 127 ) );
    $N = 256 + $N if ( $N < 0 );
    my $top = ( $N >> 4 );
    my $bot = ( $N & 0xf );
    return ( $top, $bot );
}

# Emit an operation with two operands
sub emit_twoop_operation {
    my ( $lvar, $var1, $op, $var2, $jump ) = @_;
    my ($leftisconst, $rightisconst)= (0,0);
    my ($lefttop, $leftbot, $righttop, $rightbot);

    # Work out the high/low lvar names
    my ($lvarhi, $lvarlo)=('', '');
    if ($lvar ne '') {
      $lvar = checkvar( $lvar, 1 );
      $lvarhi= $lvar. 'hi';
      $lvarlo= $lvar. 'lo';
    }

    # Convert operands either to nibbles or
    # identify the variables involved
    if ($var1=~ m{^-?\d+$}) {
      ($lefttop, $leftbot ) = num2nibbles($var1);
      $leftisconst=1;
    } else {
      $var1 = checkvar( $var1, 1 );
    }
    if ($var2=~ m{^-?\d+$}) {
      ($righttop, $rightbot ) = num2nibbles($var2);
      $rightisconst=1;
    } else {
      $var2 = checkvar( $var2, 1 );
    }

    my $aluinstruction = $ALUop{$op};
    print($OUT "\t\t\t# $lvar = $var1 $op $var2\n");
    printf( $OUT "\tCLC\n" ) if ( ( $op eq "+" ) || ( $op eq "-" ) );
    if ($leftisconst) {
      printf( $OUT "\tLCA 0x%x\n", $leftbot);
    } else {
      printf( $OUT "\tLMA %slo\n", $var1 );
    }
    if ($rightisconst) {
      printf( $OUT "\tLCB 0x%x\n", $rightbot);
    } else {
      printf( $OUT "\tLMB %slo\n", $var2 );
    }
    printf( $OUT "\t$aluinstruction %s\n", $lvarlo );
    # Intermediate jump for == and !=
    printf( $OUT "\t$jump\n") if (defined($jump));
    if ($leftisconst) {
      printf( $OUT "\tLCA 0x%x\n", $lefttop);
    } else {
      printf( $OUT "\tLMA %shi\n", $var1 );
    }
    if ($rightisconst) {
      printf( $OUT "\tLCB 0x%x\n", $righttop);
    } else {
      printf( $OUT "\tLMB %shi\n", $var2 );
    }
    printf( $OUT "\t$aluinstruction %s\n", $lvarhi );
}

# Emit a less-than type comparison
sub emit_comparison {
    my ( $startlabel, $var1, $var2, $jump, $op, $jump2 ) = @_;
    printf( $OUT "$startlabel:\t\t\t# $var1 $op $var2\n" );
    emit_twoop_operation( '', $var1, '-', $var2, $jump2 );
    printf( $OUT "\t$jump\n" );
}

# Deal with the end of a function
sub end_function {
    my @retlist;

    # Build list of return jumps
    printf( $OUT "%sret:\tLMB %scaller\n", $funcname, $funcname );
    print( $OUT "\tTBF\n" );
    foreach my $i ( 0 .. 15 ) {
        push( @retlist, " JMP " . $funcname . "ret" . $i );
    }
    print( $OUT "\t" . join( " | ", @retlist ) . "\n" );
    $funcname = undef;
}

# Emit code for a function call
sub do_function_call {
    my ( $name, $argument, $lvar ) = @_;
    die("function $name not previously declared\n")
      if ( !exists( $Funccaller{$name} ) );
    print( $OUT "\t\t\t# Call $name\n" );

    # Get a new caller id
    my $id = getcallerid($name);

    # If there is an argument, copy it into the function
    if ( defined($argument) && ( $argument ne "" ) ) {
        die("function $name has no argument\n")
          if ( $Funcparam{$name} eq "" );
        $argument = checkvar( $argument, 1 );
        print( $OUT "\tLMA $argument" . "hi\n" );
        print( $OUT "\tSMA $Funcparam{$name}" . "hi\n" );
        print( $OUT "\tLMA $argument" . "lo\n" );
        print( $OUT "\tSMA $Funcparam{$name}" . "lo\n" );
    }

    # Print out the call and the return label
    print( $OUT "\tLCB $id\n" );
    print( $OUT "\tJMP $name\n" );
    print( $OUT "$name" . "ret$id:\n" );

    # If we have an lvar, copy from the param back to the lvar
    if ( defined($lvar) ) {
        print( $OUT "\tLMA $Funcparam{$name}" . "hi\n" );
        print( $OUT "\tSMA $lvar" . "hi\n" );
        print( $OUT "\tLMA $Funcparam{$name}" . "lo\n" );
        print( $OUT "\tSMA $lvar" . "lo\n" );
    }
}

#### MAIN PROGRAM ####
die("Usage: $0 file.cl\n") if ( @ARGV != 1 );
my $outfile = $ARGV[0];
$outfile =~ s{cl$}{s};
die("output file name same as input file $outfile\n")
  if ( $outfile eq $ARGV[0] );

open( $OUT,   ">", $outfile ) || die("Cannot write $outfile: $!\n");
open( my $IN, "<", $ARGV[0] ) || die("Cannot open $ARGV[0]: $!\n");
print( $OUT "\tJMP main\n" );    # Initial function call
while (<$IN>) {
    chomp;

    # Lose comments
    s{\s*//.*}{};

    # Skip empty lines;
    next if (m{^$});

    # Variable declaration
    if (m{var\s+(\S+)\s*;}) {
        my $var = $1;
        addvar($var);
        next;
    }

    # Two operand operation
    if (m{(\S+)\s*=\s*(\S+)\s*(\+|\-|\&|\||\^)\s*(\S+)\s*;}) {
        my ( $lvar, $var1, $op, $var2 ) = ( $1, $2, $3, $4 );
        emit_twoop_operation( $lvar, $var1, $op, $var2 );
        next;
    }

    # While loop/If statement
    if (m{(if|while)\s*\(\s*(\S+)\s+(\S+)\s+(\S+)\s*\)\s*\{}) {
        my ( $keyword, $var1, $op, $var2 ) = ( $1, $2, $3, $4 );

        # Get a start label and an end label
        my $startlabel = newlabel();
        my $endlabel   = newlabel();
        if ( $keyword eq "while" ) {
            push( @Loopstack,
                [ "LOOP", "\tJMP $startlabel\n$endlabel:\n", $endlabel ] );
        } else {
            push( @Loopstack, [ "IF", "$endlabel:\n", undef ] );
        }

        if ( $op eq "==" ) {
            emit_comparison( $startlabel, $var1, $var2, "JNE $endlabel",
		 $op, "JNE $endlabel" );
        }
        if ( $op eq "!=" ) {
            emit_comparison( $startlabel, $var1, $var2, "JEQ $endlabel",
		$op, "JEQ $endlabel" );
        }
        if ( $op eq "<" ) {
            emit_comparison( $startlabel, $var1, $var2, "JGE $endlabel", $op );
        }
        if ( $op eq ">=" ) {
            emit_comparison( $startlabel, $var1, $var2, "JLT $endlabel", $op );
        }
        if ( $op eq ">" ) {
            emit_comparison( $startlabel, $var2, $var1, "JGE $endlabel", $op );
        }
        if ( $op eq "<=" ) {
            emit_comparison( $startlabel, $var2, $var1, "JLT $endlabel", $op );
        }
        next;
    }

    # Else statement
    if (m{\}\s*else\s*\{}) {
        my $endlabel = newlabel();
        my $aryref   = pop(@Loopstack);
        die("Unbalanced else\n") if ( !defined($aryref) );
        my ( $type, $line, $orignendlabel ) = @{$aryref};
        die("else not after if\n") if ( $type ne "IF" );
        push( @Loopstack, [ "IF", "$endlabel:\n", undef ] );
        print( $OUT "\tJMP $endlabel\t\t# Just before else\n" );
        print( $OUT $line );
        next;
    }

    # while (1) statement
    if (m{while\s*\(\s*1\s*\)\s*\{}) {

        # Get a start label and an end label
        my $startlabel = newlabel();
        my $endlabel   = newlabel();
        push( @Loopstack,
            [ "LOOP", "\tJMP $startlabel\n$endlabel:\n", $endlabel ] );
        printf( $OUT "$startlabel:\t\t\t# while (1)\n" );
        next;
    }

    # End of an if, loop or function
    if (m{\}}) {
        my $aryref = pop(@Loopstack);
        die("Unbalanced }\n") if ( !defined($aryref) );
        my ( $type, $line, $orignendlabel ) = @{$aryref};
        die("Unbalanced }\n") if ( !defined($type) );

        if ( $type eq "FUNC" ) {
            end_function();
            next;
        }

        # Otherwise an if or loop end
        print( $OUT $line );
        next;
    }

    # putchar
    if (m{putchar\((.+)\);}) {
        my $origarg = $1;
        my $arg = checkvar( $origarg, 0 );
        if ( defined($arg) ) {
            printf( $OUT "\tLMA %shi\t\t# putchar $arg\n", $arg );
            printf( $OUT "\tLMB %slo\n",                   $arg );
            printf( $OUT "\tDAB\n" );
        } else {
	    $arg= undef;
            $arg = 10      if ( $origarg eq "'\\n'" );
            $arg = ord($1) if ( $origarg =~ m{'(.)'} );
	    die("Unrecognised putchar argument $origarg\n")
			   if (!defined($arg));
            my ( $top, $bot ) = num2nibbles($arg);
            print( $OUT "\tLCA $top\t\t# putchar $arg\n" );
            print( $OUT "\tLCB $bot\n" );
            print( $OUT "\tDAB\n" );
        }
        next;
    }

    # prhex(n)
    if (m{prhex(n?)\((.+)\);}) {
      my ($n, $arg)= ($1, $2);
      $arg = checkvar( $arg, 1 );
      printf( $OUT "\tLMB %shi\t\t# prhex$n $arg\n", $arg);
      printf( $OUT "\tTBF\n");
      printf( $OUT "\tLCA 3 | NzVc LCA 4 | NzVC LCA 4 | NZvc LCA 4 | " .
		"NZvC LCA 4 | NZVc LCA 4 | NZVC LCA 4\n");
      printf( $OUT "\tNOP | NzVc LCB 1 | NzVC LCB 2 | NZvc LCB 3 | " .
		"NZvC LCB 4 | NZVc LCB 5 | NZVC LCB 6\n");
      printf( $OUT "\tDMAB %slo\n", $arg);
      printf( $OUT "\tTBF\n");
      printf( $OUT "\tLCA 3 | NzVc LCA 4 | NzVC LCA 4 | NZvc LCA 4 | " .
		"NZvC LCA 4 | NZVc LCA 4 | NZVC LCA 4\n");
      printf( $OUT "\tNOP | NzVc LCB 1 | NzVC LCB 2 | NZvc LCB 3 | " .
		"NZvC LCB 4 | NZVc LCB 5 | NZVC LCB 6\n");
      printf( $OUT "\tDAB 0\n");
      if ($n eq 'n') {
        printf( $OUT "\tLCB 0xA\n");
        printf( $OUT "\tDAB\n");
      }
      next;
    }

    # Postincrement
    if (m{(\S+)\+\+;}) {
        my $var1 = $1;
        $var1 = checkvar( $var1, 1 );
        printf( $OUT "\tLMA %slo\t\t# $var1 ++\n", $var1 );
        printf( $OUT "\tSMIA %slo\n",              $var1 );
        printf( $OUT "\tNOP | C LMA %shi\n",    $var1 );
        printf( $OUT "\tNOP | C SMIA %shi\n",   $var1 );
        next;
    }

    # Arithmetic shift right by four
    if (m{(\S+)\s*=\s*(\S+)\s*>>\s*4;}) {
        my ( $lvar, $var1 ) = ( $1, $2 );
        $lvar = checkvar( $lvar, 1 );
        $var1 = checkvar( $var1, 1 );
        printf( $OUT "\tLMA %shi\t\t# $lvar = $var1 >> 4\n", $var1 );
        printf( $OUT "\tSMA %slo\n",                         $lvar );
        printf( $OUT "\tLCA 0 | N LCA 0xf\n" );
        printf( $OUT "\tSMA %shi\n", $lvar );
        next;
    }

    # break
    if (m{break;}) {

        # Get the length of the @Loopstack -1, to get highest index
        my $i     = @Loopstack - 1;
        my $found = 0;
        while ( $i >= 0 ) {
            my $aryref = $Loopstack[ $i-- ];
            die("No matching loop end for break\n") if ( !defined($aryref) );
            my ( $type, $line, $orignendlabel ) = @{$aryref};
            if ( $type eq "LOOP" ) {
                printf( $OUT "\tJMP %s\t\t# break\n", $orignendlabel );
                $found = 1;
                last;
            }
        }
        die("No matching loop end for break\n") if ( !$found );
        next;
    }

    # Exit: inifinite loop
    if (m{exit;}) {
        print( $OUT "end:\tJMP end\n" );
        next;
    }

    # Function declaration: function name (param) {
    if (m{function\s+(\S+)\s*\((\S*)\)\s*\{}) {
        my $name  = $1;
        my $param = $2;
        die("Can't declare function $name inside $funcname\n")
          if ( defined($funcname) );
        die("function $name previously declared\n")
          if ( exists( $Funcparam{$name} ) );
        $funcname = $name;
        $Funccaller{$name} = -1;    # No callers yet
        print( $OUT "\n$name:\n" );
        printf( $OUT "%scaller:\tEQU %d\n", $name, $varlocn++ );
        if ( defined($param) && ( $param ne "" ) ) {
          addvar($param);
          $param = checkvar( $param, 1 );
          $Funcparam{$name} = $param;
	}
        printf( $OUT "\tSMB %scaller\n", $name );
        push( @Loopstack, ["FUNC"] );
        next;
    }

    # Return with return value. Use the param as return location
    if (m{return\((\S+)\);}) {
        my $retvar = $1;
        $retvar = checkvar( $retvar, 1 );
        printf( $OUT "\tLMA %shi\t\t# Return $retvar\n", $retvar );
        printf( $OUT "\tSMA %shi\n",  $Funcparam{$funcname} );
        printf( $OUT "\tLMA %slo\n",  $retvar );
        printf( $OUT "\tSMA %slo\n",  $Funcparam{$funcname} );
        printf( $OUT "\tJMP %sret\n", $funcname );
        next;
    }

    # Function call with optional argument and assignment
    if (m{(\S+)=\s*(\S+)\s*\((\S*)\)\s*;}) {
        my $name     = $2;
        my $argument = $3;
        my $lvar     = $1;
        $lvar = checkvar( $lvar, 1 );
        do_function_call( $name, $argument, $lvar );
        next;
    }

    # Function call with optional argument and no assignment
    if (m{(\S+)\s*\((\S*)\)\s*;}) {
        my $name     = $1;
        my $argument = $2;
        do_function_call( $name, $argument );
        next;
    }

    # Constant assignment
    if (m{(\S+)\s*=\s*(\S+)\s*;}) {
        my ( $var, $val ) = ( $1, $2 );
        $var = checkvar( $var, 1 );

	# If the value is a constant
        print( $OUT "\t\t\t# $var = $val\n" );
        if ($val=~ m{^-?\d+$}) {
          my ( $top, $bot ) = num2nibbles($val);
          if ($top) {
            printf( $OUT "\tLCA 0x%x\n", $top );
            printf( $OUT "\tSMA %shi\n", $var );
          } else {
            printf( $OUT "\tZEROM %shi\n", $var );
          }
          if ($bot) {
            printf( $OUT "\tLCA 0x%x\n", $bot );
            printf( $OUT "\tSMA %slo\n", $var );
          } else {
            printf( $OUT "\tZEROM %slo\n", $var );
          }
        } else {
	  # See if the val is a variable
	  my $rhsvar= checkvar( $val, 1);
          printf( $OUT "\tLMA %shi\n", $rhsvar );
          printf( $OUT "\tSMA %shi\n", $var );
          printf( $OUT "\tLMA %slo\n", $rhsvar );
          printf( $OUT "\tSMA %slo\n", $var );
	}
	next;
    }

    # Return and no return value
    if (m{return;}) {
        printf( $OUT "\tJMP %sret\n", $funcname );
        next;
    }

    die("Unrecognised line: $_\n");
}

# Print out dummy labels for the unused function caller ids
print( $OUT "\n# Dummy labels for unused function caller ids\n" );
foreach my $n ( keys(%Funccaller) ) {
    my $start = $Funccaller{$n} + 1;
    foreach my $i ( $start .. 15 ) {
        print( $OUT "$n" . "ret$i:\n" );
    }
}

die("No main function defined\n") if ( !exists( $Funccaller{"main"} ) );
close($IN);
close($OUT);
exit(0);