#!/usr/bin/perl 
# X16Asm: DDP-516/H316 assembler version 0.4 -- date: Jan 14 2010
#
# This assembler is a 2 or 3 pass assembler which assembles absolute "load mode" code for 
# the H316/H516 instruction set and supports a subset of the DAP16 assembly language: 
# all instructions can be translated, but only a few speudo operations can be used. 
# The assembler is only meant to generate test programs for the FPGA implementation of the 
# H316/H516.
# The optional 1st pass (pass 0) expands tabs in a file (file extention is .s) to the DAP16 
# defined colomns for the label, operation, operand and comment field (result is file with 
# extention with extention .txt).
# Pass 1 processes the .txt file and defines the used symbols in the source file.
# Pass 2 assembles the source file and produces a listing (file with extension .lst) and
# the object output (file with extension .hex).
#
# The supported speudo operations are not completely compatible with DAP16; i.e. OCT and 
# DEC can have only a single value:
#  OCT: [+|-][']<octal number> | [+|-]<predefined symbol>
#  DEC: [+|-]<decimal number>  | [+|-]<predefined symbol>
#
# NUM, not DAP16 compatible, allows a simple numeric expression <expr>, including hex numbers.
# EAC,EAC*, not DAP16 compatible support, like DAC in normal mode 14 bit addresses, the 
# definition of 15 bit extend mode addresses 
#
# BCI, BSS, BSZ, DAC, EJCT, END, EQU, LOAD and ORG are recognized, of which BCI allows a 
# string expression and EQU, BSS, BSZ, DAC, and ORG a simple numeric expression <expr> , 
# which generates a single 16 bit number. 
# <expr> allows octal, decimal ,hexadecimal numbers or symbols separated by + and - operators.
#
# The output is absolute code in hexadecimal form: "<address>,<content>\n" for each word to load 
# in memory, and cannot be linked.
# 
my $version = '0.4';
my $DEBUG = 0;
#
# Author : Theo Engel
# Contact: Info@theoengel.nl
#
# history:
# 0.4 (JAN 14 2010) definition of 15 bit extended addresses supported (EAC EAC*)
# 0.3 (JAN 10 2010) more compatibility with DAP16: included LOAD and a subset of OCT and DEC
# 0.2 (DEC 13 2009) published version
#
# Usage: X16Asmxx.pl [-nl] <filename>.s..|<filename>.txt (where xx is some version number)
#
# source input fields
#####################
# the source input record is 80 characters maximum (punched card image) and 
# divided in 4 fields: label, operation, operand, comment
#
# default input record layout:
# max symbol length = 4
#!*** !**** !*****************!******************************************!
#label operation   operand         comment
#
# record layout can be changed by adapting the following settings.
# default
my $tab1 = 0;               # label field
my $fl1  = 5;               # +1
my $tab2 = 5;               # operation field
my $fl2  = 6;
my $tab3 = 11;              # operand field
my $fl3  = 15; 
my $tab4 = 26;              # comment field
my $fl4  = 46;
my $tab5 = $fl1+$fl2+$fl3+$fl4;

my $symlength=4;            # default max symbol length

my $f1;                     # input field1 char 0-5 (l=6)
my $f2;                     # input field2 char 7-18 (l=12)
my $f3;                     # input field3 char 19-34 (l=16)
my $f4;                     # input field4 char 35-79 (l=45)
my $ch;						          # input character
my $line = "";				      # expanded input record
my $cin  = 0;				        # input record char counter
my $cout = 0;				        # expanded record char counter
my $quot = 0;               # in quoted string flag
my $ll;						          # input record length
my $l;                      # temp
my $i;                      # temp
my $w1;
my $conlist=1;              # listing by default to concole as well

my $fi = shift (@ARGV);				
if($fi eq '-nl')
{
	$conlist=0;
	$fi = shift (@ARGV);				# source file
	if ($fi eq "" &&  $fi !~ /\.txt/ && $fi !~ /\.s/)
	{
		print "No filename, or wrong extention: $fi\n";
		print "Usage: X16Asmxx.pl [-nl] <filename>.s..|<filename>.txt\n";
		exit 1;
	}
}
else
{
	if ($fi eq "" &&  $fi !~ /\.txt/ && $fi !~ /\.s/)
	{
		print "No filename, or wrong extention: $fi\n";
		print "Usage: X16Asmxx.pl [-nl] <filename>.s..|<filename>.txt\n";
		exit 1;
	}
}	

print "X16 cross assembler version $version\n";

#######################################################################
#            PASS 0
#######################################################################
# If the extension is .s , pass 0 is executed to expand tabs
# The result is a file with expanded records with a .txt extension
# In case the provided input file has already an .txt extension, pass 0 is
# skipped and pass 1 is entered directly. The .txt file is expected to have
# the fields formatted in the required colums

if( $fi =~ /\.s/)
{
	($fn,$ty) = split(/\./, $fi);
	$fo = $fn . ".txt";
	if($DEBUG) {print "Expand tabs in $fi to file $fo\n";}
	if($DEBUG) {print "Start reading $fi (type is $ty) \n";}
	open (IN,$fi) || die "cannot open inputfile $fi: $!";
	open (OUT,">$fo") || die "cannot open ouputfile $fo: $!";
	while(<IN>)
	{
		$line = "";
		$cin  = 0;
		$cout = 0;
		$quot = 0;
		chomp;
		$ll = length($_);
		# expand tabs
		if(($ll > 0) && (substr($_,$cin,1) ne "*"))
		{
			while($cin < $ll)   
			{
				$ch=substr($_,$cin,1);			        # get next char from input record
				$cin=$cin+1;	
				if( $ch =~ /\\/ )		                        # replace tab by one or more spaces						
				{
						# replace tab by space
						$line=$line . " ";					# expanded input record
						$cout=$cout+1;
						if($cout <= $tab2)
						{
							while($cout<$tab2)
							{
									$line=$line . " ";	# expanded input record
					                $cout=$cout+1;
							}
							next;
						}
						if($cout <= $tab3)
						{
							while($cout<$tab3)
							{
									$line=$line . " ";	# expanded input record
					                $cout=$cout+1;
							}
							next;
						}
						if($cout <= $tab4)
						{
							while($cout<$tab4)
							{
									$line=$line . " ";	# expanded input record
					                $cout=$cout+1;
							}
							next;
						}
				}
				else
				{
					$line=$line . $ch;
					$cout = $cout + 1;
				}
			}
		}
		else
		{
			if($ll > 0)
			{
				$line = $_;		# comment line
			}
		}
		if($ll > 0)
		{
			print OUT $line . "\n";
		}
	}
	close (IN)   || die "can't close $fi: $!";
	close (OUT)  || die "can't close $fo: $!";	
	if($DEBUG) {print "$fi expanded into $fo\n";}
	$fi = $fo;
}

($fn,$ty) = split(/\./, $fi);
$fo = $fn . ".hex";
$fl = $fn . ".lst";

print "Assemble $fi to object $fo and listing $fl\n";
if($DEBUG) {print "Start reading $fi (pass1)\n";}
open (IN,$fi) || die "cannot open inputfile $fi: $!";

my $ln=0;                    # linenumber
my $header="";               # 1st source line is listing header
my $mode="A";                # default = absolute mode
my $pass=1;                  # start with pass 1
my $p=0;                     # location counter
my $nerr=0;                  # error counter
my $symbol;                  # scanned symbol
my %sym;                     # symbol table (name,value)
my %symtype;                 # symbol type  (name,type) A 
#
# symbol types
# a symbol can only be defined once and can not be redefined
# symbols are either predefined or are being defined during pass 1
# This assembler uses only symbols which represent absolut values:
# A  absolute

#######################################################################
# expression evaluator
#######################################################################
my $es;					        # expression string
my $les;                # expresion string length
my $ei;                 # expresion string index
my $eval;               # expression result
my $etype;              # type result value ("A", OR "!" if error)
my $exerr;              # 1 if error detected during expression evaluation

my %cvdig;              # digit conversion
$cvdig{'0'}=0x0;
$cvdig{'1'}=0x1;
$cvdig{'2'}=0x2;
$cvdig{'3'}=0x3;
$cvdig{'4'}=0x4;
$cvdig{'5'}=0x5;
$cvdig{'6'}=0x6;
$cvdig{'7'}=0x7;
$cvdig{'8'}=0x8;
$cvdig{'9'}=0x9;
$cvdig{'A'}=0xa;
$cvdig{'B'}=0xb;
$cvdig{'C'}=0xc;
$cvdig{'D'}=0xd;
$cvdig{'E'}=0xe;
$cvdig{'F'}=0xf;

#######################################################################
# operand syntax scanner and code generator
#######################################################################
my %I;		# operand syntax template
my %G;		# code generator of word

# operand syntax template: 2 fields of which 1 is optional
#
#	field1	field2
#	 ""		  ""    		empty, or
#	 m                mem address, or
#  sc               shift count (decimal)
#  da               device address
#         1         index register (optional and only in case field 1 is m)
#
#  m: memory address
#  m is represented by expression <expr>, resulting in an absolute value for m (for <expr>, see the subroutine evalexpr).
#
#  the value of m is tranlated into a value of p (page bit) and sa (sector address). 
#   - if m is  < 1000 (octal), p is set to 0 and sa is set to m;
#   - if m is >= 1000 (octal), p is set to 1 and sa is set to the last 9 bits of m.

#  sc: shift count
#  <number>, where
#  <number> == <decimal number> | <octal number>
#
#  the value of sc is translated into a value of csc (two complement shift count)
#    the last 6 bits of two complement value of the specified shift count are inserted in the shift instruction

#  da: device address
#  <number>, where
#  <number> == <decimal number> | <octal number>
#  the last 10 bits of the specified da value are inserted into the IO instruction

#  1 : index
#  in case the index is specified, the t (tag) bit is set in the memory reference instruction

$I{"JMP"}      = 'm,@1'; $G{"JMP"}      = '0.t.0001.p.sa';
$I{"JMP*"}     = 'm,@1'; $G{"JMP*"}     = '1.t.0001.p.sa';
$I{"LDA"}      = 'm,@1'; $G{"LDA"}      = '0.t.0010.p.sa';
$I{"LDA*"}     = 'm,@1'; $G{"LDA*"}     = '1.t.0010.p.sa';
$I{"ANA"}      = 'm,@1'; $G{"ANA"}      = '0.t.0011.p.sa';
$I{"ANA*"}     = 'm,@1'; $G{"ANA*"}     = '1.t.0011.p.sa';
$I{"STA"}      = 'm,@1'; $G{"STA"}      = '0.t.0100.p.sa';
$I{"STA*"}     = 'm,@1'; $G{"STA*"}     = '1.t.0100.p.sa';
$I{"ERA"}      = 'm,@1'; $G{"ERA"}      = '0.t.0101.p.sa';
$I{"ERA*"}     = 'm,@1'; $G{"ERA*"}     = '1.t.0101.p.sa';
$I{"ADD"}      = 'm,@1'; $G{"ADD"}      = '0.t.0110.p.sa';
$I{"ADD*"}     = 'm,@1'; $G{"ADD*"}     = '1.t.0110.p.sa';
$I{"SUB"}      = 'm,@1'; $G{"SUB"}      = '0.t.0111.p.sa';
$I{"SUB*"}     = 'm,@1'; $G{"SUB*"}     = '1.t.0111.p.sa';
$I{"JST"}      = 'm,@1'; $G{"JST"}      = '0.t.1000.p.sa';
$I{"JST*"}     = 'm,@1'; $G{"JST*"}     = '1.t.1000.p.sa';
$I{"CAS"}      = 'm,@1'; $G{"CAS"}      = '0.t.1001.p.sa';
$I{"CAS*"}     = 'm,@1'; $G{"CAS*"}     = '1.t.1001.p.sa';
$I{"IRS"}      = 'm,@1'; $G{"IRS"}      = '0.t.1010.p.sa';
$I{"IRS*"}     = 'm,@1'; $G{"IRS*"}     = '1.t.1010.p.sa';
$I{"IMA"}      = 'm,@1'; $G{"IMA"}      = '0.t.1011.p.sa';
$I{"IMA*"}     = 'm,@1'; $G{"IMA*"}     = '1.t.1011.p.sa';
$I{"***"}      = 'm,@1'; $G{"***"}      = '0.t.0000.p.sa';
$I{"****"}     = 'm,@1'; $G{"****"}     = '1.t.0000.p.sa';
$I{"PZE"}      = 'm,@1'; $G{"PZE"}      = '0.t.0000.p.sa';
$I{"PZE*"}     = 'm,@1'; $G{"PZE*"}     = '1.t.0000.p.sa';
$I{"DAC"}      = 'm,@1'; $G{"DAC"}      = '0.t.m';         
$I{"DAC*"}     = 'm,@1'; $G{"DAC*"}     = '1.t.m';
$I{"EAC"}      = 'm';    $G{"EAC"}      = '0.m';            # Extend Mode DAC  (15 bit address)
$I{"EAC*"}     = 'm';    $G{"EAC*"}     = '1.m';            # Extend Mode DAC* (15 bit address)
$I{"LDX"}      = 'm';    $G{"LDX"}      = '011101.p.sa';
$I{"LDX*"}     = 'm';    $G{"LDX*"}     = '111101.p.sa';
$I{"STX"}      = 'm';    $G{"STX"}      = '001101.p.sa';
$I{"STX*"}     = 'm';    $G{"STX*"}     = '101101.p.sa';
$I{"LRL"}      = 'sc';   $G{"LRL"}      = '0100000000.csc';
$I{"LRS"}      = 'sc';   $G{"LRS"}      = '0100000001.csc';
$I{"LRR"}      = 'sc';   $G{"LRR"}      = '0100000010.csc';
$I{"LGR"}      = 'sc';   $G{"LGR"}      = '0100000100.csc';
$I{"ARS"}      = 'sc';   $G{"ARS"}      = '0100000101.csc';
$I{"ARR"}      = 'sc';   $G{"ARR"}      = '0100000110.csc';
$I{"LLL"}      = 'sc';   $G{"LLL"}      = '0100001000.csc';
$I{"LLS"}      = 'sc';   $G{"LLS"}      = '0100001001.csc';
$I{"LLR"}      = 'sc';   $G{"LLR"}      = '0100001010.csc';
$I{"LGL"}      = 'sc';   $G{"LGL"}      = '0100001100.csc';
$I{"ALS"}      = 'sc';   $G{"ALS"}      = '0100001101.csc';
$I{"ALR"}      = 'sc';   $G{"ALR"}      = '0100001110.csc';
$I{"HLT"}      = '';     $G{"HLT"}      = '0000000000000000';
$I{"INK"}      = '';     $G{"INK"}      = '0000000000100011';
$I{"IAB"}      = '';     $G{"IAB"}      = '0000000010000001';
$I{"ENB"}      = '';     $G{"ENB"}      = '0000000100000001';
$I{"INH"}      = '';     $G{"INH"}      = '0000001000000001';
$I{"SKP"}      = '';     $G{"SKP"}      = '1000000000000000';
$I{"SRC"}      = '';     $G{"SRC"}      = '1000000000000001';
$I{"SR4"}      = '';     $G{"SR4"}      = '1000000000000010';
$I{"SR3"}      = '';     $G{"SR3"}      = '1000000000000100';
$I{"SR2"}      = '';     $G{"SR2"}      = '1000000000001000';
$I{"SR1"}      = '';     $G{"SR1"}      = '1000000000010000';
$I{"SSR"}      = '';     $G{"SSR"}      = '1000000000011110';
$I{"SZE"}      = '';     $G{"SZE"}      = '1000000000100000';
$I{"SLZ"}      = '';     $G{"SLZ"}      = '1000000001000000';
$I{"SPL"}      = '';     $G{"SPL"}      = '1000000100000000';
$I{"NOP"}      = '';     $G{"NOP"}      = '1000001000000000';
$I{"SSC"}      = '';     $G{"SSC"}      = '1000001000000001';
$I{"SS4"}      = '';     $G{"SS4"}      = '1000001000000010';
$I{"SS3"}      = '';     $G{"SS3"}      = '1000001000000100';
$I{"SS2"}      = '';     $G{"SS2"}      = '1000001000001000';
$I{"SS1"}      = '';     $G{"SS1"}      = '1000001000010000';
$I{"SSS"}      = '';     $G{"SSS"}      = '1000001000011110';
$I{"SNZ"}      = '';     $G{"SNZ"}      = '1000001000100000';
$I{"SLN"}      = '';     $G{"SLN"}      = '1000001001000000';
$I{"SMI"}      = '';     $G{"SMI"}      = '1000001100000000';
$I{"CHS"}      = '';     $G{"CHS"}      = '1100000000010100';
$I{"CRA"}      = '';     $G{"CRA"}      = '1100000000100000';
$I{"SSP"}      = '';     $G{"SSP"}      = '1100000001000000';
$I{"RCB"}      = '';     $G{"RCB"}      = '1100000010000000';
$I{"CSA"}      = '';     $G{"CSA"}      = '1100000011010000';
$I{"CMA"}      = '';     $G{"CMA"}      = '1100000100000001';
$I{"SSM"}      = '';     $G{"SSM"}      = '1100000101000000';
$I{"SCB"}      = '';     $G{"SCB"}      = '1100000110000000';
$I{"CAR"}      = '';     $G{"CAR"}      = '1100001000100100';
$I{"CAL"}      = '';     $G{"CAL"}      = '1100001000101000';
$I{"ICL"}      = '';     $G{"ICL"}      = '1100001001100000';
$I{"AOA"}      = '';     $G{"AOA"}      = '1100001010000110';
$I{"ACA"}      = '';     $G{"ACA"}      = '1100001010001110';
$I{"ICR"}      = '';     $G{"ICR"}      = '1100001010100000';
$I{"ICA"}      = '';     $G{"ICA"}      = '1100001011100000';
$I{"TCA"}      = '';     $G{"TCA"}      = '1100000100000111'; #140407 iso 141407
$I{"OCP"}      = 'da';   $G{"OCP"}      = '001100.da';
$I{"INA"}      = 'da';   $G{"INA"}      = '101100.da';
$I{"OTA"}      = 'da';   $G{"OTA"}      = '111100.da';
$I{"SKS"}      = 'da';   $G{"SKS"}      = '011100.da';
$I{"SMK"}      = 'da';   $G{"SMK"}      = '111100.da';
$I{"OTK"}      = '';     $G{"OTK"}      = '1111001000010000';
$I{"EXA"}      = '';     $G{"EXA"}      = '0000000000001011';
$I{"DXA"}      = '';     $G{"DXA"}      = '0000000000001001';

# code generation variables
my $m;          # address field (16 bit)
my $sa;         # address in sector (9 bit)
my $oty;        # operand type (must be A)
my $sc;         # shift count field (6 bit)
my $da;         # device address (10 bit)
my $pagebit;    # sector bit
my $tag;        # index bit

######################## bin code generation ##########################
my $som     = 0201;	#start of codeblock
my $eom     = 0203;	#end   of codeblock
my $space   = 0x20; #space
my $rub     = 0xFF; #rubout
my $prl;			#program length in words
#######################################################################
# ASCII CONVERSION TABLE
my %ch;
$ch{' '}=0x20;
$ch{'!'}=0x21;
$ch{"\""}=0x22;
$ch{"\#"}=0x23;
$ch{'$'}=0x24;
$ch{'%'}=0x25;
$ch{'&'}=0x26;
$ch{"\'"}=0x27;
$ch{'('}=0x28;
$ch{')'}=0x29;
$ch{'*'}=0x2A;
$ch{'+'}=0x2B;
$ch{','}=0x2C;
$ch{'-'}=0x2D;
$ch{'.'}=0x2E;
$ch{"\/"}=0x2F;
$ch{'0'}=0x30;
$ch{'1'}=0x31;
$ch{'2'}=0x32;
$ch{'3'}=0x33;
$ch{'4'}=0x34;
$ch{'5'}=0x35;
$ch{'6'}=0x36;
$ch{'7'}=0x37;
$ch{'8'}=0x38;
$ch{'9'}=0x39;
$ch{"\:"}=0x3A;
$ch{"\;"}=0x3B;
$ch{'<'}=0x3C;
$ch{'='}=0x3D;
$ch{'>'}=0x3E;
$ch{'?'}=0x3F;
$ch{'@'}=0x40;
$ch{'A'}=0x41;
$ch{'B'}=0x42;
$ch{'C'}=0x43;
$ch{'D'}=0x44;
$ch{'E'}=0x45;
$ch{'F'}=0x46;
$ch{'G'}=0x47;
$ch{'H'}=0x48;
$ch{'I'}=0x49;
$ch{'J'}=0x4A;
$ch{'K'}=0x4B;
$ch{'L'}=0x4C;
$ch{'M'}=0x4D;
$ch{'N'}=0x4E;
$ch{'O'}=0x4F;
$ch{'P'}=0x50;
$ch{'Q'}=0x51;
$ch{'R'}=0x52;
$ch{'S'}=0x53;
$ch{'T'}=0x54;
$ch{'U'}=0x55;
$ch{'V'}=0x56;
$ch{'W'}=0x57;
$ch{'X'}=0x58;
$ch{'Y'}=0x59;
$ch{'Z'}=0x5A;
$ch{'['}=0x5B;
$ch{"\\"}=0x5C;
$ch{']'}=0x5D;
$ch{'^'}=0x5E;
$ch{'_'}=0x5F;

########################       PASS 1      ##########################
# input is a text file (extension is .txt) with all tabs are expanded
while(<IN>)
{
	chomp;
	$line = $_;
	if(ord(substr($_,0,1)) == 0)
	{
		# strip leader
		$i=0;
		$l=length($_);
		while((ord(substr($_,$i,1)) == 0) && $i < $l)
		{
			$i=$i+1;
		}
		$line = substr($_,$i,$l-$i);
	}
	$ln=$ln+1;			                   # incr line number
  if($ln == 1)
	{
		$header = $line;
	}
  next if (substr($_,0,1) eq '*');	   # ignore comment lines
  $f1=substr($line,$tab1,$fl1);          # label
	$f1=rtrim($f1);
  $f2=substr($line,$tab2,$fl2);          # operation
	$f2=rtrim($f2);
  $f3=substr($line,$tab3,$fl3);          # operand
	$f3=rtrim($f3);
	
	if($DEBUG){print "p1fields.$f1.$f2.$f3.\n";}
	
	if($f2 eq 'EJCT')
	{
		error("Error: Label not allowed in EJCT") if(label());
		next;
	}
	if($f2 eq 'LOAD')
	{
		error("Error: Label not allowed in LOAD") if(label());
		next;
	}	
	if($f2 eq 'ORG')
	{
		error("Error: Label not allowed in ORG") if(label());
		error("Error: Operand missing in ORG")   if($f3 eq "");
		$p = evalexpr($f3);
		if($DEBUG)
		{
			print "ORG:" . proct($p);
			print "\n";
		}
		next;
	}
	if($f2 eq 'END')
	{
		error("Error: Label not allowed in END") if(label());
		last;
	}	
	
  # A label is allowed/required for the following directives
	if($f2 eq 'NUM')   # only 1 value allowed
	{
		label();
		if($f3 ne "")
		{
			$l =  evalexpr($f3);
			$p=$p+1;
		}
		else
		{
			error("Error: Operand missing in NUM");
		}
		next;		
	}	
	if($f2 eq 'OCT')   # only 1 value allowed
	{
		label();
		if($f3 ne "")
		{
			$l =  evaloct($f3);
			$p=$p+1;
		}
		else
		{
			error("Error: Operand missing in OCT");
		}
		next;		
	}	
	if($f2 eq 'DEC')   # only 1 value allowed
	{
		label();
		if($f3 ne "")
		{
			$l =  evaldec($f3);
			$p=$p+1;
		}
		else
		{
			error("Error: Operand missing in DEC");
		}
		next;		
	}				
 	if($f2 eq 'BCI')  
	{
		label();
		if($f3 ne "")
		{
			$l=evalexpr($f3);
			$p=$p+$l;
		}
		else
		{
			error("Error: Operand missing in BCI");
		}
		next;	
	}		  	
	if($f2 eq 'BSS' || $f2 eq 'BSZ')
	{
		label();
		if($f3 ne "")
		{
			$l=evalexpr($f3);
			$p=$p+$l;
		}
		else
		{
			error("Error: Operand missing");
		}
		next;
	}
	if($f2 eq 'EQU')
	{
		if(! ($symbol=label()))
		{
			error("Error: Label missing, or wrong label in EQU, ");
		}
		else
		{
			if($f3 ne "")
			{
				$l=evalexpr($f3);
				$sym{$symbol} = $l; 		# define symbol value
				$symtype{$symbol} = $etype; # and set type
			}
			else
			{
				error("Error: Operand missing in EQU");
			}
		}
		next;
	}
	
	# Scan the non-directive operations
	label();
	if($G{$f2} eq undef)	
	{
		error("Error: Undefined opcode");
		next;
	}
	$p=$p+1;
}

# end of pass1

close (IN) || die "can't close $fi: $!";
print "End of Assembler pass 1, number of detected errors = $nerr\n";
if($nerr != 0)
{
	print "Stop, no object file generated\n";
	exit 1;
}

###########################      PASS 2        ##########################
if($DEBUG) {print "Start reading $fi (pass2)\n";}
open (IN,$fi) || die "cannot open inputfile $fi: $!";	
open (BIN, ">$fo") || die "cannot open outputfile $fo: $!";
open (LIST,">$fl") || die "cannot open outputfile $fl: $!";
$ln=0;					        # source input line number
$prl=0;                 # program length
$pass=2;
################# list page format ##############
my $page = 1;			      # listing page number
my $lpmax = 40;         # lines per listing page
my $lp = 0;             # listing page line number
#################################################
$p=0;                   # reset the location counter

while(<IN>)
{
	chomp;
	$line = $_;
	if(ord(substr($_,0,1)) == 0)
	{
		# strip leader
		$i=0;
		$l=length($_);
		while((ord(substr($_,$i,1)) == 0) && $i < $l)
		{
			$i=$i+1;
		}
		$line = substr($_,$i,$l-$i);
	}	
	$ln=$ln+1;
  if (substr($line,0,1) eq '*')
	{
		# list comment line
	    list($ln, spaces(14) . $line);
	    next;
	}
  $f1=substr($line,$tab1,$fl1);        # label
	$f1=rtrim($f1);
  $f2=substr($line,$tab2,$fl2);        # operation
	$f2=rtrim($f2);
  $f3=substr($line,$tab3,$fl3);        # operand	
	$f3=rtrim($f3);
  $f4=substr($line,$tab4,$fl4);        # comment
  $f4=rtrim($f4);

  if($DEBUG){print "p2fields.$f1.$f2.$f3.$f4\n";}
  
	if($f2 eq 'EJCT')
	{
	  list($ln, spaces(16) . $line);
		while($lp <= $lpmax)
		{
  		print LIST "\n";
			$lp=$lp+1;
		}
		$lp=0;   	  
		next;
	}  
  if($f2 eq 'ORG')
	{
		$p = evalexpr($f3);
	  list($ln, spaces(16) . $line);
		next;
	}
  if($f2 eq 'LOAD')
	{
	  list($ln, spaces(16) . $line);
		next;
	}	
  if($f2 eq 'END')
	{
	  list($ln, spaces(16) . $line);
		last;
	}	
	if($f2 eq 'NUM')   # only 1 value allowed
	{
		$l =  evalexpr($f3);
		list($ln, proct($p) . proct($l) . spaces(2) . $line . spaces(72-24-length($line)-2) . prhex(16,$p) . "," . prhex(16,$l));	
		print BIN prhex(16,$p) . "," . prhex(16,$l) . "\n";
		$p=$p+1;
		next;		
	}
	if($f2 eq 'OCT')   # only 1 value allowed
	{
		$l =  evaloct($f3);
		list($ln, proct($p) . proct($l) . spaces(2) . $line . spaces(72-24-length($line)-2) . prhex(16,$p) . "," . prhex(16,$l));	
		print BIN prhex(16,$p) . "," . prhex(16,$l) . "\n";
		$p=$p+1;
		next;		
	}
	if($f2 eq 'DEC')   # only 1 value allowed
	{
		$l =  evaldec($f3);
		list($ln, proct($p) . proct($l) . spaces(2) . $line . spaces(72-24-length($line)-2) . prhex(16,$p) . "," . prhex(16,$l));	
		print BIN prhex(16,$p) . "," . prhex(16,$l) . "\n";
		$p=$p+1;
		next;		
	}		
 	if($f2 eq 'BCI')  
	{
		$l=evalexpr($f3.$f4);		
	  list($ln, spaces(16) . $line);
    $i=0;
    nextchar(); # skip ,
    while($i < $l)
    {
    	$c=ord(nextchar());
    	if($c == 0) {$c=ord(' ')};
    	$w1=$c << 8;
     	$c=ord(nextchar());
    	if($c == 0) {$c=ord(' ')};  	
    	$w1=$w1+$c;
    	$w1=$w1 | 0x8080;           # set msb of both ASCII's
    	list(0, spaces(8) . proct($p) . proct($w1) . spaces(2) . spaces(72-24-2) . prhex(16,$p) . "," . prhex(16,$w1));
    	print BIN prhex(16,$p) . "," . prhex(16,$w1) . "\n";  		
    	$i=$i+1;
    	$p=$p+1;
    }
		next;	
	}		  	
	if($f2 eq 'BSS' || $f2 eq 'BSZ') # for BSS, like for BSZ, also "zero" words are generated
	{
	  list($ln, spaces(16) . $line);		
		$l=evalexpr($f3);
		$i=0;
		while($i<$l)
		{
			list(0, spaces(8) . proct($p) . proct(0) . spaces(2) . spaces(72-24-2) . prhex(16,$p) . "," . prhex(16,0));	
		  print BIN prhex(16,$p) . "," . prhex(16,0) . "\n";
			$p=$p+1;
			$i=$i+1;
		}
		next;
	}
	if($f2 eq 'EQU')
	{
		list($ln, spaces(16) . $line);
		next;
	}
  # Scan machine operations
	scan($f2,$I{$f2},$f3);   # $f2=opcode, $I{$f2}=template, $f3=string
	# and generate the code	
	$w1=gen1($G{$f2});
	list($ln, proct($p) . proct($w1) . spaces(2) . $line . spaces(72-24-length($line)-2) . prhex(16,$p) . "," . prhex(16,$w1));
	print BIN prhex(16,$p) . "," . prhex(16,$w1) . "\n";
  $p=$p+1;
}

# force an EJECT to have the symbol table on a new page
while($lp <= $lpmax)
{
  print LIST "\n";
	$lp=$lp+1;
}
$lp=0;   
list(0, "  SYMBOL TABLE\n");

my $sb;
my $sl="";
$i=0;
foreach my $n (sort keys %sym)
{
	$l = length($n);
	$sb = "  $n" . spaces($symlength-$l+1) . proct($sym{$n}) . " " . $symtype{$n};
	$sl = $sl . $sb . " ";
	$i = $i + 1;
	if($i == 4)		# symbol table over 4 columns
	{
		list(0, $sl);
		$sl = "";
		$i=0;
	}
}
list(0, $sl); # last line symbol table
list(0, "\n  X16Asm, version $version. End of assembly, $nerr errors.");

if(! $conlist)
{
	print  "X16Asm, version $version. End of assembly, $nerr errors.\n"
}

close (IN)   || die "can't close $fi: $!";
close (BIN)  || die "can't close $fo: $!";
close (LIST) || die "can't close $fl: $!";

if($nerr == 0)
{
	exit;
}
else
{
	exit 1;
}
#############################################################################

sub punch {
    my($a) = @_;
    my $byte;
    $byte = pack("C", $a);
    print BIN $byte;
}

sub rtrim {
	my $s = shift;
	my $l = length($s);
	my $i = $l;
	if ($l > 0)
	{
		while($i > 0)
		{
			if((substr($s,$i-1,1)) ne " ")
			{ 
				last;
			}
			else
			{
				$i=$i-1;
			}
		}
	}
	else
	{
		return "";
	}
	if($i == 0)
	{
		return "";
	}
	else
	{
		return substr($s,0,$i);
	}
}

sub prhex {
	# print hex
	# $n is number of bits
	# $v is value
	my $n = shift;
	my $v = shift;
	my $s;
	if($n == 0)
	{
		return "";
	}
	elsif($n<5)
	{
		$s = sprintf("%01X", $v);	
	}
	elsif($n<9)
	{
		$s = sprintf("%02X", $v);
	}
	elsif($n<13)
	{		
		$s = sprintf("%03X", $v);
	}
	elsif($n<17)
	{		
		$s = sprintf("%04X", $v);
	}
	elsif($n<21)
	{
		$s = sprintf("%05X", $v);
	}
	elsif($n<25)
	{						
		$s = sprintf("%06X", $v);
	}
	elsif($n<29)
	{		
		$s = sprintf("%07X", $v);
	}
	elsif($n<33)
	{
		$s = sprintf("%08X", $v);
	}
	# print "$s ";
	return $s;
}

sub proct
{
	# convert 16bit number into an  octal string
	my $n=shift;
	$n=$n & 0xFFFF;
	my $d1=$n >> 15 + "0";
	my $d2= (($n >> 12) & 0x7) + "0";
	my $d3= (($n >>  9) & 0x7) + "0";
	my $d4= (($n >>  6) & 0x7) + "0";	
	my $d5= (($n >>  3) & 0x7) + "0";	
	my $d6= ($n & 0x7) + "0";
	return " " . $d1 . $d2 . $d3 . $d4 . $d5 . $d6;
}

sub prdec
{
	# print number
	# $n is number of digits (string)
	# $v is value
	my $n = shift;
	my $v = shift;
	my $s;
	my $format="\%0" . $n . "d";
	$s = sprintf($format, $v);
	# print "$s ";
	return "  $s  ";
}

sub error
{
	my $es = shift;
	$nerr = $nerr + 1;
	if($pass == 1)
	{
		print prdec("4", $ln) . "$line    *** $es\n";
	}
	else
	{
		list(0, prdec("4", $ln) . " ************* $es *");
	}	
}

sub label
{
	my $s;
	return "" if $f1 eq "";
	if($s=symbol($f1))
	{
		if($sym{$s} eq undef)
		{
			$sym{$s} = $p;           # default value of symbol = location address
			$symtype{$s} = $mode; 
			if($DEBUG) {print "sym:$s. mode:$mode. value:" . proct($sym{$s}) . "\n";}  
			return $s;
		}
		else
		{
			error("Error: Label field contains a double defined symbol $s ,or is not allowed");
		}
	}
	else
	{
		error("Error: Label $f1 not a valid symbol, or is not allowed");
	}
	return "";
}

# scan whether $s contains a valid symbol
# 1st char must be alpha 
# next chars alpha|digit
sub symbol
{
	my $s=shift;
	my $l = length($s);
	my $c;
	my $i;
	my $result="";
	if($l > $symlength)
	{
		return "";
	}
	$i=0;
	if($l>=1) # minimal 1 character
	{
		$c=substr($s,0,1);           # get 1st character
		if($c =~ /[A-Z]/)
		{
			# 1st character OK
			$result=$result . $c;
			$i=1;
			while($i < $l)
			{
				$c=substr($s,$i,1); # next character
				$i=$i+1;
				if($c =~ /[A-Z0-9]/)   #/[A-Z0-9]/ 
				{
					$result=$result . $c;
				}
				else
				{
					return "";      # not a valid symbol
				}
			}
			return $result;
		}
	}
	return "";  # not a valid symbol
}
	
# output listing record
sub list
{
	my $ln = shift;			# source input record number
	my $ls = shift;			# string to list
	my $l=0;
	my $s;
	
	# new page ? output listing header on the new page 
	if($lp == 0)
	{
		if($conlist) {print "\n\n\n";}
		print LIST "\n\n\n";
		$l = length($header);
		$s = spaces(22) . $header . spaces(88-22-$l-19) . "PAGE" . prdec(4,$page);
		if($conlist) {print $s;}
		print LIST $s;
		if($conlist) {print "\n\n\n";}
		print LIST "\n\n\n";
		$page = $page + 1;			# page number
		$lp = 3;
	}
	if($ln == 0)
	{
		# just output the string
		$s = $ls;
	}
	else
	{
		# output an assembled record
		# $s = prdec(4,$ln) . spaces(14) . $ls;
		$s = prdec(4,$ln) . $ls;
	}
	if($conlist) {print $s;}
	print LIST $s;
	if($conlist) {print "\n";}
	print LIST "\n";
    $lp = $lp + 1;
	if($lp == $lpmax)
	{
		$lp = 0;			# reset internal line counter to force a new page
	}
}

# generate a string of n spaces
sub spaces
{
	my $n = shift;
	my $i = 0;
	my $s = "";
	while($i < $n)
	{
		$s = $s . " ";
		$i = $i + 1;
	}
	return $s;
}
######################### expression evaluator ###############################
# provide next character of the expression string
sub nextchar
{
	my $c;
	if($ei < $les)
	{
		$c = substr($es,$ei,1);
		if($DEBUG) {print "nextchar1:$c.\n";} 		
		$ei = $ei + 1;
		return $c;
	}
	else
	{
		if($DEBUG) {print "nextchar2: \n";} 				
		return " ";
	}
}

# peek next character of the expression string
sub peekchar
{
	my $c;
	if($ei < $les)
	{
		$c = substr($es,$ei,1);
		if($DEBUG) {print "peek1:$c.\n";} 
		return $c;
	}
	else
	{
		if($DEBUG) {print "peek2: .\n";} 	
		return " ";
	}
}

# convert octal string in expression to binary
sub cvoct
{
	my $r=0;
	my $d=0;
	my $c;
	if( ($c = peekchar()) =~ /[0-7]/ )	# at least 1 octal digit required
	{
		while (peekchar() =~ /[0-7]/)
		{
			$c = nextchar();
			$d = $cvdig{$c};
			$r = ($r << 3) + $d;
		}
		if ($r > 0xFFFF)
		{
			$exerr = 1;
			error("Error: Octal number (too big for 16 bit)");
			return 0;
		}
		return ($r & 0xFFFF);
	}
	else
	{
		$exerr = 1;
		error("Error: No octal number");
		return 0;
	}
}

# convert hex string in expression to binary
sub cvhex
{
	my $r=0;
	my $d=0;
	my $c;
	if( ($c = peekchar()) =~ /[0-9A-F]/ )	# at least 1 hex digit required
	{
		while (peekchar() =~ /[0-9A-F]/)
		{
			$c = nextchar();
			$d = $cvdig{$c};
			$r = ($r << 4) + $d;
		}
		if ($r > 0xFFFF)
		{
			$exerr = 1;
			error("Error in hex number (too big for 16 bit)");
			return 0;
		}
		return ($r & 0xFFFF);
	}
	else
	{
		$exerr = 1;
		error("Error in hex number");
		return 0;
	}
}

# convert decimal string in expression to binary
sub cvdec
{
	my $r=0;
	my $c;
	if( ($c = peekchar()) =~ /[0-9]/ )	# at least 1 digit required
	{		
		while ( (peekchar()) =~ /[0-9]/)
		{
			$c = nextchar();
			$c = $cvdig{$c};
			$r = $r * 10 + $c;
		}
		if ($r > 0xFFFF)
		{
			$exerr = 1;
			error("Error: Decimal number (too big for 16 bit)");
			return 0;
		}
		return ($r & 0xFFFF);
	}
	else
	{
		$exerr = 1;
		error("Error: No decimal number");
		return 0;
	}
}

# calculate a single 16 bit value from an octal number specification in the operand field (field3)
# [+|-][']0..7.. | [+|-]predefined symbol
sub evaloct
{
	my $c;
	my $sign = '+';
	my $systr = "";
	my $r;	
	$es = shift;			       # expression string
	$les = length($es);      # length expression string
	$ei = 0;                 # char index in expression string
  $eval = 0;               # result
  $etype = "";             # A = Absolute, "!" = Error
	$exerr = 0;              # reset error flag	
	if($DEBUG){print "expr-in1:$es.ei.$ei.les.$les.\n";}
	if($les <= 0)
	{
		$exerr = 1;
		error("Error: Expected octal number is missing in operand");
	}
	if($DEBUG){print "expr-in2:$es.ei.$ei.les.$les.exerr.$exerr\n";}
	# expressing must start with either: [0-7] or ' or + or - or [A-Z]
	$systr = "";
	$c = peekchar();
	# 		
	if($c eq '+')
	{
		$sign = '+';
		$c=nextchar();
	  $c=peekchar();			
	}
	if($c eq '-')
	{
		$sign = '-';
		$c=nextchar();
		$c=peekchar();
	}
	if($c eq '\'')
	{
		# octal number
		$c=nextchar(); # skip
		if($sign eq '+')
		{
			$eval = cvoct();
		}
		else
		{
			$eval = - cvoct();
		}			
	}
	else
	{
		if($c =~ /[0-7]/)
		{
			# octal number
			if($sign eq '+')
			{
				$eval = cvoct();
			}
			else
			{
				$eval = - cvoct();
			}					
		}
		else
		{
			if( $c =~ /[A-Z]/)
			{
				# symbol
				$c=nextchar();
				$systr=$c;
				while( peekchar() =~ /[A-Z0-9]/ )
				{
					$c = nextchar();
					$systr = $systr . $c;
				}
				if(length($systr) > $symlength)
				{
					$exerr = 1;
					error("Error: Symbol $systr in operand longer than $symlength characters");
				}
				if($sym{$systr} ne undef)
				{
					if($sign eq '+')
					{
						$eval = $sym{$systr};
					}
					else
					{
						$eval = - $sym{$systr};
					}
				}						
				else
				{
					$exerr = 1;
					error("Error: Symbol $systr in operand undefined");
				}
			}
			else
			{
					$exerr = 1;
					error("Error: Malformed octal operand");
			}
		}
	}
	if($exerr)
	{
		$etype = '!';
	}
	else
	{
		$etype = 'A';
	}
  if($DEBUG){print "evaloct-out:" . proct($eval & 0xFFFF) . " type:" . $etype . "\n";}
	return ($eval = ($eval & 0xFFFF));
}															

# calculate a single 16 bit value from a decimal number specification in the operand field (field3)
# [+|-]0..9.. | [+|-]predefined symbol
sub evaldec
{
	my $c;
	my $sign = '+';
	my $systr = "";
	my $r;	
	$es = shift;			       # expression string
	$les = length($es);      # length expression string
	$ei = 0;                 # char index in expression string
  $eval = 0;               # result
  $etype = "";             # A = Absolute, "!" = Error
	$exerr = 0;              # reset error flag	
	if($DEBUG){print "expr-in1:$es.ei.$ei.les.$les.\n";}
	if($les <= 0)
	{
		$exerr = 1;
		error("Error: Expected decimal number is missing in operand");
	}
	if($DEBUG){print "expr-in2:$es.ei.$ei.les.$les.exerr.$exerr\n";}
	# expressing must start with either: [0-7] or ' or + or - or [A-Z]
	$systr = "";
	$c = peekchar();
	# 		
	if($c eq '+')
	{
		$sign = '+';
		$c=nextchar();
	  $c=peekchar();			
	}
	if($c eq '-')
	{
		$sign = '-';
		$c=nextchar();
		$c=peekchar();
	}
	if($c =~ /[0-9]/)
	{
		# octal number
		if($sign eq '+')
		{
			$eval = cvdec();
		}
		else
		{
			$eval = - cvdec();
		}					
	}
	else
	{
		if( $c =~ /[A-Z]/)
		{
			# symbol
			$c=nextchar();
			$systr=$c;
			while( peekchar() =~ /[A-Z0-9]/ )
			{
				$c = nextchar();
				$systr = $systr . $c;
			}
			if(length($systr) > $symlength)
			{
				$exerr = 1;
				error("Error: Symbol $systr in operand longer than $symlength characters");
			}
			if($sym{$systr} ne undef)
			{
				if($sign eq '+')
				{
					$eval = $sym{$systr};
				}
				else
				{
					$eval = - $sym{$systr};
				}
			}						
			else
			{
				$exerr = 1;
				error("Error: Symbol $systr in operand undefined");
			}
		}
		else
		{
				$exerr = 1;
				error("Error: Malformed decimal operand");
		}
	}
	if($exerr)
	{
		$etype = '!';
	}
	else
	{
		$etype = 'A';
	}
	if($DEBUG){print "evaldec-out:" . proct($eval & 0xFFFF) . " type:" . $etype . "\n";}
	return ($eval = ($eval & 0xFFFF));	
}

# evalexpr
# ========
# Calculates a 16 bit absolute value for an expression (-32768 .. 32767) in the operand field (field3)
#
# <expr> =:: [+|-]<term>[+|-<term>[+|-<term>]]
# <term> =:: <number> | <symbol>
#
# <number> =:: <decimal number> | <octal number> | <hex number>
# <decimal number> =:: 1 or more digits 0..9
# <octal number>   =:: <quote> followed by 1 or more digits 0..7
# <hex number>     =:: <dollar> followed by 1 or more digits 0..F
# # 
# <symbol> ::= * | ** | identifier of 1 upto 4 characters starting with an alpha and representing a location address value
# two special symbols:
#  *       ::= current value of location counter
#  **      ::= 0
#
sub evalexpr
{
	my $c;
	my $sign = '+';
	my $systr = "";
	my $r;
	my $x;
	my $nterm=3; # three terms max
	my $term;   
	
	$es = shift;			       # expression string
	$les = length($es);      # length expression string
	$ei = 0;                 # char index in expression string
  $eval = 0;               # result
  $etype = "";             # A = Absolute, "!" = Error
	$exerr = 0;              # reset error flag

	if($DEBUG){print "expr-in1:$es.ei.$ei.les.$les.\n";}
	if($les <= 0)
	{
		$exerr = 1;
		error("Error: Expected expression is missing in operand");
	}
	if($DEBUG){print "expr-in2:$es.ei.$ei.les.$les.exerr.$exerr\n";}
		
	$term=$nterm;
	# expressing must start with either: *, or [A-Z] or [0-9] or ' or $ or + or -
	while(($ei < $les) && ($exerr == 0) && ($term > 0))
	{
		$systr = "";
		$c = peekchar();

		# process term		
		if($c eq '+')
		{
			$sign = '+';
			$c=nextchar();
		  $c=peekchar();			
		}
		if($c eq '-')
		{
			$sign = '-';
			$c=nextchar();
			$c=peekchar();
		}					
		if($c eq '*' )
		{
			nextchar();
			$c = peekchar();
			if($c eq '*')
			{
				nextchar();
				$c = peekchar();
				if($c eq ' ' || $c eq '+'|| $c eq '-')      # symbol ** 
				{
					$eval = $eval + 0;
				}
				else
				{
					$exerr = 1;
					error("Error: invalid symbol **...");				
				}
			}
			elsif($c eq ' ' || $c eq '+'|| $c eq '-')        # symbol * 
			{
				if($sign eq '+')
				{
					$eval = $eval + $p;
				}
				else
				{
					$eval = $eval - $p;
				}
			}
			else
			{
				$exerr = 1;
				error("Error: invalid symbol *...");			
			}
		}
		elsif($c eq '\'')
		{
			# octal number
			$c=nextchar(); # skip
			if($sign eq '+')
			{
				$eval = $eval + cvoct();
			}
			else
			{
					$eval = $eval - cvoct();
			}			
		}
		elsif($c eq '$')
		{
			# hex number
			$c=nextchar(); # skip $
			if($sign eq '+')
			{
				$eval = $eval + cvhex();
			}
			else
			{
				$eval = $eval - cvhex();
			}					
		}		
		elsif($c =~ /[0-9]/)
		{
			# decimal number
			if($sign eq '+')
			{
				$eval = $eval + cvdec();
			}
			else
			{
				$eval = $eval - cvdec();
			}					
		}
		elsif( $c =~ /[A-Z]/)
		{
			# symbol
			$c=nextchar();
			$systr=$c;
			while( peekchar() =~ /[A-Z0-9]/ )
			{
				$c = nextchar();
				$systr = $systr . $c;
			}
			if(length($systr) > $symlength)
			{
				$exerr = 1;
				error("Error: Symbol $systr in operand longer than $symlength characters");
			}
			if($sym{$systr} ne undef)
			{
				if($sign eq '+')
				{
					$eval = $eval + $sym{$systr};
				}
				else
				{
					$eval = $eval - $sym{$systr};
				}						
			}
			else
			{
				$exerr = 1;
				error("Error: Symbol $systr in operand undefined");
			}				
		}
		else
		{
				$exerr = $nterm - $term + 1;
				error("Error: Term $exerr in operand expression malformed");
		}			
		# term must be followed by either 'nothing', or a + or - to introduce the next term (or , for BCI)
		$term=$term+1;
		$c = peekchar();
		if($c eq ' ')
		{
			last;
		}
		elsif($c eq '+')
		{
			next;
		}
		elsif($c eq '-')
		{
			next;		
		}
		if($c eq ',')
		{
			last;
		}		
		else
		{
			$exerr = 1;
	  	error("Error: Malformed operand expression");
		}		
	}

	if($exerr)
	{
		$etype = '!';
	}
	else
	{
		$etype = 'A';
	}
  if($DEBUG){print "expr-out:" . proct($eval & 0xFFFF) . " type:" . $etype . "\n";}
	return ($eval = ($eval & 0xFFFF));
}

########################### operand syntax scanner #########################
sub scan
{
	my $o = shift;           # operation code
	my $t = shift;           # operand template
	my $s = shift;           # operand to scan
	
	my $t1;                  # t1,t2 template parts
	my $t2;
	
	my $p1;                  # p1,p2 operand parts
	my $p2;

	my $l;
	
	($t1,$t2) = split(/\,/, $t);  # split template
	($p1,$p2) = split(/\,/, $s);  # split operand
	if($DEBUG){print "t1:$t1.t2:$t2.\n";}
	if($DEBUG){print "p1:$p1.p2:$p2.\n";}	
	$oty = '';
	# scan part 1
	$l = length($t1);
	if($l>0)
  {
		if($t1 eq 'm')
		{
			$m = evalexpr($p1);
			$oty = $etype;
		}
		elsif($t1 eq 'sc')
		{
      $sc = evalexpr($p1);
 			$oty = $etype;
 			if($sc > 32)
 			{
 				error("Error: Shift Count bigger than 32");
 			}    	
	  }	
		elsif($t1 eq 'da')
		{
	    $da = evalexpr($p1);
 			$oty = $etype;
 			if($da > 1023)
 			{
 				error("Error: Device Address/Function bigger than 1023 (10 bit)");
 			}  			   	
	  }			
		else
		{
			error("Error: Operand expected");
		}
	}
	else
	{
		if($p1 eq '')
		{
			# instruction without 1st operand, ok
			;
		}
		else
		{
			error("Error: No operand expected");
		}
	}

	# scan part 2
	$l = length($t2);
	if($l>0)
  {
		if($t2 eq '@1')
		{
			if($p2 eq "1")
			{
				$tag = 1;
			}
			elsif($p2 eq undef)
			{
				$tag = 0;
			}
			else
			{
				error("Error: Wrong index used");
			}		
		}
	}
	else
	{
		if($p2 ne '')
		{
			error("Error: No 2nd operand field expected")
		}
		return;
	}
}

#$I{"JMP"}      = 'm,@1'; $G{"JMP"}     = '0.t.0001.p.sa';
#$I{"LDX"}      = 'm';    $G{"LDX"}     = '010111.p.sa';
#$I{"LRL"}      = 'sc';   $G{"LRL"}     = '0100000000.csc';
#$I{"TCA"}      = '';     $G{"TCA"}     = '1100001100000111';
#$I{"OCP"}      = 'da';   $G{"OCP"}     = '001100.da';

####################### code generator ##########################
# generator of word 1
sub gen1 {
	my $s = shift;
	my $c1;
	my $c2;
	my $c3;
	my $c4;
	my $c5;
	my $w=0;
	my $l;
	my $i;
	my $b;
	($c1,$c2,$c3,$c4,$c5) = split(/\./, $s);
	if($DEBUG){print "gw1--c1:$c1.c2:$c2.c3:$c3.c4:$c4.c5:$c5.\n";}
		
	# part 1
	$l = length($c1);
	if($l>0)
  {
		for($i=0; $i<$l; $i++)
		{
			$c=substr($c1,$i,1);
			if($c eq '0')
			{
				$b = 0;
			  $w = $w << 1;
			  $w=$w+$b;				
			}
			elsif($c eq '1')
			{
				$b = 1;
			  $w = $w << 1;
			  $w=$w+$b;				
			}
			else
			{
			  error("Error: Code gen error w part1 $c1");	
			}	
		}
	}
	
	# part 2
	$l = length($c2);
	if($l>0)
	{
		if($c2 eq 't')     # tag bit?
		{
			$w = $w << 1;
			$w = $w + $tag;
		}
		elsif($c2 eq 'p')  # page bit?(LDX/STX)
		{	
			$w = $w << 1;
			if($m < 512)
			{
				# address in sector 0 => page bit is 0
				$sa=$m & 0x01FF; # save sector address part of operand			
				$pagebit=0;
			}
			else
			{
				# sector address PC and operand (m) equal?
				if( ($p & 0xFC00) == ($m & 0xFC00))
				{
					# yes, => set page bit to 1
					$pagebit=1;
					$w=$w+1;
					$sa=$m & 0x01FF; # save sector address part of operand
				}
				else
				{
					# error
					error("Error: Operand address not in current sector or sector 0");
				}
			}
		}
		elsif($c2 eq 'csc')
		{	
			$w = $w << 6;
			$sc= ((~ $sc) + 1) & 0x003F; # two complement of shift count 
			$w = $w + $sc;
		}
		elsif($c2 eq 'da')
		{
			$w = $w << 10;
			$w = $w + $da;
		}
		elsif($c2 eq 'm') # EAC and EAC*: m is extended address (15 bit)
		{
			$w = $w << 15;
			# $w = ($w & 0xC000) + ($m & 0x3FFF);
			# sometimes a negative address is used, so
			$w = $w | $m;
		}		
		else
		{
			error("Error: Code gen error w part2 $c2");
		}
	}
	
	# part 3
	$l = length($c3);
	if($l>0)
    {
		if($c3 eq 'sa')
		{
			$w = $w << 9;
			$w = $w + $sa;
		}
		elsif($c3 eq 'm')
		{
			$w = $w << 14;
			# $w = ($w & 0xC000) + ($m & 0x3FFF);
			# sometimes in DAC a negative address is used, so
			$w = $w | $m;
		}  
		else
		{
			for($i=0; $i<$l; $i++)
			{
				$c=substr($c3,$i,1);
				if($c eq '0')
				{
					$b = 0;
					$w = $w << 1;
					$w=$w+$b;				
				}
				elsif($c eq '1')
				{
					$b = 1;
				  $w = $w << 1;
				  $w=$w+$b;					
				}
				else
				{
				  error("Error: Code gen error w part3 $c3");	
				}			
			}
		}
	}
	
	# part 4
	$l = length($c4);
	if($l>0)
  {
		if($c4 eq 'p')
		{
			$w = $w << 1;
			if($m < 512)
			{
				# address in sector 0 => page bit is 0
				$sa=$m & 0x01FF; # save sector address part of operand				
				$pagebit=0;
			}
			else
			{
				# sector address PC and operand (m) equal?
				if( ($p & 0xFC00) == ($m & 0xFC00))
				{
					# yes, => set page bit to 1
					$pagebit=1;
					$w=$w+1;
					$sa=$m & 0x01FF; # save sector address part of operand
				}
				else
				{
					# error
					error("Error: Operand address not in current sector or sector 0");
				}
			}			
		}
		else
		{
			error("Error: Code gen error w part4 $c4");
		}
	}
	
	# part 5
	$l = length($c5);
	if($l>0)
  {
		if($c5 eq 'sa')
		{
			$w = $w << 9;
			$w = $w + $sa;
		}
		else
		{
			error("Error: Code gen error w part5 $c5");
		}
	}
	return $w;
}