h.eyp

# h.eyp: Compiler for Warren's simple H language.
# Char and int are the same. No structs, unions.
#
# (c) Warren Toomey, 2016. GPL3 license.
#
%token IDENTIFIER CONSTANT STRINGLITERAL
%token INC_OP DEC_OP LEFT_OP RIGHT_OP LE_OP GE_OP EQ_OP NE_OP AND_OP OR_OP
%token CHAR INT VOID RECURSIVE
%token IF ELSE WHILE DO GOTO CONTINUE BREAK RETURN 
%left WEAK 
%right ELSE 
%start translation_unit 

%{
use Data::Dumper;
### GLOBALS ###
my ( $IN, $OUT );    	# Filehandles for input & output files
my $Basename;        	# Basename of both files
my @TokenQueue;      	# Stack of tokens not yet read
my $Incomment;       	# Are we in a multi-line comment?
my $Linenumber;      	# What line number we are on
my $Optimise=1;		# Are optimisations turned on?
my @Constlist;       	# List of constants in array initialisation
my %Global;          	# List of known global identifiers
my @GlobaLine;		# Output lines for the globals
my $Isvoid=0;		# Set if we see the keyword 'void'
my $Isrecursive=0;	# Set if we see the keyword 'recursive'
my %Functype;		# Hash of void and recursive types per function
my %Local;           	# List of known per-function identifiers
		     	# ->{fnname}->{id}
my %PPosn= (	     	# The parameter names and position for each function
 'putchar' => [ 'c' ],
 'printn'  => [ 'n' ],
 'open'    => [ 'buf', 'how' ],
 'read'    => [ 'fd', 'buf', 'cnt' ],
 'write'   => [ 'fd', 'buf', 'cnt' ],
 'close'   => [ 'fd' ],
 'creat'   => [ 'buf' ],
 'seek'    => [ 'fd', 'offset', 'how' ],
 'link'    => [ 'dir', 'src', 'dst' ],
 'unlink'  => [ 'buf' ],
 'setuid'  => [ 'uid' ],
 'rename'  => [ 'old', 'new' ],
 'chdir'   => [ 'dir' ],
 'chmod'   => [ 'file', 'mode' ],
 'chown'   => [ 'file', 'uid' ],
);

my $Last_functionid="";	# Name of the last function that was created
my $Calledfn="";	# Name of function being called, needed for arguments
my %Const;		# List of numeric constants used
my @FinalLine;       	# Array of references to arrays which contain all
		     	# the generated assembly code lines
my @Forstack;	     	# Stack of line arrayrefs of third expressions in FOR
			# List of temp locations. We shift to get one,
			# unshift to return it

my @Templocn;		# List of available temporary locations
my $Tempnum= 20;	# Number of available temporary locations

my $Line=[ ];		# List of assembly code lines we have generated
		     	# but which have not yet been added to the final
		     	# set of lines in @FinalLine

my %Keyword= (		# List of keywords in the grammar
  'break'    => 'BREAK',
  'char'     => 'CHAR',
  'continue' => 'CONTINUE',
  'do'       => 'DO',
  'else'     => 'ELSE',
  'for'      => 'FOR',
  'goto'     => 'GOTO',
  'if' 	     => 'IF',
  'int'      => 'INT',
  'return'   => 'RETURN',
  'recursive'=> 'RECURSIVE',
  'void'     => 'VOID',
  'while'    => 'WHILE',
);

my %Function=(       	# List of known function identifiers
    'printn'  => 'proto',
    'getchar' => 'proto',
    'putchar' => 'proto',
    '.exit'   => 'proto',
    '.open'   => 'proto',
    '.read'   => 'proto',
    '.write'  => 'proto',
    '.close'  => 'proto',
    '.getuid' => 'proto',
    '.creat'  => 'proto',
    '.seek'   => 'proto',
    '.link'   => 'proto',
    '.unlink' => 'proto',
    '.setuid' => 'proto',
    '.rename' => 'proto',
    '.time'   => 'proto',
    '.chdir'  => 'proto',
    '.chmod'  => 'proto',
    '.chown'  => 'proto',
    '.fork'   => 'proto',
);

my %Syscall= (		# List of known system calls to translate
  'exit'   => '.exit',	# The three built-in functions putchar,
  'open'   => '.open',	# getchar and printn are included here so that
  'read'   => '.read',  # we don't save/load locals on the stack when
  'write'  => '.write', # we call them
  'close'  => '.close',
  'getuid' => '.getuid',
  'creat'  => '.creat',
  'seek'   => '.seek',
  'link'   => '.link',
  'unlink' => '.unlink',
  'setuid' => '.setuid',
  'rename' => '.rename',
  'time'   => '.time',
  'chdir'  => '.chdir',
  'chown'  => '.chown',
  'chmod'  => '.chmod',
  'fork'   => '.fork',
  'printn'  => 'printn',
  'getchar' => 'getchar',
  'putchar' => 'putchar',
);

# Simple method to print error and die
sub Die
{
  my $err= shift;
  print(STDERR "$err on $Basename.h line $Linenumber\n");
  exit(1);
}


# Declare a new global identifier id. If there is a
# value, print the label and the value.
sub new_globalid
{
  my ($id, $type, $val)= @_;
  Die("$id global already declared") if (defined($Global{$id}));
  Die("Cannot declare $id as type void") if ($Isvoid);
  Die("Cannot declare $id as type recursive") if ($Isrecursive);
  $Global{$id}=$type;
  return if (!defined($val));

  push(@GlobaLine, "$id:");
  push(@GlobaLine, "   $val");

}

my $Nextpnum;			# The position of the next parameter

# Declare a new local identifier for the current function
# If how is 1, we will allocate storage for it.
# If how is 0, we don't as it is an array.
# Parameters to a function are treated as locals.
sub new_localid
{
  my ($fn,$id, $how)= @_;
  Die("Cannot declare $id as type void") if ($Isvoid);
  Die("Cannot declare $id as type recursive") if ($Isrecursive);

  # If we already have a definition for this local,
  # ignore it if this is from a prototype
  if (defined($Local{$fn}{$id})) {
    if ($Function{$fn} eq 'proto') {
      # However, check that it's in the same position
      Die("$fn: $id not in same position as prototype")
	if ($PPosn{$fn}[$Nextpnum] ne $id);
      $Nextpnum++; return;
    }

    Die("$fn: $id local already declared");
  }

  # This was not defined beforehand.
  # Define the local and store its position
  $Local{$fn}{$id}=$how;
  $PPosn{$fn}[$Nextpnum++]= $id;
}

# Declare and create a new array. If $Last_functionid has a
# value, then this is a local array, so we need to decorate its
# name with the function's name. Otherwise, it is a global array.
# Return the id
sub new_array
{
  my ($id, $valref)= @_;

  # Make this a local variable if $Last_functionid has a value
  if ($Last_functionid) {
     new_localid($Last_functionid, $id,0);
     $id= "$Last_functionid.$id";
  } else {
     new_globalid($id, 'array');
  }

  # Strings are dealt with elsewhere
  return ($id) if (!defined($valref));

  # Create a pointer to the array base
  push(@GlobaLine, "$id: $id.base");
  push(@GlobaLine, "$id.base:");

  # Output the contents of the array
  foreach my $val (@$valref) {
    push(@GlobaLine, "   $val");
  }
  return($id);
}

# Given an identifier arrayref, see if this is a local or
# a global. Return a local identifier ref or the original.
# Return a string with identifier and any 'i'
# 
# Expression identifiers are represented as an arrayref with two or
# three elements: the identifier, 'i' if it needs an
# indirect reference, and an optional third value which
# is the array offset expression (i.e. also an arrayref).
# The second element is 'array' if there is an offset.
sub getid
{
  my ($idref, $how)= @_;
  Die("undefined id in getid from $how") if (!defined($idref));
  my ($id, $ind, $offset)= @$idref;

  # Free up a temporary location
  if ($id=~ m{^.temp\d$}) {
    unshift(@Templocn, $id);
  }

  # Add the function name if this is a local identifier
  $id= "$Last_functionid.$id"
		if (defined($Local{$Last_functionid}{$id}));

  # Arrays are hard because we have to create a pointer to
  # the element, and then we can return the pointer.
  if ($ind eq 'array') {
    my ($offid, $offind) = @$offset;

    # If this isn't a lac, save the current AC
    my $temp= tempdac() if ($how ne 'lac');

    Die("can't index an array more than once") if ($offind eq 'array');
    $offset= getid($offset);	# Get the real offset name

    # Get the pointer to the array element into .ptr
    # and then get back the saved AC. .ptr is now
    # pointing at the array element
    push(@$Line, ['lac', $id]);
    push(@$Line, ['tad', "$offset"]);
    push(@$Line, ['dac', '.ptr']);
    lac($temp) if ($how ne 'lac');
    $id='.ptr'; $ind=' i';
  }
  return("$id$ind");
}


#### LABEL CODE
my @loopstack;	# Stack of labels for each loop
my @ifstack;	# Stack of labels for each selection statement
my $lifref;	# Points to either the loopstack or the ifstack

# Return a new label
my $label=0;
sub new_label
{
  $label++;
  return("LL$label");
}

#### FUNCTION CODE
# Declare a new function. The definition is always "proto" when we are
# called, and stays that way after a function prototype. It changes to
# "real" when the function is really defined.
sub new_functionid
{
  my ($id, $definition)= @_;
  Die("$id function conflicts with global") if (defined($Global{$id}));
  Die("$id function already declared")
	if (defined($Function{$id}) && $Function{$id} eq "real");

  $Function{$id}=$definition;	# proto or real
  $Nextpnum=0;			# Params for this function start at 0
  $Last_functionid=$id;

  # Mark the type of function
  $Functype{$id}{void}=1 if $Isvoid;
  $Functype{$id}{recursive}=1 if $Isrecursive;
}

# Print out the label of the function just created
# We do this for real function declarations, not just prototypes
sub print_function_label
{
  $Function{$Last_functionid}= 'real';
  push(@$Line, [ "$Last_functionid: 0" ]);
}

# Check and return a function name. Translate system calls to
# ones starting with a dot, so we don't tread on the assembler's toes
sub get_functionid
{
  my $id= shift;
  $id= $Syscall{$id} if (defined($Syscall{$id}));
  Die("$id function not yet declared") if (!defined($Function{$id}));
  return($id);
}

### STRING LITERAL CODE
my @Stringlit;		# List of string literals and their identifiers

my $strlabel=0;
# Return a new string label
sub new_strlabel
{
  $strlabel++;
  return("STR$strlabel");
}

# Add a new string literal. Make a label if none
sub add_strliteral
{
  my ($s, $label)= @_;
  $label= new_strlabel() if (!defined($label));
  push(@Stringlit, [ $s, $label ]);
  return($label);
}

### TEMPORARY LOCATIONS CODE
#
# When I first wrote the compiler, I thought I could keep the
# last expression result in the AC. This doesn't work for
# exprssions like if (x + 2 > y - 4). Now, every expression is
# saved in a temporary location and reloaded as required. We
# rely on the optimiser to remove pointless store/loads.
#
# Expand an identifier and load it into the AC
sub lac
{
  my $id= shift;
  if (!defined($id)) {
    Die("No expression value, perhaps a void function");
  }
  push(@$Line, ['lac', getid($id, 'lac')]);
}

# Expand an identifier and store into it from the AC
sub dac
{
  my ($id, $who)= @_;
  return if (!defined($id));
  #push(@$Line, ['dac', getid($id, 'dac'), "\t\t\" $who"]);
  push(@$Line, ['dac', getid($id, 'dac')]);
}

# Reset the temporary locations
sub reset_temp_locations
{
  @Templocn= ();
  foreach my $i (1 .. $Tempnum) {
    push(@Templocn, ".temp$i");
  }
}

# Temporarily store the AC and return an
# identifier for the temporary storage
sub tempdac
{
  Die("out of temp locations") if (@Templocn==0);
  my $temp= shift(@Templocn);
  push(@$Line, ['dac', $temp]);
  return([ $temp, '' ]);
}

### CONSTANTS CODE
# Create a new constant to be written out later
sub new_const
{
  my $c= shift;
  my $label;

  # Negative constants have labels starting with m (minus)
  # Positive constants have labels starting with d (decimal)
  if ($c<0) {
    my $absc= abs($c);
    $label= "m$absc";
  } else {
    $label= "d$c";
  }
  $Const{$label}=$c;
  return($label);
}

### FUNCTION CALLING CODE
# For functions which are recursive, save their local variables
# and the return address onto the stack.
sub save_locals
{
  my $fname= shift;

  # If the caller is a recursive function, then save all our local
  # variables onto the stack. However, don't do this when we are calling
  # a system call
  if (defined($Functype{$Last_functionid}{recursive}) &&
	!defined($Syscall{$fname})) {
    # Firstly save the return address
    push(@$Line, ['lac', "$Last_functionid"]);
    push(@$Line, ['dac', '.stkptr i']);

    # Now save the locals
    foreach my $local (@{ $PPosn{$Last_functionid} }) {
      push(@$Line, ['lac', "$Last_functionid.$local"]);
      push(@$Line, ['dac', '.stkptr i']);
    }
  }
}

# Call the named function. For recursive function callers, also
# restore the local variables and the return address from the stack.
sub call_function
{
  my $fname= shift;
  my $temp;
  my $localcnt;

  # Output the code to call the function, and
  # store the returned value of the non-void function
  push(@$Line, ['jms', get_functionid($fname) ]);
  $temp= tempdac() if (!defined($Functype{$fname}{void}));

  # If the caller is a recursive function, retrieve our local variables
  if (defined($Functype{$Last_functionid}{recursive}) &&
	!defined($Syscall{$fname})) {
    $localcnt= 1+ scalar(@{ $PPosn{$Last_functionid} }); # +1 for return addr
    new_const( -$localcnt);
    push(@$Line, ['lac', '.stkptr']);
    push(@$Line, ['tad', "m$localcnt"]);
    push(@$Line, ['dac', '.stkptr']);

    # Firstly reload the return address
    push(@$Line, ['lac', '.stkptr i']);
    push(@$Line, ['dac', "$Last_functionid"]);

    # Now reload the locals
    foreach my $local (@{ $PPosn{$Last_functionid} }) {
      push(@$Line, ['lac', '.stkptr i']);
      push(@$Line, ['dac', "$Last_functionid.$local"]);
    }

    # And reset the stack pointer
    push(@$Line, ['lac', '.stkptr']);
    push(@$Line, ['tad', "m$localcnt"]);
    push(@$Line, ['dac', '.stkptr']);
  }
  
  # Return nothing or the temporary value
  if (defined($Functype{$fname}{void})) {
    return(undef);
  } else {
    return($temp);
  }
}

%}

%%

translation_unit:
      global_declarations 
;
global_declarations:
      global_declaration
    | global_declaration global_declarations 
;
global_declaration:
      type_specifier global_declaration_list ';'
	{ # Reset the void/recursive flags for the next function declaration
	  $Isvoid=0; $Isrecursive=0;
	}
    | type_specifier function_definition 
;
global_declaration_list:
      global_id_declaration
    | global_id_declaration ',' global_declaration_list
;
global_id_declaration:
      ptr_identifier.d
	{ # A new global variable with a default zero value
	  new_globalid($d,'',0);
	}
    | ptr_identifier.d '=' CONSTANT.c
	{ # A new global variable with a specific value
	  new_globalid($d, '',$c);
	}
    | array_declaration
;
local_declaration:
      type_specifier local_declaration_list ';'
	{ # Reset the void/recursive flags for the next function declaration
	  $Isvoid=0; $Isrecursive=0;
	}
;
local_declaration_list:
      local_id_declaration
    | local_id_declaration ',' local_declaration_list
;
local_id_declaration:
      ptr_identifier.p
	{ # A new local variable in this function named $p
	  new_localid($Last_functionid, $p, 1);
	}
    | ptr_identifier.p '=' bit_expression.e
	{ # A new local variable in this function named $p
	  new_localid($Last_functionid, $p, 1);
	  # Load the expression and save it into $p
	  lac($e); dac([$p,''], 'local_id_declaration');
	}
    | array_declaration
;
array_declaration:
      ptr_identifier.d '[' CONSTANT.c ']'
        {
          # Build a list of zero values
          my @zlist;
          foreach my $count (1 .. $c) {
            push(@zlist, 0);
          }
          new_array($d, \@zlist);
        }
    | ptr_identifier.d '[' ']' '=' '{' constant_list.l '}'
	{ # Create a new array initialised with the constant list
	  new_array($d, $l);
	}
    | ptr_identifier.d '[' ']' '=' STRINGLITERAL.s
	{ # Create a new array with no element list, but then
	  # add the string literal and point the array at it
          my $id= new_array($d, undef);
          add_strliteral($s, $id);
        }
;
constant_list:
      CONSTANT.c
	{ # Return an arrayref with one element
	  [ $c ];
	}
    | constant_list.l ',' CONSTANT.c
	{ # Return an arrayref with an extra element
          push(@$l, $c); $l;
	}
;
ptr_identifier:
      IDENTIFIER.i
	{ $i; }
    | pointer IDENTIFIER.i
	{ $i; }
;
type_specifier:
      type
    | recursive type
;
type:
      VOID
	{ $Isvoid=1; }
    | CHAR
    | INT 
;
recursive:
      RECURSIVE
	{ $Isrecursive=1; }
;
pointer:
      '*' 
;
function_definition:
      function_declarator ';'
    | function_declarator
	{ print_function_label();
	  reset_temp_locations();
	}
      compound_statement
	{ # Output the code to return from the functions
	  push(@$Line, ['jmp', "$Last_functionid i"]);
	}
;
function_declarator:
      ptr_identifier.f '(' ')'
	{ # Declare the function as a prototype for now
	  # and then reset the void/recursive flags for later
	  new_functionid($f,'proto');
	  $Isvoid=0; $Isrecursive=0;
	}
    | ptr_identifier.f '('
	{ # Declare the function as a prototype for now
	  # and then reset the void/recursive flags for later
	  new_functionid($f,'proto');
	  $Isvoid=0; $Isrecursive=0;
	}
      parameter_list ')'
;
parameter_list:
      parameter_declaration
    | parameter_list ',' parameter_declaration
;
parameter_declaration:
      type_specifier ptr_identifier.p 
	{ # Create the parameter as a new local, and
	  # reset the void/recursive flags
	  new_localid($Last_functionid, $p, 1);
	  $Isvoid=0; $Isrecursive=0;
	}
;
function_expression:
      IDENTIFIER.f '(' ')'
	{ save_locals($f); call_function($f); }
    | IDENTIFIER.f '('
	{ # We have parameters, so start them at zero
	  $Nextpnum=0; $Calledfn= $f; save_locals($f); }
      argument_list ')' 
	{ call_function($f); }
;
argument_list:
      argument.a
	{ # Get the name of the function's param at this position
	  my $pname= $PPosn{$Calledfn}[$Nextpnum++];
	  lac($a); dac(["$Calledfn.$pname",''], 'argument_list');
	}
    | argument_list ',' argument.a
	{ # Get the name of the function's param at this position
	  my $pname= $PPosn{$Calledfn}[$Nextpnum++];
	  lac($a); dac(["$Calledfn.$pname",''], 'argument_list2');
	}
;

# Expression identifiers are represented as an arrayref with two or
# three elements: the identifier, 'i' if it needs an
# indirect reference, and an optional third value which
# is the array offset expression (i.e. also an arrayref).
# The second element is 'array' if there is an offset.
lvalue_expression:
      IDENTIFIER.i
	{ [ $i, '' ]; }
    | '*' IDENTIFIER.i
	{ [ $i, ' i' ]; }
    | IDENTIFIER.i '[' bit_expression.e ']'
	{ [ $i, 'array', $e ]; }
;
basic_expression:
      lvalue_expression
    | postop_expression
    | CONSTANT.c
	{ # Create a constant, get its id and return an idref
	  $c= new_const($c); [ $c, '']; }
    | STRINGLITERAL.s
	{ # Create a string literal, get its id and return an idref
	  my $id= add_strliteral($s);
	  [ $id, '' ]; }
    | function_expression
    | '(' bit_expression.b ')'
	{ $b; }
;
unary_expression:
      basic_expression
    | '~' basic_expression.e
        {
	  lac($e);
  	  push(@$Line, ['cma']);
	  tempdac();
        }
    | '!' basic_expression.e
        { my $temp= tempdac();
	  lac($e);
	  # Set the temp to 0 if $e is non-zero, 1 if $e is zero
  	  push(@$Line, ['sza']);
  	  push(@$Line, ['jmp', '1f']);
  	  push(@$Line, ['lac', '.d1']);
  	  push(@$Line, ['dac', $temp->[0]]);
  	  push(@$Line, ['jmp', '2f']);
  	  push(@$Line, ['1: dzm', $temp->[0]]);
  	  push(@$Line, ['2:']);
	  $temp;
	}
;
multiplicative_expression:
      unary_expression
    | unary_expression.lhs '*' multiplicative_expression.rhs
	{ 
	  lac($rhs);
  	  push(@$Line, ['dac', '.+4']);
	  lac($lhs);
  	  push(@$Line, ['cll; mul; ..; lacq']);
	  tempdac();
	}
    | unary_expression.lhs '/' multiplicative_expression.rhs
	{ 
	  lac($rhs);
  	  push(@$Line, ['dac', '.+4']);
	  lac($lhs);
  	  push(@$Line, ['cll; idiv; ..; lacq']);
	  tempdac();
	}
    | unary_expression.lhs '%' multiplicative_expression.rhs
	{ 
	  lac($rhs);
  	  push(@$Line, ['dac', '.+4']);
	  lac($lhs);
  	  push(@$Line, ['cll; idiv; ..']);
	  tempdac();
	}
;
additive_expression:
      multiplicative_expression
    | additive_expression.lhs '+' multiplicative_expression.rhs
	{ 
	  lac($lhs);
  	  push(@$Line, ['tad', getid($rhs, 'rhsadd')]);
	  tempdac();
	}
    | additive_expression.lhs '-' multiplicative_expression.rhs
	{ 
	  lac($lhs);
  	  push(@$Line, ['cma']);
  	  push(@$Line, ['tad', getid($rhs, 'rhssub')]);
  	  push(@$Line, ['cma']);
	  tempdac();
	}
;
shift_expression:
      additive_expression
    | shift_expression.lhs LEFT_OP CONSTANT.c
	{ lac($lhs);
  	  push(@$Line, ['lls', $c]);
	  tempdac();
	}
    | shift_expression.lhs RIGHT_OP CONSTANT.c
	{ lac($lhs);
  	  push(@$Line, ['lrss', $c]);
	  tempdac();
	}
;
bit_expression:
      shift_expression
    | bit_expression.lhs '&' shift_expression.rhs
	{ 
	  lac($lhs);
  	  push(@$Line, ['and', getid($rhs, 'rhsand') ]);
	  tempdac();
	}
    | bit_expression.lhs '^' shift_expression.rhs
	{ 
	  lac($lhs);
  	  push(@$Line, ['xor', getid($rhs, 'rhsxor') ]);
	  tempdac();
	}
    | bit_expression.lhs '|' shift_expression.rhs
	{ 
	  lac($rhs);
  	  push(@$Line, ['lmq']);
	  lac($lhs);
  	  push(@$Line, ['omq']);
	  tempdac();
	}
;
# Save a zero or non-zero result into a temp location
relational_expression:
      bit_expression
    | bit_expression.lhs '<' bit_expression.rhs
	{ 
	  lac($lhs);
	  push(@$Line, ['cma']);
	  push(@$Line, ['tad', getid($rhs, 'rhs<') ]);
	  push(@$Line, ['cma']);
	  push(@$Line, ['sma']);
          push(@$Line, ['cla']);	# Not true, now zero
	  tempdac();
	}
    | bit_expression.lhs '>' bit_expression.rhs
	{ 
	  lac($rhs);
	  push(@$Line, ['cma']);
	  push(@$Line, ['tad', getid($lhs, 'lhs>')]);
	  push(@$Line, ['cma']);
	  push(@$Line, ['sma']);
          push(@$Line, ['cla']);	# Not true, now zero
	  tempdac();
	}
    | bit_expression.lhs LE_OP bit_expression.rhs
	{ 
	  lac($rhs);
	  push(@$Line, ['cma']);
	  push(@$Line, ['tad', getid($lhs, 'lhs<=') ]);
	  push(@$Line, ['cma']);
	  push(@$Line, ['spa']);
          push(@$Line, ['jmp', '1f']);
          push(@$Line, ['lac', '.d1']);	# True, now one
          push(@$Line, ['jmp', '2f']);
          push(@$Line, ['1: cla']);	# Not true, now zero
          push(@$Line, ['2:']);
	  tempdac();
	}
    | bit_expression.lhs GE_OP bit_expression.rhs
	{ 
	  lac($lhs);
	  push(@$Line, ['cma']);
	  push(@$Line, ['tad', getid($rhs, 'rhs>=') ]);
	  push(@$Line, ['cma']);
	  push(@$Line, ['spa']);
          push(@$Line, ['jmp', '1f']);
          push(@$Line, ['lac', '.d1']);	# True, now one
          push(@$Line, ['jmp', '2f']);
          push(@$Line, ['1: cla']);	# Not true, now zero
          push(@$Line, ['2:']);
	  tempdac();
	}
    | bit_expression.lhs EQ_OP bit_expression.rhs
	{
	  my $third= new_label();
	  lac($lhs);
	  push(@$Line, ['sad', getid($rhs, 'rhs==') ]);
          push(@$Line, ['jmp', '1f']);
          push(@$Line, ['cla']);		# Not true, now zero
          push(@$Line, ['jmp', '2f']);
          push(@$Line, ['1: lac', '.d1']);	# True, now one
          push(@$Line, ['2:']);
	  tempdac();
	}
    | bit_expression.lhs NE_OP bit_expression.rhs
	{ 
	  lac($lhs);
	  push(@$Line, ['sad', getid($rhs, 'rhs!=') ]);
          push(@$Line, ['jmp', '1f']);
          push(@$Line, ['lac', '.d1']);	# True, now one
          push(@$Line, ['jmp', '2f']);
          push(@$Line, ['1: cla']);	# Not true, now zero
          push(@$Line, ['2:']);
	  tempdac();
	}
;
logical_expression:
      relational_expression
    | relational_expression.lhs AND_OP logical_expression.rhs
	{ # We can't just "and" them because both might be non-zero
	  # but the "and" result might be zero.
	  lac($lhs);
  	  push(@$Line, ['sna']);
  	  push(@$Line, ['jmp', '1f']);
	  lac($rhs);
  	  push(@$Line, ['sna']);
  	  push(@$Line, ['jmp', '1f']);
  	  push(@$Line, ['lac', '.d1']);
  	  push(@$Line, ['jmp', '2f']);
  	  push(@$Line, ['1: cla']);
  	  push(@$Line, ['2:']);
	  tempdac();
	}
    | relational_expression.lhs OR_OP logical_expression.rhs
	{ 
	  lac($rhs);
  	  push(@$Line, ['lmq']);
	  lac($lhs);
  	  push(@$Line, ['omq']);
	  tempdac();
	}
;
argument:
      logical_expression
;
true_false_expression:
      logical_expression.b
	{ 
	  lac($b);
	  push(@$Line, ['lac', getid($b, 'lac')]);
	  push(@$Line, ['sna']);
          push(@$Line, ['jmp', $lifref->[-1]->[0]]);
	}
;
statement:
      labeled_statement
    | assignment_statement ';'
    | function_expression ';'
    | selection_statement
    | iteration_statement
    | jump_statement
    | compound_statement
    | postop_statement 
;
labeled_statement:
      IDENTIFIER.i ':'
  	{ push(@$Line, [ "$i:" ]); }
      statement
;
assignment_statement:
    lvalue_expression.l '=' bit_expression.e
	{ lac($e); dac($l, 'assignment_statement'); reset_temp_locations(); }
;
selection_statement:
      if_head %prec WEAK
        { push(@$Line, ["$ifstack[-1]->[0]:"]);
          pop(@ifstack);
        }
    | if_head
	{ push(@$Line, ['jmp', $ifstack[-1]->[1]]);
          push(@$Line, ["$ifstack[-1]->[0]:"]); 
	}
      ELSE statement
        { push(@$Line, ["$ifstack[-1]->[1]:"]);
	  pop(@ifstack);
	}
;
if_head:
      IF
        { # Generate false and end labels for this IF
          my $false= new_label();
          my $end= new_label();
          push(@ifstack, [ $false, $end ]);
	  $lifref= \@ifstack;
        }
      '(' true_false_expression ')'
	{ reset_temp_locations(); }
      statement 
;
iteration_statement:
      WHILE
        { # Generate start and end labels for this loop
          my $start= new_label();
          my $end= new_label();
          push(@loopstack, [ $end, $start ]);
	  $lifref= \@loopstack;
          push(@$Line, ["$start:"]);
        }
      '(' true_false_expression ')'
      statement
        { push(@$Line, ['jmp', $loopstack[-1]->[1]]);
          push(@$Line, ["$loopstack[-1]->[0]:"]);
	  pop(@loopstack);
	  reset_temp_locations();
	}
    | DO
        { # Generate start and end labels for this loop
          my $start= new_label();
          my $end= new_label();
          push(@loopstack, [ $end, $start ]);
	  $lifref= \@loopstack;
          push(@$Line, ["$start:"]);
        }
      statement WHILE '(' true_false_expression ')' ';'
	{ push(@$Line, ['jmp', $loopstack[-1]->[1]]);
          push(@$Line, ["$loopstack[-1]->[0]:"]);
	  pop(@loopstack);
	  reset_temp_locations();
	}
    | FOR
      '(' assignment_statement ';'
        { # Generate start and end labels for this loop
          my $start= new_label();
          my $end= new_label();
          push(@loopstack, [ $end, $start ]);
	  $lifref= \@loopstack;
          push(@$Line, ["$start:"]);
        }
      true_false_expression ';'
	{ # Move all the current lines over to FinalLine
          # and empty $Line for the third statement
          push(@FinalLine, $Line); $Line= [];
	  reset_temp_locations();
        }
      third_for_expression ')' statement
        {
          # Move all the current lines over to FinalLine
          push(@FinalLine, $Line); $Line= [];
          # Pop off the most recent FOR third statement code
          # and save in the FinalLine array
          push(@FinalLine, pop(@Forstack));
          # Now add in the jump at the end of the loop
          push(@$Line, ['jmp', $loopstack[-1]->[1]]);
          push(@$Line, ["$loopstack[-1]->[0]:"]);
	  pop(@loopstack);
        }
;
third_for_expression:
      assignment_statement
        {
          # Push the third statement code onto the Forstack
          push(@Forstack, $Line); $Line= [];
        }
    | postop_expression
        {
          # Push the third statement code onto the Forstack
          push(@Forstack, $Line); $Line= [];
        }
;
jump_statement:
      GOTO IDENTIFIER.i ';'
  	{ push(@$Line, [ 'jmp', $i ]); }
    | CONTINUE ';'
	{ push(@$Line, ['jmp', $loopstack[-1]->[1]]); }
    | BREAK ';'
	{ push(@$Line, ['jmp', $loopstack[-1]->[0]]); }
    | RETURN ';'
	{ push(@$Line, ['jmp', "$Last_functionid i"]); }
    | RETURN '(' bit_expression.e ')' ';' 
	{ lac($e); push(@$Line, ['jmp', "$Last_functionid i"]); }
;
compound_statement:
      '{' '}'
    | '{' statement_list '}'
    | '{' declaration_list statement_list '}' 
;
postop_statement:
      postop_expression ';' 
;
postop_expression:
      lvalue_expression.l INC_OP
	{ # We manually load into $id and $ind so
	  # that we can increment this identifier
	  # separately from the original value in $temp
	  my ($id, $ind)= getid($l, 'lac');
	  push(@$Line, ['lac', "$id $ind"]);
	  my $temp= tempdac();
	  push(@$Line, ['tad', '.d1']); 
	  push(@$Line, ['dac', "$id $ind"]);
	  $temp;
	}
    | lvalue_expression.l DEC_OP 
	{ my ($id, $ind)= getid($l, 'lac');
	  push(@$Line, ['lac', "$id $ind"]);
	  my $temp= tempdac();
	  push(@$Line, ['tad', '.m1']); 
	  push(@$Line, ['dac', "$id $ind"]);
	  $temp;
	}
;
declaration_list:
      local_declaration
    | local_declaration declaration_list 
;
statement_list:
      statement
    | statement statement_list 
;

%%

sub TERMINAL::info { $_[0]{attr} }
$Parse::Eyapp::Node::INDENT = 2;

sub _Error {
    print("Token " . $_[0]->YYCurval .
          " unexpected on line $Linenumber of $Basename.h\n");
    print("Expecting one of: " . join(' ', $_[0]->YYExpect) . "\n");
}

sub _Lexer {
    my($parser)=shift;

    # Loop until we can return a token or there are no lines left
    while (1) {
      # Return a token if possible
      if (@TokenQueue) {
        my $tokptr= shift(@TokenQueue);
        #print("Return token $tokptr->[0] $tokptr->[1]\n");
        return(@{ $tokptr });
      }

      # No tokens, so read a line in. Exit if no lines left
      $_= <$IN> || return('',undef);
      $Linenumber++;

      # Pre-processor line
      if (m{^#}) {
	# Pre-processor current line number
        if (m{^#\s*(\d+)}) {
          $Linenumber= $1-1;
	}
	# Read in another line
        next;
      }

      # Remove any // comments and leading whitespace
      s{\s*\/\/.*}{}; s{^\s*}{};

      # Break the line up into tokens
      while ($_) {
        if ($Incomment) {
          # If we find the end of a multi-line comment, mark out
          if (s{.*\*/\s*}{}) { $Incomment = 0; next; }
          # Didn't find one, so get out of this line loop
          # as the whole line is part of the comment.
          last;
        }
        if (s{^/\*\s*}{}) { $Incomment = 1; next; }
        if (s{^([A-Za-z_][A-Za-z0-9_]*)\s*}{}) {
          # Push a keyword if found
          if ($Keyword{$1}) { push(@TokenQueue,[$Keyword{$1},$1]); next; }
          push(@TokenQueue,['IDENTIFIER',$1]); next;
        }
        if (s{^0([0-7]+)\s*}{}) {
          push(@TokenQueue,['CONSTANT',oct($1)]); next;
	}
        if (s{^(-?\d+)\s*}{}) {
          push(@TokenQueue,['CONSTANT',$1]); next;
        }
        if (s{^'\\n'\s*}{}) {
          push(@TokenQueue,['CONSTANT',10]); next;
        }
        if (s{^'\\t'\s*}{}) {
          push(@TokenQueue,['CONSTANT',9]); next;
        }
        if (s{^'\\0'\s*}{}) {
          push(@TokenQueue,['CONSTANT',0]); next;
        }
        if (s{^'([^'])'\s*}{}) {
          push(@TokenQueue,['CONSTANT',ord($1)]); next;
        }
	# Two character constant e.g 'ul'
        if (s{^'([^'])([^'])'\s*}{}) {
          push(@TokenQueue,['CONSTANT',ord($1)<<9 | ord($2)]); next;
        }
        if (s{^"([^"]*)"\s*}{}) {
	  # Change literal \n \t \0
	  my $str= $1;
	  $str=~ s/\\n/\n/g; $str=~ s/\\t/\t/g; $str=~ s/\\0/\0/g;
          push(@TokenQueue,['STRINGLITERAL',$str]); next;
        }
        if (s{^(<<)\s*}{}) {
          push(@TokenQueue,['LEFT_OP',$1]); next;
        }
        if (s{^(>>)\s*}{}) {
          push(@TokenQueue,['RIGHT_OP',$1]); next;
        }
        if (s{^(\&\&)\s*}{}) {
          push(@TokenQueue,['AND_OP',$1]); next;
        }
        if (s{^(\|\|)\s*}{}) {
          push(@TokenQueue,['OR_OP',$1]); next;
        }
        if (s{^(\+\+)\s*}{}) {
          push(@TokenQueue,['INC_OP',$1]); next;
        }
        if (s{^(\-\-)\s*}{}) {
          push(@TokenQueue,['DEC_OP',$1]); next;
        }
        if (s{^(==)\s*}{}) {
          push(@TokenQueue,['EQ_OP',$1]); next;
	}
        if (s{^(!=)\s*}{}) {
          push(@TokenQueue,['NE_OP',$1]); next;
	}
        if (s{^(<=)\s*}{}) {
          push(@TokenQueue,['LE_OP',$1]); next;
	}
        if (s{^(>=)\s*}{}) {
          push(@TokenQueue,['GE_OP',$1]); next;
	}
        if (s{^([-+*/%&|^<>=,;:~!])\s*}{}) {
          push(@TokenQueue,[$1,$1]); next;
        }
        if (s{^([\(\)\{\}\[\]])\s*}{}) {
          push(@TokenQueue,[$1,$1]); next;
        }
        Die("Unrecognised token on line: $_\n");
      }
    }
}

sub Run {
    my($self,$infile)= @_;

    # Create some globals to hold the filehandles and the basename
    $Basename = $infile;
    $Basename =~ s/\.[a-z]$//;

    # Open the in/out files
    open( $IN, "-|", "cpp -nostdinc -DH_LANG $infile")
    				|| die("Cannot open $infile: $!");
    my $outfile = $Basename . ".s";
    open( $OUT, ">", $outfile ) || die("Cannot write $outfile: $!");
    $Incomment  = 0;
    $Linenumber = 0;

    # Create the temporary locations
    # and the pointer for array element access
    foreach my $i (1 .. $Tempnum) {
      new_globalid(".temp$i",'',0);
    }
    new_globalid('.ptr','',0);

    # Parse the class which is in this file
    my $t= $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error);


    # Add any remaining lines to the final set of lines of code
    push(@FinalLine, $Line);

    # Do any optimisations
    do_optimisations() if ($Optimise);

    # Print out the lines of code
    foreach my $lref (@FinalLine) {
      foreach my $l (@$lref) {
	next if (!defined($l));		# Skip lines removed by optimiser
        my $line= join(' ', @$l);
        $line= "   " . $line if (!($l->[0]=~ m{:}));
        print($OUT "$line\n");
      }
    }

    # Print out the global variables
    foreach my $line (@GlobaLine) {
        print($OUT "$line\n");
    }

    # Print out constants
    foreach my $c (keys(%Const)) {
      print($OUT "$c: $Const{$c}\n");
    }

    # Print out local variables
    # Don't print out main.argc and main.argv
    # Don't print out locals whose "$how" value is zero
    foreach my $fn (keys(%Local)) {
      foreach my $id (keys(%{$Local{$fn}})) {
	my $l= "$fn.$id";
	next if ($Local{$fn}{$id}==0);	# how is zero
	next if ($l eq "main.argc");
	next if ($l eq "main.argv");
	print($OUT "$l: 0\n");
      }
    }

    # Write out the string literals, null terminated
    foreach my $sref (@Stringlit) {
      my ($s, $label)= @$sref;
      print($OUT "$label: $label.base\n");
      print($OUT "$label.base:\n");
      foreach my $i (0 .. length($s)-1) {
        print($OUT "   " . ord(substr($s, $i, 1)) . "\n");
      }
      print($OUT "   0\n");
    }

    # Finally, write out the beginning of the stack
    print($OUT ".stack: 0\n");

    # Close the in/out files
    close($IN);
    close($OUT);
}

# List of instructions that preserve the AC
# Used by the optimiser below
my %ACpreserve= (
  'lac' => 1,	# Yes I know, the logic below fixes this up
  'dac' => 1,
  'jmp' => 1,
  'lmq' => 1,
  'sma' => 1,
  'spa' => 1,
  'sad' => 1,
);

# Try to optimise the code
sub do_optimisations
{
  foreach my $lref (@FinalLine) {

    # We loop until there are no optimisations.
    # This is because one optimisation may allow
    # a futher optimisation.
    while (1) {
      # Set the details of the previous instruction to bogus values
      my ($prevopcode, $prevoperand, $previndex)=('','',-100);
      my $ac_value='';
      my $index=0;

      # So far, we haven't done any optimisations
      my $no_optimisation=1;

      # Get the next set of lines to process
      foreach my $l (@$lref) {
	if (!defined($l)) {
	  $index++; next;
 	}

	# Get the opcode and operand on this instructions
        my ($opcode, $operand)= @$l;
	# print("$index: $opcode, $operand; no_optim is $no_optimisation\n");
        $operand='' if (!defined($operand));

        # Destroy the AC value if this opcode doesn't preserve it
        $ac_value='' if (!defined($ACpreserve{$opcode}));

	# Remove two cma ops in a row
        if (($opcode eq 'cma') && ($prevopcode eq 'cma')) {
	  $lref->[$previndex]=undef;
	  $lref->[$index]=undef;
	  $opcode=''; $operand='';
	  $no_optimisation=0;
	}

        # If this is a dac and the last line was lac d0,
        # remove the last one and make this one a dzm
        if ($opcode eq 'dac') {
	  if (($prevoperand eq 'd0') && ($prevopcode eq 'lac')) {
	    $lref->[$previndex]=undef;
	    $opcode='dzm';
	    $lref->[$index]->[0]= $opcode;
	    $no_optimisation=0;
	  }
	  $ac_value= $operand;
        }

        # If there is a dac temp/lac temp pair, remove both of them
        if (($opcode eq 'lac') && ($prevopcode eq 'dac')
		&& ($operand eq $prevoperand) && ($operand=~ m{^\.temp\d+$})) {
	  $lref->[$previndex]=undef;
	  $lref->[$index]=undef;
	  $opcode=''; $operand='';
	  $no_optimisation=0;
        }

        # If this is a lac, save the new AC value
        if ($opcode eq 'lac') {
	  # If the AC already has this value, don't load it
	  if ($operand eq $ac_value) {
	    $lref->[$index]=undef; $opcode='';
	    $no_optimisation=0;
	  }
	  $ac_value= $operand;
        }

        # If this is a tad on d0, remove it
        if (($opcode eq 'tad') && ($operand eq 'd0')) {
	    $lref->[$index]=undef; $opcode='';
	    $no_optimisation=0;
        }

        # If this is a jmp and is the same as the last line, remove it
        if (($opcode eq 'jmp') && ($prevopcode eq 'jmp')) {
	  if ($operand eq $prevoperand) {
	    $lref->[$index]=undef;
	    $no_optimisation=0;
	  }
        }

        # Save this line as the last instruction for the next iteration
        ($prevopcode, $prevoperand, $previndex)= ($opcode, $operand, $index);
        $index++;
      }
      last if ($no_optimisation);
    }
  }
}


### MAIN PROGRAM ###

# Error if no argument
die("Usage: $0 [-nopt] file.h\n") if (@ARGV < 1);

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

    # -nopt: disable optimisations
    if ( $ARGV[0] eq "-nopt" ) {
        $Optimise = 0;
        shift(@ARGV);
    }
}

die("$ARGV[0] is not a file!\n") if (! -f $ARGV[0]);

my($parser)=new h;
$parser->Run($ARGV[0]);
exit(0);