'$INCLUDE: 'incutil.bi'
'$INCLUDE: 'incsym.bi'
'$INCLUDE: 'incerror.bi'
'$DYNAMIC
DEFINT A-Z
DECLARE FUNCTION AddArray2List% (nm AS STRING)
DECLARE FUNCTION AddConst2List% (nm AS STRING, vartype AS INTEGER, CValue AS LONG)
DECLARE FUNCTION AddFunction2List% (nm AS STRING)
DECLARE FUNCTION AddType2List% (nm AS STRING)
DECLARE FUNCTION AddVar2List% (nm AS STRING, vartype AS INTEGER)
DECLARE SUB AllocData (class AS INTEGER, id AS INTEGER)
DECLARE SUB Asm.Epilog ()
DECLARE FUNCTION Asm.GetMemPtrNm$ (size AS INTEGER)
DECLARE SUB Asm.PutLabel (LabelNum AS INTEGER)
DECLARE SUB Asm.Prolog ()
DECLARE SUB Compile.Main ()
DECLARE SUB Compile.Start (InFileName AS STRING, OutFileName AS STRING)
DECLARE SUB ConvertType (Eq AS INTEGER, typeid AS INTEGER)
DECLARE SUB DecrScope ()
DECLARE SUB Do.Do ()
DECLARE SUB Do.Else ()
DECLARE SUB Do.ElseIf ()
DECLARE SUB Do.Exit (StructType AS INTEGER)
DECLARE SUB Do.For ()
DECLARE SUB Do.Function ()
DECLARE SUB Do.If ()
DECLARE SUB Do.Return ()
DECLARE SUB Do.Select ()
DECLARE SUB Eq.Asm.AccessAry (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.ANDORXOR (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Assign (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.CMP (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Div (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.FuncCall (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Minus (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Mod (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Mul (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Neg (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.NOT (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.Add (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.PushParam (OpIdx AS INTEGER)
DECLARE SUB Eq.Asm.ZeroTest (idx AS INTEGER)
DECLARE SUB Eq.Debug.List ()
DECLARE SUB Eq.Debug.Print (n AS INTEGER)
DECLARE SUB Eq.Debug.Remake (StartIndex AS INTEGER)
DECLARE SUB Eq.DelToken (n AS INTEGER)
DECLARE FUNCTION Eq.FindFreeToken% ()
DECLARE FUNCTION Eq.FindNextOp% (FromEq AS INTEGER)
DECLARE FUNCTION Eq.GetCmpName$ (RelOp AS INTEGER, Inverse AS INTEGER)
DECLARE FUNCTION Eq.GetTempVarNm$ (id AS INTEGER, size AS INTEGER)
DECLARE SUB Eq.GetTokens (BYVAL InstrStart AS INTEGER, BYVAL InstrEnd AS INTEGER, BYVAL basis AS INTEGER)
DECLARE FUNCTION Eq.InsertToken% (NewToken AS ANY, BYVAL AfterOrBefore AS INTEGER, BYVAL idx AS INTEGER)
DECLARE FUNCTION Eq.LValue% (Eq AS INTEGER)
DECLARE SUB Eq.Postprocess (StartIndex AS INTEGER)
DECLARE SUB Eq.ResetForBuild ()
DECLARE SUB Eq.SaveAsTempVar (idx AS INTEGER)
DECLARE FUNCTION Eq.Solve.Term% (OpIdx AS INTEGER)
DECLARE SUB Eq.Solve.Whole (BYVAL OpIdx AS INTEGER, BYVAL basis AS INTEGER)
DECLARE SUB Eq.SwapInfo (l AS INTEGER, r AS INTEGER)
DECLARE FUNCTION Eq.TypeMatch% (Op AS INTEGER, Ref AS INTEGER)
DECLARE SUB Equation (modus AS INTEGER, where AS INTEGER, InstrStart AS INTEGER, InstrEnd AS INTEGER, TrueLabel AS INTEGER, FalseLabel AS INTEGER)
DECLARE FUNCTION GetAsmValNm$ (ViaEq AS INTEGER, idx AS INTEGER, class AS INTEGER, id AS INTEGER)
DECLARE FUNCTION GetAsmValNm.Eq$ (i AS INTEGER)
DECLARE FUNCTION GetAsmValNm.I$ (i AS INTEGER)
DECLARE SUB GetInstructFromFile ()
DECLARE FUNCTION GetLabelNm$ (LabelNum AS INTEGER)
DECLARE SUB GetNextInstruction ()
DECLARE FUNCTION GetTokenName$ (t AS INTEGER)
DECLARE SUB IdentifyToken (nm AS STRING, fromScope AS INTEGER, retToken AS ANY)
DECLARE SUB IncrOpenStructs ()
DECLARE SUB Init ()
DECLARE FUNCTION IsLiteral% (str AS STRING)
DECLARE SUB LegalName (str AS STRING)
DECLARE FUNCTION NewLabel% ()
DECLARE SUB OutAsmLn (t AS STRING)
DECLARE SUB OutCode (t AS STRING)
DECLARE SUB OutData (t AS STRING)
DECLARE SUB P.Const ()
DECLARE SUB P.ConstAssign ()
DECLARE SUB P.Dim ()
DECLARE SUB P.FuncParameter ()
DECLARE SUB P.Init ()
DECLARE FUNCTION P.Match% (TokClass AS INTEGER, TokIdx AS INTEGER)
DECLARE SUB P.Need (TokClass AS INTEGER, TokIdx AS INTEGER)
DECLARE SUB P.NextToken ()
DECLARE FUNCTION P.TypeOfIdent% ()
DECLARE SUB P.VarTyping ()
DECLARE FUNCTION Reg.AssignEq% (ReqReg AS INTEGER, EqElem AS INTEGER)
DECLARE SUB Reg.Debug.Print ()
DECLARE FUNCTION Reg.IsFree% (WhichReg AS INTEGER)
DECLARE FUNCTION Reg.MakeFree% (ReqReg AS INTEGER)
DECLARE SUB Reg.Push (r AS INTEGER)
DECLARE SUB Reg.SetFree (RegNum AS INTEGER)
DECLARE SUB Reg.SetUsed (RegNum AS INTEGER, EqUser AS INTEGER)
DECLARE SUB ReScanUnknownTok ()
DECLARE SUB Scan.Instruction ()

CONST True = -1, False = 0

CONST VarExt = "%&!#$"
CONST Comma = ","
CONST ISsign = "="
CONST Alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
CONST Numbers = "0123456789"

'Used in EqParts array signalling
CONST Link = -1, BOC = -1, EOC = -1    'New/Beginning/End Of Chain

CONST AddAt = 1        '\
CONST AddBefore = 2    ' Used in signalling with Eq.InsertToken
CONST AddAfter = 3     '/

'Tells Equation what it's current equation is: an assignment or a condition
CONST JustDoItEq = 0
CONST AssignEq = 1
CONST ConditionEq = 2

' Constants used in signalling to Equation to tell it if it should reread
' EqParts() from InstrParts() or use EqParts() as already available.
CONST FromInstr = 1
CONST DirectFromEq = 2

CONST SyntaxErrStr = "Syntax error : "
CONST OpTypesErrStr = "An operation on these different types is not allowed."

TYPE InstrToken       ' Descriptor of elements (tokens) of a instruction:
	class AS INTEGER    '  * class of token : var,sub,function,operator ..
	id AS INTEGER       '  * index number in array which describes tokens
						'    of that class
	vartype AS INTEGER  '  * variable type of token
	intval AS LONG      '  * contains integer value if the eq token is an
						'    integer literal or a integer constant
	PosInStr AS INTEGER '  * position of token in instruction string  \ used to init
	TokenStrLen AS INTEGER'* length of string representation of token / unknown names
	symptr AS INTEGER   '  * index of token into symbol table
END TYPE

TYPE EqToken          'Describes tokens in equation:
	class AS INTEGER    '* class of token : var,sub,function,operator ..
	id AS INTEGER       '* index number in array which describes tokens
						'  of that class
	vartype AS INTEGER  '* defines type of token (byte, int, long)
	nextp AS INTEGER    '* index to next equation part, if EOC then no parts
						'  left; Needed because of switching of parameters
						'  to make most efficient code
	prev AS INTEGER     '* index to next eq. part, if BOC then at begin
	extra AS INTEGER    '* index to extra eq. part if class = Link.
	basis AS INTEGER    '* index number where the link to current chain can
						'  be found.
	intval AS LONG      '* contains integer value if the eq token is an
						'  integer literal or a integer constant
	symptr AS INTEGER   '* index of token into symbol table
END TYPE

TYPE VarInfoType          'Describes some features of variables
	 vartype AS INTEGER   '* defines type of var (byte, int, long etc.)
	 scope AS INTEGER     '* defines scope of var (local, global)
	 storage AS INTEGER   '* defines mode of access to var (static,
						  '  on stack, byref or byval parameter)
	 stackptr AS INTEGER  '* place relative to stack, used for args and local vars
	 symptr AS INTEGER    '* index of operator in symbol table
END TYPE
'modes of variable storage
CONST GlobalVar = 0     '.storage is set in AddVar2List to Global- or
CONST LocalVar = 1      'LocalVar. Other .storage types must be set "manually"
CONST StaticVar = 2
CONST ByRefParam = 3
CONST ByValParam = 4
CONST TempVar = 5       '**not yet implemented: still an apart class**

TYPE FunctionDescriptType   'Describes general features of function
	 vartype AS INTEGER     '* defines returning type of function (byte, int, long)
	 scope AS INTEGER       '* scope of function
	 NumArgs AS INTEGER   '* number of parameters
	 ArgLstPtr AS INTEGER   '* ptr into FuncArgInfo array to first parameter
	 ExitLabel AS INTEGER   '* label in front of function exit code
	 Bytes2Pass AS INTEGER  '* total bytes needed to pass all parameters
	 StackAlloc AS INTEGER  '* bytes to allocate on stack for local variables
	 symptr AS INTEGER      '* index of function in symbol table
END TYPE

TYPE FuncArgListType       'Describes the features of function parameters
	 PassMode AS INTEGER   '* way of passing of variable to function
						   '  (by value, by reference)  NOT USED YET
	 Bytes2Pass AS INTEGER '* bytes needed to pass param, depends on PassMode
	 vartype AS INTEGER    '* type of parameter to be passed
	 VarInfoPtr AS INTEGER '* index of parameter name into variable name table
						   '  and into variable descriptor, for further info
END TYPE

TYPE OperatorInfoType       'Describes some features of the operators
	 SideMatters AS INTEGER '* boolean, if true then exchange of
							'  parameters results in different results
	 priority AS INTEGER    '* lower number has higher priority; min. = 1
	 OperandSide AS INTEGER '* describes on which side the operand(i) of
							'  the operator are  -1 : 1 operand at the left
							'                     0 : 2 operands left+right
							'                     1 : 1 operand at the right
	 symptr AS INTEGER      '* index of operator in symbol table
END TYPE

TYPE RegsInfoType           'Describes some features of the registers
	 InUse    AS INTEGER    '* if set then reg is being used by some token
	 UsedBy   AS INTEGER    '* pointer to token of eq using the register
	 'comment: size of register in bytes is stored in the RegSize array and not
	 '         here to prevent erasure of this info when resetting this array.
END TYPE

TYPE ConstInfoType     ' Describes some features of constants
	 intval AS LONG      '* contains integer value of the constant
	 vartype AS INTEGER  '* defines type of constant (byte, int, long)
	 scope AS INTEGER    '* scope of constant
	 symptr AS INTEGER   '* index of constant in symbol table
END TYPE

TYPE TypeInfoType         'Describes some features of constants
	 class AS INTEGER     '* class: numerical (=NumType) or something else (=0)
	 size  AS INTEGER     '* size of data structure
	 scope AS INTEGER     '* scope of type
	 symptr AS INTEGER    '* index of constant in symbol table
END TYPE
CONST NumType = 1

TYPE ArrayInfoType        'Structure for array info
	 scope AS INTEGER
	 vartype AS INTEGER
	 storage AS INTEGER   '* storage of array (static (includes global),local,
						  '  byref or byval parameter: not implemented yet)
	 stackptr AS INTEGER  '* place relative to stack, used for args and local vars
	 dims AS INTEGER      '* amount of dimensions in array
	 dimptr AS INTEGER    '* index into dimension array to first dimension of array
	 symptr AS INTEGER
END TYPE

TYPE DimInfoType   'Structure for dimension info of arrays
	 lb AS INTEGER        '* lower boundary of dimension
	 ub AS INTEGER        '* upper boundary
	 mul AS INTEGER       '* value to multiply with the offset of each dim to
						  '  get dimension base offset
	 aryptr AS INTEGER    '* pointer to array to which this dimension descriptor belongs
END TYPE

TYPE StructuresInfoType    ' Describes the features of a structure to be used
						   ' in a "stack" array holding info about structures
	 sort AS INTEGER       '  * sort of structure: if, for..next, do..loop
	 StartLabel AS INTEGER '  * label number at beginning of structure
	 ContinueLabel AS INTEGER'  * extra label number
	 ExitLabel AS INTEGER   '  * label number at end of structure
END TYPE
CONST IfStruct = 1
CONST ForNextStruct = 2
CONST DoLoopStruct = 3
CONST SubStruct = 4
CONST FunctionStruct = 5
CONST SelectStruct = 6

'$STATIC
DIM SHARED InstrParts(1 TO 200) AS InstrToken

'\\ number of tokens currently in InstrParts array
DIM SHARED TotInstrTokens AS INTEGER

'\\ index of token into InstrParts array currently looked at
DIM SHARED CurTok AS INTEGER

'\\ flag which is set if there is no next token, and reset when a new
'   instruction is divided into tokens (see Instruct
DIM SHARED NoNextToken AS INTEGER

DIM SHARED EqParts(0 TO 100) AS EqToken 'Internal array that holds the
'tokens of an equation, which is filled by Eq.GetTokens and used by other
'equation-related procedures.
DIM SHARED EqResult AS INTEGER

DIM SHARED RegInfo(1 TO 24) AS RegsInfoType 'must be static to allow for easy
											'resetting array using "erase"
'$DYNAMIC
REDIM SHARED RegSize(1 TO 24) AS INTEGER

'// arrays that contain features of the tokens of the language
REDIM SHARED OperatorInfo(1 TO 25) AS OperatorInfoType
REDIM SHARED ConstInfo(1 TO 200) AS ConstInfoType
REDIM SHARED VarInfo(1 TO 200) AS VarInfoType
REDIM SHARED TypeInfo(1 TO 200) AS TypeInfoType

REDIM SHARED ArrayInfo(1 TO 50) AS ArrayInfoType  'array descriptors
REDIM SHARED DimInfo(1 TO 75) AS DimInfoType
DIM SHARED DimInfoTop AS INTEGER

'// arrays containing information about of defined functions, vars, types, etc.
REDIM SHARED FuncDescript(1 TO 100) AS FunctionDescriptType
REDIM SHARED FuncArgInfo(1 TO 2000) AS FuncArgListType
DIM SHARED ParamInfoTop AS INTEGER

' "Stack" containing opened structures (if,for,do,etc.)
REDIM SHARED StructStack(1 TO 30) AS StructuresInfoType
DIM SHARED OpenStructs AS INTEGER    'total number of opened structures


'// array for internal database of symbols
SymTableSize = funFirstPrime(200)

'// part of internal database of symbols: tells how much tokens each class
'   of symbols has
DIM SHARED totKeyWords AS INTEGER, totTypes AS INTEGER
DIM SHARED totFunctions AS INTEGER, totOperators AS INTEGER
DIM SHARED totConstants AS INTEGER, totVars AS INTEGER
DIM SHARED totArrays AS INTEGER

DIM SHARED EndOfSource AS INTEGER
DIM SHARED InputFileHandle AS INTEGER 'global integer containing current inputfile
DIM SHARED OutputFileHandle AS INTEGER

DIM SHARED CurScope AS INTEGER
DIM SHARED CurFunc AS INTEGER      'current function

'\\ Variables having to do with the general bookkeeping needed for the
'   generated assembler code
DIM SHARED CurSeg AS INTEGER
	CONST DataSeg = 1
	CONST CodeSeg = 2

DIM SHARED SpRelToBP AS INTEGER       'SP pointer relative to BP
DIM SHARED TmpSpaceAllocated AS INTEGER  'total bytes to be reserved for temporary
									  'variables used by for..next and case
									  'structures and to temporaraly store
									  'results of equations
DIM SHARED FreeTmpSpacePtr AS INTEGER 'Pointer to byte number from which all
									  'all temp bytes are free. Reset to old
									  'value after each equation.
DIM SHARED DoingCondition AS INTEGER


'\\ Variables used to optimize code generation for condition tests.
DIM SHARED ConditionJumpsOptimized AS INTEGER
DIM SHARED ConditionFalseLabel AS INTEGER
DIM SHARED ConditionTrueLabel AS INTEGER
'DIM SHARED CmpFlagsReg AS INTEGER  ' contains number of reg for which flags
								   ' were set last time
'\\ Variables used in parsing of instructions.
DIM SHARED IPtr AS INTEGER         ' num of current instruction token
DIM SHARED ILook AS InstrToken   ' instruction token currently looked at

DIM SHARED cTab AS STRING * 1
DIM SHARED CrLf AS STRING * 2
  cTab = CHR$(9)
  CrLf = CHR$(13) + CHR$(10)

'\\ names of cpu registers used for code generation
DIM SHARED RegNames(1 TO 24) AS STRING

  'Do _NOT_ change the values of these constants without referring initialisation !!
  CONST AX = 1, BX = 2, cx = 3, DX = 4     'These are coupled to the stringarray
  CONST AL = 5, BL = 6, CL = 7, DL = 8     'RegNames containing their names.
  CONST AH = 9, bh = 10, ch = 11, DH = 12  'A change in their values _MUST_ be
  CONST EAX = 13, EBX = 14, ECX = 15, EDX = 16'accompanied with a similar change of
  CONST BP = 17, SI = 18, DI = 19          'the Reg array (see the label
  CONST SS = 20, DS = 21, es = 22          'RegNameData)
  CONST GenByteReg = -1
  CONST GenWordReg = -2
  CONST GenDWordReg = -3
  
  ' When adding operators make sure that operands which operate only on the
  ' left or right operands get their special .OperandSide value !!
  totOperators = 19
  CONST Negate = 1
  CONST mul = 2, Div = 3, Modulus = 4, Add = 5, minus = 6
  CONST Eq = 7, JG = 8, JL = 9, JLE = 10, JGE = 11, JNE = 12
  CONST logNOT = 13, logAND = 14, logOR = 15, logXOR = 16
  CONST Assign = 17, PushPrmOpr = 18, CallOpr = 19
  CONST ArySubOpr = 20, AryAccessOpr = 21

  totKeyWords = 23
  CONST kwREM = 1, kwDIM = 2, kwFOR = 3, kwNEXT = 4
  CONST kwDO = 5, kwLOOP = 6, kwIF = 7, kwTHEN = 8, kwELSE = 9, kwELSEIF = 10
  CONST kwEXIT = 11, kwEND = 12, kwTO = 13, kwSTEP = 14, kwCONTINUE = 15
  CONST kwUNTIL = 16, kwWHILE = 17
  CONST LP = 18, RP = 19, kwComma = 20
  CONST kwAS = 21, kwSUB = 22, kwFUNCTION = 23, kwRETURN = 24
  CONST kwCONST = 25
  CONST kwSELECT = 26, kwCASE = 27, kwSTAY = 28, kwIS = 29
  CONST kwSTOP = 30  'STOP is JUST FOR DEBUGGING PURPOSES while making this..

  CONST bytevar = 1, intvar = 2, longvar = 3
  CONST singlevar = 4, doublevar = 5
  CONST stringvar = 6
  
CONST Debugging = 0

Init
IF Debugging THEN
 CLS
 VIEW PRINT 1 TO 23   'for debugging purposes: see also Reg.Debug.Print
END IF

Compile.Start "tst.bas", "tst.asm"
SHELL "l tst.asm"
'SHELL "a86 tst.asm +O +S"
'SHELL "masm tst.asm"
'SHELL "tasm tst.asm"
END

 'InputFileHandle = FREEFILE: OPEN "qb50.bas" FOR INPUT AS InputFileHandle
 'mcnt = 3000: t! = TIMER
 'FOR c = 1 TO mcnt: GetInstructFromFile: NEXT
 't! = TIMER - t!: PRINT t!, t! / mcnt, 1 / (t! / mcnt): END

'I wished you could initialize variables (even arrays) in basic...
'DATA is such an annoying method.

DefKeyWordNames:
	'These are predefined symbols which are put in the symbol table during
	'initialisation.
	'Order is important!! because of constants referring to these keywords,
	'as defined above.

	DATA "REM","DIM","FOR","NEXT"
	DATA "DO","LOOP","IF","THEN","ELSE","ELSEIF"
	DATA "EXIT","END","TO","STEP","CONTINUE"
	DATA "UNTIL","WHILE"
	DATA "(", ")",","
	DATA "AS","SUB","FUNCTION","RETURN"
	DATA "CONST"
	DATA "SELECT","CASE","STAY","IS"
	DATA "STOP"
	DATA ""   : ' <--------- null string signals end of the data

DefTypeNames:
	'Order is important!! because of constants referring to these keywords,
	'as defined above.
	'format: stringname, size in bytes, class

	DATA "BYTE",1,1
	DATA "INTEGER",2,1
	DATA "LONG",4,1
	DATA "SINGLE",4,1
	DATA "DOUBLE",8,1
	DATA "STRING",4,0
	DATA ""   : ' <--------- null string signals end of the data

DefOperatorNames:
	' format:  stringname, priority, operandside
	' Order is important!! because of constants referring
	' to these operators, as defined above.
	' priority: the lower the value, the higher the priority
	' operandside: position of operand(i) relative to operator
	'              0= 2 operandi at left and right side of operator
	'              1= 1 operand at right side of operator
	'              2= 1 operand at left side of operator
	DATA " NEG",1,1      : ' fake symbol name
	DATA "*", 2, 0
	DATA "/", 2, 0
	DATA "MOD",2,0
	DATA "+", 3, 0
	DATA "-", 3, 0
	DATA "=",4,0
	DATA ">",4,0
	DATA "<",4,0
	DATA " _<=_ ",4,0    : ' \
	DATA " _=>_ ",4,0    : '   fake symbol names
	DATA " _<>_ ",4,0    : ' /
	DATA "NOT",5,1
	DATA "AND",6,0
	DATA "OR",6,0
	DATA "XOR",6,0
	DATA ":=",99,0       : ' \
	DATA "pass",100,1   : '   fake
	DATA "call",0,2     : '   symbol   lowercase can never be in table
	DATA "arysub",100,1 : '   names
	DATA "@array",0,2   : ' /
	DATA "": ' <--------- null string signals end of the data

RegNameData:
	'These strings are loaded into the RegNames array .
	'Don't change the order without referring to the Reg.* functions !
	'Don't _ever_ break the a?, b?, c?, d? sequence!!

	DATA "ax", 2,"bx",2, "cx",2, "dx",2
	DATA "al",1, "bl",1, "cl",1, "dl",1
	DATA "ah",1, "bh",1, "ch",1, "dh",1
	DATA "eax",4, "ebx",4, "ecx",4, "edx",4
	DATA "bp",2, "si",2, "di",2, "ss",2, "ds",2, "es",2, "cs",2, "ip",2
	DATA ""   : ' <--------- null string signals the end of the data

REM $STATIC
DEFSNG A-Z
FUNCTION AddArray2List% (nm AS STRING) STATIC
 LegalName nm

 totArrays = totArrays + 1
 IF totArrays > UBOUND(ArrayInfo) THEN FatalErr "Cannot store any more array information."
 ArrayInfo(totArrays).symptr = AddSymbol(nm, CurScope, ArrayNm, totArrays)
 ArrayInfo(totArrays).scope = CurScope
 
 ReScanUnknownTok  'identify possibly previous unknown tokens in instruction

 AddArray2List = totArrays
END FUNCTION

'Nieuwe constante invoeren in lijst, nadat gecontroleerd is of
'de opgegeven naam niet al bestaat en of de naam legaal is.
'
'  Changes :  if legal constant
'                - ConstInfo array : VarType and IntVal
'                - TotConstants
'                - Constants string array
'
FUNCTION AddConst2List% (nm AS STRING, vartype AS INTEGER, CValue AS LONG) STATIC
 LegalName nm
 
 totConstants = totConstants + 1
 IF totConstants > UBOUND(ConstInfo) THEN FatalErr "Cannot store any more constant information."

 ConstInfo(totConstants).symptr = AddSymbol(nm, CurScope, ConstNm, totConstants)
 ConstInfo(totConstants).vartype = vartype
 ConstInfo(totConstants).intval = CValue
 ConstInfo(totConstants).scope = CurScope

 ReScanUnknownTok  'identify possibly previous unknown tokens in instruction
 AddConst2List = totConstants
END FUNCTION

FUNCTION AddFunction2List% (nm AS STRING) STATIC
 LegalName nm

 totFunctions = totFunctions + 1
 IF totFunctions > UBOUND(FuncDescript) THEN FatalErr "Cannot store any more function information."

 FuncDescript(totFunctions).symptr = AddSymbol(nm, CurScope, FunctionNm, totFunctions)
 FuncDescript(totFunctions).scope = CurScope
 FuncDescript(totFunctions).Bytes2Pass = 0        ' things to reset..

 AddFunction2List = totFunctions
END FUNCTION

FUNCTION AddType2List% (nm AS STRING) STATIC

 LegalName nm
 
 totTypes = totTypes + 1
 IF totTypes > UBOUND(TypeInfo) THEN FatalErr "Cannot store any more type information."

 TypeInfo(totTypes).symptr = AddSymbol(nm, CurScope, TypeNm, totTypes)
 TypeInfo(totTypes).class = 0

 AddType2List = totTypes

END FUNCTION

'Nieuwe variabele invoeren in lijst, nadat gecontroleerd is of
'variabele niet al bestaat.
'
FUNCTION AddVar2List% (nm AS STRING, vartype AS INTEGER) STATIC
 DIM Asm AS STRING
 DIM k AS INTEGER
 DIM n AS INTEGER
 
 LegalName nm

 totVars = totVars + 1
 IF totVars > UBOUND(VarInfo) THEN FatalErr "Cannot store any more variable information."

 VarInfo(totVars).symptr = AddSymbol(nm, CurScope, VarName, totVars)
 VarInfo(totVars).vartype = vartype
 VarInfo(totVars).scope = CurScope

 ReScanUnknownTok  'identify possibly previous unknown tokens in instruction
 AddVar2List = totVars

 'get "type" of requested variable if there is a "type-extension"'and remove a "type-extension" if there is one (just for comparison)
 'k = INSTR(VarExt, RIGHT$(nm, 1))       'this is _almost_ identical to the'IF k > 0 THEN                           'function StripVarExt$
 '   nm = LEFT$(Var, LEN(nm) - 1)'   VarType = k'END IF
END FUNCTION

'** generate code for data allocation
SUB AllocData (class AS INTEGER, id AS INTEGER) STATIC
 DIM m AS INTEGER
 DIM n AS INTEGER
 DIM sz AS INTEGER: sz = 0
 DIM Asm AS STRING
 
 IF class = VarName THEN
	sz = TypeInfo(VarInfo(id).vartype).size
 ELSEIF class = ArrayNm THEN
	m = 1
	FOR n = ArrayInfo(id).dimptr TO ArrayInfo(id).dimptr + ArrayInfo(id).dims - 1
		sz = (DimInfo(n).ub - DimInfo(n).lb + 1) * m
		m = sz
	NEXT
	sz = sz * TypeInfo(ArrayInfo(id).vartype).size
 ELSE ReportErr 23098
 END IF

 IF CurScope = 0 THEN
	'select asm for data reservation for variable based on vartype size
	SELECT CASE sz
	   CASE 1: Asm = " db 0"
	   CASE 2: Asm = " dw 0"
	   CASE 4: Asm = " dd 0"
	   CASE ELSE: Asm = " db" + STR$(sz) + " dup (0)"
	END SELECT
	IF class = VarName THEN
	   VarInfo(totVars).storage = GlobalVar
	   OutData "_" + GetSymName(VarInfo(id).symptr) + Asm
	ELSEIF class = ArrayNm THEN
	   OutData "_" + GetSymName(ArrayInfo(id).symptr) + Asm
	END IF

 ELSE
	FuncDescript(CurFunc).StackAlloc = FuncDescript(CurFunc).StackAlloc + sz
	IF class = VarName THEN
	   VarInfo(id).stackptr = FuncDescript(CurFunc).StackAlloc
	   VarInfo(id).storage = LocalVar
	ELSEIF class = ArrayNm THEN
	   ArrayInfo(id).stackptr = FuncDescript(CurFunc).StackAlloc
	   ArrayInfo(id).storage = LocalVar
	END IF
 END IF

END SUB

SUB Asm.Epilog

  OutCode ""
  OutAsmLn "$TEMPVARSIZE equ" + STR$(TmpSpaceAllocated)
  OutData "$_temp_data db $TEMPVARSIZE dup (0)"
  OutAsmLn "END"

END SUB

FUNCTION Asm.GetMemPtrNm$ (size AS INTEGER)

 SELECT CASE size
		CASE 1: Asm.GetMemPtrNm = "byte ptr"
		CASE 2: Asm.GetMemPtrNm = "word ptr"
		CASE 4: Asm.GetMemPtrNm = "dword ptr"
		CASE ELSE: ReportErr 12343
 END SELECT
 
END FUNCTION

SUB Asm.Prolog

  OutAsmLn ""
  OutAsmLn "; Start up code"
  OutAsmLn ".MODEL MEDIUM"
  OutAsmLn ".386"
  OutAsmLn ".STACK"
  OutCode ".STARTUP"
  OutCode "mov ah,4Ch"
  OutCode "int 21h"

END SUB

SUB Asm.PutLabel (LabelNum AS INTEGER)

	OutCode GetLabelNm(LabelNum) + ":"

END SUB

SUB Compile.Main
 DIM m AS INTEGER
 DIM n AS INTEGER

 DO

  GetNextInstruction
  IF EndOfSource THEN EXIT SUB

  IF InstrParts(1).class = KeyWordNm THEN
	 '// <if <condition> then>
	 IF InstrParts(1).id = kwIF THEN
		IncrOpenStructs
		StructStack(OpenStructs).sort = IfStruct
		Do.If

	 '// <else>
	 ELSEIF InstrParts(1).id = kwELSE THEN
		IF OpenStructs = 0 THEN FatalErr "Illegal <ELSE>. There is no opened <IF> structure."
		IF StructStack(OpenStructs).sort <> IfStruct THEN FatalErr "Illegal <ELSE> : IF is not the last structure opened."
		EXIT DO

	 '// <elseif>
	 ELSEIF InstrParts(1).id = kwELSEIF THEN
		IF OpenStructs = 0 THEN FatalErr "Illegal <ELSEIF>. There is no opened <IF> structure."
		IF StructStack(OpenStructs).sort <> IfStruct THEN FatalErr "Illegal <ELSEIF> : IF is not the last structure opened."
		EXIT DO

	 '// <SUB|FUNCTION>
	 ELSEIF InstrParts(1).id = kwSUB OR InstrParts(1).id = kwFUNCTION THEN
		IF OpenStructs > 0 THEN FatalErr "not all structures are closed: function definition not allowed"
		IncrOpenStructs
		IF InstrParts(1).id = kwSUB THEN
		   StructStack(OpenStructs).sort = SubStruct
		ELSE StructStack(OpenStructs).sort = FunctionStruct
		END IF
		Do.Function

	 '// <RETURN>
	 ELSEIF InstrParts(1).id = kwRETURN THEN
		IF CurFunc = 0 THEN FatalErr "Illegal RETURN: not in a procedure."
		Do.Return

	 '// <SELECT>
	 ELSEIF InstrParts(1).id = kwSELECT THEN
		IncrOpenStructs
		StructStack(OpenStructs).sort = SelectStruct
		Do.Select

	 '// <CASE>|<STAY>
	 ELSEIF InstrParts(1).id = kwCASE OR InstrParts(1).id = kwSTAY THEN
		EXIT SUB

	 '// <DO>
	 ELSEIF InstrParts(1).id = kwDO THEN
		
	 '// <end if|sub|function>
	 ELSEIF InstrParts(1).id = kwEND THEN
		P.NextToken
		IF P.Match(KeyWordNm, kwIF) THEN
		   P.Need -1, 0
		   IF OpenStructs = 0 THEN FatalErr "Illegal <END IF>. There is no opened <IF> structure."
		   IF StructStack(OpenStructs).sort <> IfStruct THEN FatalErr "Illegal <END IF> : IF is not the last structure opened."
		ELSEIF P.Match(KeyWordNm, kwSUB) THEN
		   P.Need -1, 0
		   IF OpenStructs = 0 THEN FatalErr "Illegal <END SUB>. There is no opened <SUB> structure."
		   IF StructStack(OpenStructs).sort <> SubStruct THEN FatalErr "Illegal <END SUB> : SUB is not the last structure opened."
		ELSEIF P.Match(KeyWordNm, kwFUNCTION) THEN
		   P.Need -1, 0
		   IF OpenStructs = 0 THEN FatalErr "Illegal <END FUNCTION>. There is no open <FUNCTION> structure."
		   IF StructStack(OpenStructs).sort <> FunctionStruct THEN FatalErr "Illegal <END FUNCTION> : FUNCTION is not the last structure opened."
		ELSE
		   P.Need KeyWordNm, kwSELECT
		   P.Need -1, 0
		   IF OpenStructs = 0 THEN FatalErr "Illegal <END SELECT>. There is no open <SELECT> structure."
		   IF StructStack(OpenStructs).sort <> SelectStruct THEN FatalErr "Illegal <END SELECT> : SELECT is not the last structure opened."
		END IF
		OpenStructs = OpenStructs - 1
		EXIT SUB

	 '// <DO>
	 ELSEIF InstrParts(1).id = kwDO THEN
		IncrOpenStructs
		StructStack(OpenStructs).sort = DoLoopStruct
		Do.Do
		
	 '// <LOOP>
	 ELSEIF InstrParts(1).id = kwLOOP THEN
		IF OpenStructs = 0 THEN FatalErr "Illegal <LOOP>. There is no opened <DO> structure."
		IF StructStack(OpenStructs).sort <> DoLoopStruct THEN FatalErr "Illegal <LOOP> : DO..LOOP is not the last structure opened."
		OpenStructs = OpenStructs - 1
		EXIT SUB

	 '// <FOR>
	 ELSEIF InstrParts(1).id = kwFOR THEN
		IncrOpenStructs
		StructStack(OpenStructs).sort = ForNextStruct
		Do.For

	 '// <NEXT>
	 ELSEIF InstrParts(1).id = kwNEXT THEN
		IF OpenStructs = 0 THEN FatalErr "Illegal <NEXT>. There is no opened <FOR..NEXT> structure."
		IF StructStack(OpenStructs).sort <> ForNextStruct THEN FatalErr "Illegal <NEXT> : FOR..NEXT is not the last structure opened."
		OpenStructs = OpenStructs - 1
		EXIT SUB

	 '// <EXIT DO|IF|FOR|SELECT>
	 ELSEIF InstrParts(1).id = kwEXIT THEN
		IF TotInstrTokens <> 2 THEN FatalErr SyntaxErrStr + "<EXIT DO|FOR|IF> expected."
		IF InstrParts(2).id = kwDO THEN
		   Do.Exit DoLoopStruct
		ELSEIF InstrParts(2).id = kwIF THEN
		   Do.Exit IfStruct
		ELSEIF InstrParts(2).id = kwFOR THEN
		   Do.Exit ForNextStruct
		ELSEIF InstrParts(2).id = kwSELECT THEN
		   Do.Exit SelectStruct
		ELSE
		   FatalErr SyntaxErrStr + "<EXIT DO|IF|FOR> expected."
		END IF

	 '// <DIM>
	 ELSEIF InstrParts(1).id = kwDIM THEN
		P.Dim

	 '// <CONST>
	 ELSEIF InstrParts(1).id = kwCONST THEN
		P.Const

	 '// <STOP>
	 ELSEIF InstrParts(1).id = kwSTOP THEN
		IF Debugging THEN STOP

   END IF

  ELSE
	   Equation AssignEq, FromInstr, 1, TotInstrTokens, 0, 0
  END IF

 LOOP

 'leave function

' Overview structure of compiler:
'
'
'    * Init:    - initialise variables/tables/etc.
'               - open input and output file
'
'    * Main:    - Get instruction from file
'               - Analyse instruction
'
'
'
' Types of instructions that can be encountered every time:
'       * declarations          (start with the name of a type)
'       * function calls
'       * equations             (start with the name of a variable)
'       * built-in structures   (for,next,do,loop,if,select,case,end if/case)
'
'
' How to handle built-in structures ?
'
'   Let's take a look at the 'if' structure:
'         the generalised structure
'
'               if <condition>
'                   <code>
'               <else
'                   <code>
'               >
'               fi
'
' Compile.Main
' * A new line is read from input, and saved in a global variable.
' * The first word is taken, using the delimiters <space> and <(> (used in function calls) .
' * Identification of instruction: the word is searched in internal database.
' * A special procedure calling the procs handling
'             ||
' Handle.instruction
' * It is identified as the keyword "if".
' * A special procedure handling the if-structure is called
'              ||
' Handle.If.Structure
' * The first word is from the global SrcLine variable is taken, and checked
'   for starting with if.
' * The remaining part that entirely consists of an equation is passed to
'   the equation parsing routine



END SUB

SUB Compile.Start (InFileName AS STRING, OutFileName AS STRING)
 
   CurSrcFile = UCASE$(InFileName)
   SrcLineNo = 0

   InputFileHandle = FREEFILE
   OPEN InFileName FOR INPUT AS InputFileHandle
   OutputFileHandle = FREEFILE
   OPEN OutFileName FOR OUTPUT AS OutputFileHandle

	  Asm.Prolog
	  Compile.Main
	  Asm.Epilog

   CLOSE InputFileHandle
   CLOSE OutputFileHandle

END SUB

SUB ConvertType (Eq AS INTEGER, typeid AS INTEGER) 'recursive:can't be static
  DIM m AS INTEGER
  DIM n AS INTEGER
  DIM OldType AS INTEGER: OldType = EqParts(Eq).vartype

  'same type: no type conversion needed
  IF OldType = typeid THEN EXIT SUB

  'non-numerical type: cannot convert
  IF TypeInfo(OldType).class <> NumType THEN ReportErr 6432

' variable -> register
' temp var -> register
' register -> register
' literal  -> literal

  SELECT CASE OldType
  CASE bytevar:
	   SELECT CASE typeid
	   CASE intvar:
			SELECT CASE EqParts(Eq).class
			CASE VarName, TempVarNm:
				 n = Reg.AssignEq(GenByteReg, Eq)
				 ConvertType Eq, intvar
			CASE LiteralNm:
				 EqParts(Eq).vartype = intvar
			CASE RegNm:
				 n = EqParts(Eq).id
				 SELECT CASE n
				 CASE AL TO DL: m = n + 4: n = n - 4
				 CASE AH TO DH: m = n - 4: n = n - 8
				 END SELECT
				 OutCode "xor " + RegNames(m) + "," + RegNames(m)
				 Reg.SetUsed n, Eq

			CASE ELSE: ReportErr 2398
			END SELECT
			
	   CASE longvar:
	   END SELECT
  CASE intvar:
	   SELECT CASE typeid
	   CASE bytevar:
	   CASE longvar:
	   END SELECT
  CASE longvar:
	   SELECT CASE typeid
	   CASE bytevar: FatalErr "Cannot convert longs"
	   CASE intvar:
	   END SELECT
  END SELECT

' Steps in the conversion of numerical types:
'
END SUB

SUB DecrScope
  DIM m AS INTEGER
  DIM n AS INTEGER

  CurScope = CurScope - 1
  IF CurScope < 0 THEN ReportErr 32742

  n = totVars
  IF n THEN
	DO WHILE VarInfo(n).scope > CurScope
	   DelSymbol VarInfo(n).symptr
	   n = n - 1: IF n = 0 THEN EXIT DO
	LOOP
  END IF
  totVars = n

  n = totTypes
  DO WHILE (TypeInfo(n).scope > CurScope) AND (n <= 0)
	 DelSymbol TypeInfo(n).symptr
	 n = n - 1: IF n = 0 THEN EXIT DO
  LOOP
  totTypes = n

  n = totFunctions
  IF n THEN
	DO WHILE FuncDescript(n).scope > CurScope
	   ParamInfoTop = ParamInfoTop - FuncDescript(n).NumArgs
	   n = n - 1: IF n = 0 THEN EXIT DO
	LOOP
  END IF
  totFunctions = n

  n = totConstants
  IF n THEN
	 DO WHILE ConstInfo(n).scope > CurScope
		DelSymbol ConstInfo(n).symptr
		n = n - 1: IF n = 0 THEN EXIT DO
	 LOOP
  END IF
  totConstants = n

  n = totArrays
  IF n THEN
	DO WHILE ArrayInfo(n).scope > CurScope
	   DelSymbol ArrayInfo(n).symptr
	   DimInfoTop = DimInfoTop - ArrayInfo(n).dims
	   n = n - 1: IF n = 0 THEN EXIT DO
	LOOP
  END IF
  totArrays = n

END SUB

SUB Do.Case (TempVarLoc AS INTEGER)

	

END SUB

SUB Do.Do
 DIM m AS INTEGER
 DIM n AS INTEGER
 DIM LoopForm AS INTEGER   ' case 0:   do .. loop
						   '      1:   do while|until .. loop
						   '      2:   do .. loop while|until

	n = OpenStructs
	StructStack(n).StartLabel = NewLabel
	StructStack(n).ContinueLabel = NewLabel
	StructStack(n).ExitLabel = NewLabel

	'Find possible <UNTIL> or <WHILE> after <DO>
	IF TotInstrTokens > 1 THEN
	   IF InstrParts(2).class = KeyWordNm AND InstrParts(2).id = kwWHILE THEN
		  'do while .. loop
		  Equation ConditionEq, FromInstr, 3, 0, 0, StructStack(n).ExitLabel
		  LoopForm = 1
	   ELSEIF InstrParts(2).class = KeyWordNm AND InstrParts(2).id = kwUNTIL THEN
		  'do until .. loop
		  Equation ConditionEq, FromInstr, 3, 0, StructStack(n).ExitLabel, 0
		  LoopForm = 1
	   ELSE
		  FatalErr SyntaxErrStr + "Only <UNTIL> or <WHILE> are allowed directly after <DO>."
	   END IF
	END IF

	Asm.PutLabel StructStack(n).StartLabel
	OutCode ";<do>"

	OutCode ";  <body>"
	Compile.Main  'continue compiling until <end if> or <else> encountered

	Asm.PutLabel StructStack(n).ContinueLabel

	'Find possible <UNTIL> or <WHILE> after <LOOP>
	IF TotInstrTokens > 1 THEN
	   IF LoopForm THEN FatalErr SyntaxErrStr + "<UNTIL> or <WHILE> already defined after <DO> : illegal after <LOOP>."
	   IF InstrParts(2).class = KeyWordNm AND InstrParts(2).id = kwWHILE THEN
		  'do .. loop while
		  Equation ConditionEq, FromInstr, 3, 0, StructStack(n).StartLabel, 0
	   ELSEIF InstrParts(2).class = KeyWordNm AND InstrParts(2).id = kwUNTIL THEN
		  'do .. loop until
		  Equation ConditionEq, FromInstr, 3, 0, 0, StructStack(n).StartLabel
	   ELSE
		  FatalErr SyntaxErrStr + "Only <UNTIL> or <WHILE> are allowed directly after <DO>."
	   END IF
	ELSE
	   OutCode "jmp " + GetLabelNm(StructStack(n).StartLabel)
	END IF

	Asm.PutLabel StructStack(n).ExitLabel

 'return to main compile procedure after end of structure

END SUB

SUB Do.Else

  IF TotInstrTokens = 1 THEN
	 '  else <instructs>
	 '       <instruct>
	 '  end if

	 Asm.PutLabel StructStack(OpenStructs).ContinueLabel
	 StructStack(OpenStructs).ContinueLabel = NewLabel

  END IF


END SUB

SUB Do.ElseIf
  DIM m AS INTEGER
  DIM n AS INTEGER

  
  n = TotInstrTokens
  IF InstrParts(n).class = KeyWordNm AND InstrParts(n).id = kwTHEN THEN
	 ' Type 1 elseif structure : elseif <condition> then
	 '                                  <instruct>
	 '                           else|elseif|end if

	 Asm.PutLabel StructStack(OpenStructs).ContinueLabel
	 StructStack(OpenStructs).ContinueLabel = NewLabel
	 Equation ConditionEq, FromInstr, 2, n - 1, 0, StructStack(OpenStructs).ContinueLabel

  ELSE

	 'type 2 elseif structure : elseif <condition> then <instruct>
	 '                          else|elseif|end if
	 FOR m = 2 TO n
	   IF InstrParts(n).class = KeyWordNm AND InstrParts(n).id = kwTHEN THEN
		  EXIT FOR
	   END IF
	 NEXT
	 IF m > n THEN FatalErr SyntaxErrStr + "No <THEN> in <ELSEIF>."

  END IF

END SUB

SUB Do.Exit (StructType AS INTEGER)
  DIM n AS INTEGER
  
  FOR n = OpenStructs TO 1 STEP -1
	  IF StructStack(n).sort = StructType THEN
		 OutCode "jmp " + GetLabelNm(StructStack(n).ExitLabel)
		 EXIT FOR
	  ELSE
		 ReportErr 4134
	  END IF
  NEXT
  IF n = 0 THEN FatalErr SyntaxErrStr + "Structure not open. Cannot exit nonexisting structure."

END SUB

SUB Do.For
  DIM m AS INTEGER, n AS INTEGER
  DIM FStruct AS INTEGER
  DIM OldTempVarPtr AS INTEGER  'used to restore usage of temporary variables
  DIM TOpos AS INTEGER
  DIM StepPos AS INTEGER
  DIM EqEndVal AS EqToken
  DIM EqInc AS EqToken
  DIM EqCounter AS EqToken
  DIM EqTmp AS EqToken


  OldTempVarPtr = FreeTmpSpacePtr

  FStruct = OpenStructs
  StructStack(FStruct).StartLabel = NewLabel   'label just _before_ body of loop
  StructStack(FStruct).ContinueLabel = NewLabel
  StructStack(FStruct).ExitLabel = NewLabel    'label just _after_ body of loop
  
  'Find <TO> in <FOR> instruction
  FOR m = 2 TO TotInstrTokens
   IF InstrParts(m).class = KeyWordNm AND InstrParts(m).id = kwTO THEN EXIT FOR
  NEXT
  IF m > TotInstrTokens THEN
	 FatalErr SyntaxErrStr + "No <TO> in <FOR> structure opening."
  ELSEIF m = TotInstrTokens THEN FatalErr SyntaxErrStr + "No equation between <FOR> and <TO>."
  ELSE TOpos = m
  END IF
  IF TotInstrTokens = TOpos THEN FatalErr SyntaxErrStr + "No endvalue given for FOR..NEXT loop variable."

  'Find possible <STEP> in <FOR> instruction
  FOR m = TOpos TO TotInstrTokens
   IF InstrParts(m).class = KeyWordNm AND InstrParts(m).id = kwSTEP THEN EXIT FOR
  NEXT
  IF m > TotInstrTokens THEN
	 StepPos = False
  ELSEIF m = TotInstrTokens THEN FatalErr SyntaxErrStr + "expression expected after <STEP>."
  ELSE StepPos = m
  END IF
  
  OutCode "; <for>"
  
	'example implementation simple for..next
	'    FOR x = 1 TO y
	'        I00008:   mov     ax,Y%
	'                  mov     t000E%,ax
	'                  mov     ax,0001h
	'                  jmp     I00012
	'                  nop
	'        BEEP
	'     NEXT
	'         I00013:   call    B$BEEP
	'                   mov     ax,X%
	'                   inc     ax
	'         I00012:   mov     X%,ax
	'                   cmp     ax,t000E%
	'                   jng     I00013

	 OutCode "; calculate & save end- and increasevalue"
	 IF StepPos THEN
		Equation JustDoItEq, FromInstr, TOpos + 1, StepPos - 1, 0, 0
		Eq.SaveAsTempVar EqResult
		EqEndVal = EqParts(EqResult)  ' Store eq token containing endvalue
		Equation JustDoItEq, FromInstr, StepPos + 1, 0, 0, 0
		IF EqParts(EqResult).class <> LiteralNm THEN
		   Eq.SaveAsTempVar EqResult
		END IF
		EqInc = EqParts(EqResult)

	 ELSE
		Equation JustDoItEq, FromInstr, TOpos + 1, 0, 0, 0
		Eq.SaveAsTempVar EqResult
		EqEndVal = EqParts(EqResult)  ' Store eq token containing endvalue
		EqInc.class = LiteralNm: EqInc.vartype = intvar: EqInc.intval = 1
	 END IF

	 
	 OutCode "; assign begin value to variable"
	 Equation AssignEq, FromInstr, 2, TOpos - 1, 0, 0
	 IF Debugging THEN PRINT EqResult

	 ' Store eq token containing counter
	 EqCounter = EqParts(EqResult)

	 OutCode "jmp " + GetLabelNm(StructStack(FStruct).ContinueLabel)

	 Asm.PutLabel StructStack(FStruct).StartLabel
	 OutCode ";  <body>"
  
	 '* Continue compiling until <next> encountered.
	 Compile.Main

	 '* Build eq to increase counter:    counter = counter + inc | counter += inc
	 Eq.ResetForBuild
	 n = Eq.InsertToken(EqInc, AddAt, 1)
	 n = Eq.InsertToken(EqCounter, AddBefore, 1)
	 EqTmp.class = OperatorNm: EqTmp.id = Assign
	 n = Eq.InsertToken(EqTmp, AddBefore, 1)
	 n = Eq.InsertToken(EqCounter, AddBefore, 1)
	 EqTmp.class = OperatorNm: EqTmp.id = Add
	 n = Eq.InsertToken(EqTmp, AddBefore, 1)

	 Equation JustDoItEq, DirectFromEq, 1, 0, 0, 0

	 Asm.PutLabel StructStack(OpenStructs + 1).ContinueLabel

	 '* Build eq to test condition:   if counter <= endvalue then goto for_start
	 IF EqInc.class = LiteralNm THEN

		Eq.ResetForBuild
		n = Eq.InsertToken(EqCounter, AddAt, 1)
		n = Eq.InsertToken(EqEndVal, AddAfter, 1)

		EqTmp.class = OperatorNm
		IF EqInc.intval < 0 THEN
		   EqTmp.id = JL
		   n = Eq.InsertToken(EqTmp, AddAfter, 1)
		   Equation ConditionEq, DirectFromEq, 1, 0, 0, StructStack(FStruct).StartLabel
		ELSEIF EqInc.intval > 0 THEN
		   EqTmp.id = JG
		   n = Eq.InsertToken(EqTmp, AddAfter, 1)
		   Equation ConditionEq, DirectFromEq, 1, 0, 0, StructStack(FStruct).StartLabel
		ELSE
		   FatalErr "I don't support that sort of crap. Use a do..loop, you dork. "
		END IF
		
	 ELSE   ' EqInc can have any value

		'if inc < 0 then
		'   deccounter
		'   exitfor_if(counter < endvalue)
		'else
		'   inccounter
		'   exitfor_if(counter > endvalue) ;

		'Check if EqInc > 0 or < 0
		Eq.ResetForBuild
		n = Eq.InsertToken(EqInc, AddAt, 1)
		EqTmp.class = LiteralNm: EqTmp.vartype = intvar: EqTmp.intval = 0
		n = Eq.InsertToken(EqTmp, AddAfter, 1)
		EqTmp.class = OperatorNm: EqTmp.id = JL
		n = Eq.InsertToken(EqTmp, AddAfter, 1)
		m = NewLabel
		Equation ConditionEq, DirectFromEq, 1, 0, m, 0

		'   exitfor_if(counter > endvalue)
		Eq.ResetForBuild
		n = Eq.InsertToken(EqCounter, AddAt, 1)
		n = Eq.InsertToken(EqEndVal, AddAfter, 1)
		EqTmp.class = OperatorNm: EqTmp.id = JG
		n = Eq.InsertToken(EqTmp, AddAfter, 1)
		Equation ConditionEq, DirectFromEq, 1, 0, StructStack(FStruct).StartLabel, 0
		OutCode "jmp " + GetLabelNm(StructStack(FStruct).ExitLabel)

		Asm.PutLabel m

		'   exitfor_if(counter < endvalue)

		Eq.ResetForBuild
		n = Eq.InsertToken(EqCounter, AddAt, 1)
		n = Eq.InsertToken(EqEndVal, AddAfter, 1)
		EqTmp.class = OperatorNm: EqTmp.id = JL
		n = Eq.InsertToken(EqTmp, AddAfter, 1)
		n = Eq.InsertToken(EqTmp, AddAt, EqParts(EqParts(0).extra).nextp)
		Equation ConditionEq, DirectFromEq, 1, 0, StructStack(FStruct).StartLabel, 0
		
	 END IF

	 Asm.PutLabel StructStack(FStruct).ExitLabel

  
  FreeTmpSpacePtr = OldTempVarPtr  'restore temp var ptr, since temp var used
								   'to hold end condition value is no longer
								   'needed

'  Counter variabele en temp variable voor limiet opslaan, omdat
'  ze verloren gaan tijdens de verwerking van het body.
'  Opslag in equatie elementen.
'
'  Bij verwerking <next> :
'
'    counter = counter + 1
'    if counter <= temp then goto for_start
'
' => * formule bouwen:    reg_ax := counter
'    *                    inc reg_ax
'    *                    mov counter, reg_ax
'    * formule bouwen:    reg_ax >= temp
'
'
' Hoe een formule op te bouwen?
'    1) - globale SrcLine string wijzigen
'       - string opdelen : Scan.Instruction
'       - formule uitwerken : Equation.Assign|Condition 1, TotInstrtokens
'
'       Nadelen?  * alleen taalelementen in formules: bv. geen regs
'
'    2) via InstrParts array. Geen regs in formules geaccepteerd!
'                             Support ook niet eenvoudig in te bouwen.
'    3) via EqParts array. Probleem met Equation start subs. Zij werken
'                          namelijk via de InstrParts!
'
'
  
END SUB

' Do.Function parses a function and sub header and stores the general
' function info and lets P.FuncParameter fill in the function parameter info.
' Then it calls Compile.Main which returns control when it encounters the
' end of the function/sub.
'
SUB Do.Function
  DIM SubOrFn AS INTEGER   ' =0  -> doing sub,  =1  -> doing function
  DIM OldFunction AS INTEGER
  DIM FuncDescript AS FunctionDescriptType
  DIM ParamCnt AS INTEGER
  DIM TotParamBytes AS INTEGER
  DIM b AS INTEGER
  DIM k AS INTEGER
  DIM m AS INTEGER
  DIM n AS INTEGER

  OldFunction = CurFunc 'save what was the current function id to restore
							'it when the parsing of this function has ended.
  P.Init

  IF NOT P.Match(KeyWordNm, kwFUNCTION) THEN
	 P.Need KeyWordNm, kwSUB
	 SubOrFn = 1    'routine is a sub
  END IF

  'scope token of function descriptor is set in this proc
  CurFunc = AddFunction2List(GetTokenName(CurTok))
  
  CurScope = CurScope + 1   'increase scope, so variables and parameters
							'in/of sub are local

  'set exit label: used in returning value from function (Do.Return)
  FuncDescript(CurFunc).ExitLabel = NewLabel

  P.NextToken

  '* Parse parameter list *
  IF P.Match(KeyWordNm, LP) THEN  ' parameter list opened by "("
	 FuncDescript(CurFunc).ArgLstPtr = ParamInfoTop + 1
	 DO
	   ParamCnt = ParamCnt + 1
	   P.FuncParameter
	 LOOP WHILE P.Match(KeyWordNm, kwComma)
	 P.Need KeyWordNm, RP       ' ")" needed
  END IF
  
  '* set the returning type for functions and subs *
  IF SubOrFn THEN
	 FuncDescript(CurFunc).vartype = 0     'subs..
  ELSE
	 FuncDescript(CurFunc).vartype = P.TypeOfIdent   'functions..
  END IF

  P.Need -1, 0

  'set other elements of the function descriptor
  FuncDescript(CurFunc).NumArgs = ParamCnt
  FuncDescript(CurFunc).StackAlloc = 0

  OutCode GetAsmValNm(0, 0, FunctionNm, CurFunc) + ":"
  OutCode "push bp"
  OutCode "mov bp,sp"
  OutCode "sub sp,@STACK" + LTRIM$(STR$(CurFunc))

  '* calculate relative position to stack ptr of each parameter
  k = FuncDescript(CurFunc).ArgLstPtr
  m = 0
  FOR n = ParamCnt TO 1 STEP -1
	  l = FuncArgInfo(k + n - 1).VarInfoPtr
	  VarInfo(l).stackptr = 6 + m
	  b = FuncArgInfo(k + n - 1).Bytes2Pass
	  IF b = 1 THEN b = 2 'x86 can't push 1 byte: so the called routine gets 2
	  m = m + b
  NEXT
	 
  '** compile code in function
  Compile.Main

  Asm.PutLabel FuncDescript(CurFunc).ExitLabel
  OutCode "pop bp"
  n = FuncDescript(CurFunc).Bytes2Pass
  IF n THEN
	 OutCode "retf" + STR$(n)
  ELSE
	 OutCode "retf"
  END IF
  OutAsmLn "@STACK" + LTRIM$(STR$(CurFunc)) + " EQU" + STR$(FuncDescript(CurFunc).StackAlloc)

  CurFunc = OldFunction  'restore old function id we had before this one

  DecrScope        'decreases scope and removes local variables, functions,
				   'types and constants.

  'PRINT "Before entering procedure:"PRINT , "TotVars="; totVarsPRINT , "TotConstants="; totConstantsPRINT , "TotFunctions="; totFunctions
  'PRINT "In procedure:"PRINT , "TotVars="; totVarsPRINT , "TotConstants="; totConstantsPRINT , "TotFunctions="; totFunctions
  'PRINT "After leaving procedure:"PRINT , "TotVars="; totVarsPRINT , "TotConstants="; totConstantsPRINT , "TotFunctions="; totFunctions
END SUB

SUB Do.If
 DIM m AS INTEGER
 DIM n AS INTEGER
 DIM ElseDone AS INTEGER  ' flag which is set if else is encountered; used
						  ' to check for illegal syntax

 ' double check if instruction starts with an IF
 IF InstrParts(1).class = KeyWordNm AND InstrParts(1).id = kwIF THEN

	StructStack(OpenStructs).ContinueLabel = NewLabel
	StructStack(OpenStructs).ExitLabel = NewLabel

	'find <then> in instruction
	n = TotInstrTokens
	IF InstrParts(n).class = KeyWordNm AND InstrParts(n).id = kwTHEN THEN
	   'type 1 if structure : if <condition> then
	   '                         <instruct>
	   '                      else
	   '                         <instruct>
	   '                      end if

	   Equation ConditionEq, FromInstr, 2, n - 1, 0, StructStack(OpenStructs).ContinueLabel
	   Compile.Main  'continue compiling until <end if> or <else(if)> encountered

	   DO
		  
		  IF InstrParts(1).class = KeyWordNm THEN
			 IF InstrParts(1).id = kwELSEIF THEN
				IF ElseDone THEN FatalErr SyntaxErrStr + "<ELSEIF> used after <ELSE>."
				OutCode "jmp " + GetLabelNm(StructStack(OpenStructs).ExitLabel)
				Do.ElseIf  'set up elseif block
				Compile.Main   'compile elseif block
			 ELSEIF InstrParts(1).id = kwELSE THEN
				OutCode "jmp " + GetLabelNm(StructStack(OpenStructs).ExitLabel)
				Do.Else
				Compile.Main
				ElseDone = True
			 ELSEIF InstrParts(1).id = kwEND AND InstrParts(2).id = kwIF THEN
				Asm.PutLabel StructStack(OpenStructs + 1).ContinueLabel'install labels
				Asm.PutLabel StructStack(OpenStructs + 1).ExitLabel    'at end
				EXIT DO
			 END IF
		  END IF

	   LOOP


	ELSE
	   'type 2 if structure : if <condition> then <instruct> else <instruct>
	   '                      no "end if" required at end of if structure
	   FOR m = 2 TO TotInstrTokens
		 IF InstrParts(m).class = KeyWordNm AND InstrParts(m).id = kwTHEN THEN
			EXIT FOR
		 END IF
	   NEXT
	   IF m > n THEN FatalErr SyntaxErrStr + "No <THEN> in opened <IF> structure."
	   
	END IF

 END IF

 'return to main compile procedure after end of structure

END SUB

SUB Do.Return
  DIM n AS INTEGER
  DIM EqTmp AS EqToken
  
	P.Need KeyWordNm, kwRETURN

	IF FuncDescript(CurFunc).vartype THEN
	   P.Need 0, -1   'check if there's no end of instruction
	ELSE
	   IF NoNextToken = 0 THEN FatalErr SyntaxErrStr + "A SUB cannot return a value: illegal equation"
	END IF
	
	IF NoNextToken = 0 THEN
	   '** get equation after return and change it into: reg:=equation
	   '   then solve equation

	   Equation JustDoItEq, FromInstr, 2, 0, 0, 0

	   n = FuncDescript(CurFunc).vartype
	   SELECT CASE TypeInfo(n).size
		CASE 1: n = AL
		CASE 2: n = AX
		CASE 4: n = EAX
		CASE ELSE: ReportErr 2312
	   END SELECT
	   n = Reg.AssignEq(n, EqResult)

	END IF
	
	'create jump to function exit routine
	OutCode "jmp " + GetLabelNm(FuncDescript(CurFunc).ExitLabel)

END SUB

SUB Do.Select STATIC
  DIM SelectResult AS EqToken
  DIM TmpEq AS EqToken
  DIM Stay AS INTEGER:     Stay = 0
  DIM n AS INTEGER:        n = 0
  DIM caseElse AS INTEGER: caseElse = 0

  P.Need KeyWordNm, kwSELECT
  P.Need KeyWordNm, kwCASE

  StructStack(OpenStructs).ContinueLabel = NewLabel
  StructStack(OpenStructs).ExitLabel = NewLabel
  
  Equation JustDoItEq, FromInstr, CurTok, 0, 0, 0

  Eq.SaveAsTempVar EqResult
  SelectResult = EqParts(EqResult)

  GetNextInstruction  'get instruction after select case:
					  'must be "case" or "end select"

  DO

	 IF P.Match(KeyWordNm, kwCASE) = 0 THEN
		IF Stay THEN FatalErr "CASE expected after STAY"
		EXIT DO
	 END IF

	 'case is <rel op> <expression>
	 IF P.Match(KeyWordNm, kwIS) THEN
		Eq.GetTokens 3, 0, 0
		'* check if there is a relative operator after IS
		n = EqParts(0).extra
		IF (EqParts(n).class = OperatorNm AND (EqParts(n).id >= Eq AND EqParts(n).id <= JNE)) = 0 THEN
		   FatalErr "Expected a relational operator; one of: > >= <> <= < ="
		END IF
		
		'** compare test- and case result
		n = Eq.InsertToken(SelectResult, AddBefore, n)
		Equation ConditionEq, DirectFromEq, 0, 0, 0, StructStack(OpenStructs).ContinueLabel

	 ELSEIF P.Match(KeyWordNm, kwELSE) THEN
		caseElse = True
		P.Need -1, 0     'no compare

	 'case <expression>
	 ELSE
		Equation JustDoItEq, FromInstr, 2, 0, 0, 0
		'** compare test- and case result
		TmpEq.class = OperatorNm: TmpEq.id = Eq
		n = Eq.InsertToken(TmpEq, AddBefore, EqResult)
		n = Eq.InsertToken(SelectResult, AddBefore, n)
		Equation ConditionEq, DirectFromEq, 0, 0, 0, StructStack(OpenStructs).ContinueLabel
	 END IF

	 IF Stay THEN Asm.PutLabel Stay
	 Stay = False
	 
	 '** Compile code in CASE block
	 Compile.Main

	 '** stay, next case or end select encountered
	 IF P.Match(KeyWordNm, kwSTAY) THEN
		P.Need -1, 0     'stay: don't jump out
		Stay = NewLabel
		GetNextInstruction
		OutCode "jmp " + GetLabelNm(Stay)
	 ELSEIF InstrParts(1).id = kwCASE THEN  'no need to check for KeyWordNm
		'no stay: jump out of select if there's a next case
		OutCode "jmp " + GetLabelNm(StructStack(OpenStructs).ExitLabel)
	 END IF
	 IF InstrParts(1).id = kwEND THEN
		n = OpenStructs + 1
	 ELSE
		n = OpenStructs
		IF caseElse THEN FatalErr "END SELECT expected after CASE ELSE block"
	 END IF
	 Asm.PutLabel StructStack(n).ContinueLabel
	 StructStack(n).ContinueLabel = NewLabel

  LOOP

  Asm.PutLabel StructStack(n).ExitLabel

END SUB

SUB Eq.Asm.AccessAry (OpIdx AS INTEGER) STATIC
 DIM aryId AS INTEGER
 DIM aryEq AS INTEGER
 DIM BPeq AS INTEGER
 DIM DIeq AS INTEGER
 DIM BPinUse AS INTEGER
 DIM DIinUse AS INTEGER
 DIM PushedDI AS INTEGER
 DIM subscriptFound AS INTEGER        'number of subscripts found
 DIM l AS INTEGER
 DIM n AS INTEGER
 DIM m AS INTEGER
 DIM s AS INTEGER
 DIM EqTmp AS EqToken
 DIM GenRegToUse AS INTEGER
 DIM subscriptIdx(1 TO 40) AS INTEGER  'indexes to eq tokens of push operators
 DIM DimOffsetMul(1 TO 40) AS INTEGER  'values to multiply with corresponding
									   'dims to get dimension base offset

' Input format on entry of Eq.Asm.AccessAry:
'   <array identifier> <array access op> link< <ArySubOpr subscript>* >
'
' Format ultimately used for code generation in this sub:
'   <array identifier> <array access op> link< (ArySubOpr link<subscript>)* >


aryEq = EqParts(OpIdx).prev
aryId = EqParts(aryEq).id

GOSUB FindNStoreSubcripts
GOSUB TestSubscripts
GOSUB ChangeEqFormat
GOSUB CreateAccessList

Eq.Debug.Remake 0

'*** and now : CODE GENERATION
 l = ArrayInfo(aryId).dimptr
 FOR n = 1 TO subscriptFound
	 Eq.Solve.Whole 0, EqParts(subscriptIdx(n)).nextp

	 '* check lower and upper bounds if literal subscript
		IF EqParts(EqResult).class = LiteralNm THEN
		   IF EqParts(EqResult).intval < DimInfo(l + n - 1).lb THEN
			  FatalErr "Subscript out of range: beneath lower bound"
		   ELSEIF EqParts(EqResult).intval > DimInfo(l + n - 1).ub THEN
			  FatalErr "Subscript out of range: above upper bound"
		   END IF
		END IF

	 '** Calculate offset in this dimension
	 '* idx = idx-lbound
		EqTmp.class = OperatorNm: EqTmp.id = minus
		m = Eq.InsertToken(EqTmp, AddAfter, EqResult)
		EqTmp.class = LiteralNm: EqTmp.intval = DimInfo(l + n - 1).lb: EqTmp.vartype = intvar
		s = Eq.InsertToken(EqTmp, AddAfter, m)
		s = Eq.Solve.Term(m)
	 '* offset = idx*diminfo(dim).mul
		IF NOT (EqParts(s).class = LiteralNm AND EqParts(s).intval = 0) THEN
		   EqTmp.class = OperatorNm: EqTmp.id = mul
		   m = Eq.InsertToken(EqTmp, AddBefore, s)
		   EqTmp.class = LiteralNm: EqTmp.intval = DimInfo(l + n - 1).mul: EqTmp.vartype = intvar
		   s = Eq.InsertToken(EqTmp, AddBefore, m)
		   s = Eq.Solve.Term(m)
		END IF

	 '** ADD SUBSCRIPT OFFSET TO MEM PTR (eqtoken s contains offset!)
		IF EqParts(s).class = LiteralNm THEN
		   EqParts(aryEq).intval = EqParts(aryEq).intval + EqParts(s).intval
		ELSE
		   IF DIinUse THEN
			  'DI is already in use: ADD OFFSET TO DI    '<DIeq> <+> <s>
			  EqTmp.class = OperatorNm: EqTmp.id = Add
			  n = Eq.InsertToken(EqTmp, AddAfter, DIeq)
			  EqTmp = EqParts(s)
			  m = Eq.InsertToken(EqTmp, AddAfter, n)
			  DIeq = Eq.Solve.Term(n)

		   ELSE
			  'DI isn't used for this array access sofar: ASSIGN OFFSET TO DI
			  IF RegInfo(DI).InUse THEN OutCode "push di": PushedDI = True
			  n = Reg.AssignEq(DI, s)
			  Eq.SwapInfo DIeq, s
		   END IF
		END IF
		Eq.DelToken subscriptIdx(n)
		Eq.DelToken s

 NEXT
 IF PushedDI THEN OutCode "pop di"
 Eq.Debug.Remake 0
 Eq.DelToken BPeq
 Eq.DelToken DIeq
END

 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 EXIT SUB

'** Make eq sub list that will contain "array access descriptor" consisting
'   of a base and an index register element.
CreateAccessList:
	BPeq = Eq.FindFreeToken
	EqParts(BPeq).nextp = -1
	EqParts(BPeq).prev = -1
	EqParts(BPeq).basis = aryEq
	EqParts(aryEq).extra = BPeq
	DIeq = Eq.InsertToken(EqTmp, AddAfter, BPeq)
	EqParts(aryEq).intval = 0
	IF ArrayInfo(aryId).storage = LocalVar THEN
	   EqParts(BPeq).class = RegNm
	   BPinUse = True
	   EqParts(BPeq).id = BPinUse
	   EqParts(aryEq).intval = -ArrayInfo(aryEq).stackptr
	END IF
RETURN

'** Find & store indexes of subscript operators in subscriptIdx array.
FindNStoreSubcripts:
 n = EqParts(OpIdx).nextp
 IF n <> EOC THEN
  IF EqParts(n).class = Link THEN
	n = EqParts(n).extra
	DO
	   IF n <> EOC THEN
		  IF EqParts(n).class = OperatorNm AND EqParts(n).id = ArySubOpr THEN
			 subscriptFound = subscriptFound + 1
			 IF subscriptFound > UBOUND(subscriptIdx) THEN FatalErr "Array subscript list too long."
			 subscriptIdx(subscriptFound) = n
		  END IF
	   ELSE
		  EXIT DO
	   END IF
	   n = EqParts(n).nextp
	LOOP
  END IF
 END IF
RETURN

'** test number of subscripts
TestSubscripts:
 n = ArrayInfo(aryId).dims
 IF n <> subscriptFound THEN
	FatalErr "Wrong number of subscripts to access array " + GetSymName(ArrayInfo(aryId).symptr) + ". There should be" + STR$(n) + " subscript(s), instead of" + STR$(subscriptFound)
 END IF
RETURN

'** change format of subscript list from:
'  <array identifier> <array access op> link< <ArySubOpr subscript>* >
'to:
'  <array identifier> <array access op> link< ( ArySubOpr link(<subscript>) )* >
ChangeEqFormat:
 FOR n = 1 TO subscriptFound
	 s = subscriptIdx(n)
	 EqTmp.class = Link
	 l = Eq.InsertToken(EqTmp, AddAfter, s)   'insert link after subscript op
	 EqParts(l).extra = EqParts(l).nextp      'sublist starts at subscript eq
	 s = EqParts(l).nextp
	 EqParts(s).prev = BOC   'beginning of sublist in old token after subscript op
	 IF n < subscriptFound THEN
		s = EqParts(subscriptIdx(n + 1)).prev
		EqParts(l).nextp = EqParts(s).nextp  'set next ptr of link to param sublist
		EqParts(s).nextp = EOC  'set end of new sublist (argument)
	 ELSE
		EqParts(l).nextp = EOC
	 END IF
	 'adjust .basis of all tokens in new eq sublist
	 m = EqParts(l).extra
	 DO
		EqParts(m).basis = l
		m = EqParts(m).nextp
	 LOOP UNTIL m = EOC
 NEXT
RETURN

'Code to access array element:
'
'*Static arrays:
'    dims| array index class  | asm access code
'        |                    |
'  - 1D:   - literal           [_ARRAY+literal]
'          - global|local var  mov DI, _VAR|[bp-n]
'                              [_ARRAY+DI]
'          - register          mov BX,reg
'                              [_ARRAY+BX]
'  - 2D:   - literal,literal   [_ARRAY+literal]
'          - global|local var  mov DI, _VAR|[bp-n] * sz
'            literal           [_ARRAY+DI+literal]
'          - register,literal  mov BX,reg
'                              [_ARRAY+BX+literal]
'          - global|local var  mov BX,reg*sz
'            register          mov DI, _VAR|[bp-n] * sz
'                              [_ARRAY+DI+BX]
'          - register,register mov DI, reg * sz
'                              mov BX, reg * sz
'                              [_ARRAY+DI+BX]
'*Local arrays:
'
'
'
'

'HOW ARRAYS ARE ACCESSED:
'  After conversion of the eq in the appropriate format (see ChangeEqFormat),
'the offsets in the array are calculated one after another, and multiplied
'with a number to give the appropriate byte offset.
'  To access the array in assembly, the following addressing modes are used:
'     array[di]     (+constant)
'          [bp]     (+constant)
'          [bp+di]  (+constant)
'(SI is not used for array access since it is reserved for pointer usage
' and to access by reference function arguments. BX is not used to avoid
' interference with equation solving.)
'   Thus, there can be multiple elements involved in the array access:
'the array offset, a constant, and the registers bx,si,di and bp.
'   Array access is given centrally by the GetAsmValNm(.Eq) function, with
'the eq index of the array element as input. Since there can be multiple
'elements involved in addressing arrays, extra input is needed. This is given
'in the form of an eq sublist pointed to by the .extra element of the array
'eq token. This sublist contains 2 elements: 1) a base register(BX xor BP)
'and 2) the index register DI. If their class isn't 0 they're in use.
'The value of the displacement constant is held in the .intval element of the
'array eq token. In the case of static (local and global) arrays the array
'offset is used as well, if arrays aren't static then the BP register is used.
'The sublist is made and destroyed by Eq.Asm.AccessAry.

'The natural segments are:
'    (1) DS
'            variable (constant)
'            [bx] + (constant)
'            [si] + (constant)
'            [di] + (constant)
'            [bx+si] + (constant)
'            [bx+di] + (constant)
'    (2) SS
'            [bp] + (constant)
'            [bp+si] + (constant)
'            [bp+di] + (constant)

'Arrays in C: Array subscript operator [ ]
'Brackets indicate single and multidimensional array subscripts. The
'expression         <exp1>[exp2]               <exp1>[exp2][exp3]
'is defined as     *((exp1) + (exp2))         *((exp1)+(exp2)+(exp3))
'where either
'  exp1 is a pointer and exp2 is an integer
'or
'  exp1 is an integer and exp2 is a pointer

' This principle extended to basic
'  array(exp1,exp2,exp3)  ==  *(array+(exp1)+(exp2)+(exp3))
'  array == ptr , exp(n) == integer
END SUB

' Eq.Asm.Add : handles the addition of 2 operandi.
'   Input     : OpIdx = index to token containing the "+" operand
'                       will contain resulting token
'   Returns   : nothing
'   Changes   : - the equation list at the index of the operators and operandi
'               Eq. result will ALLWAYS be returned in the OPERATOR!!
'
'   Uses      : function GetAsmValNm.Eq
'               sub OutCode, Reg.AssignEq
'
'   Comments  : result is temporarily set into left operand, but will be
'               be put into operator token at end of function
'
SUB Eq.Asm.Add (OpIdx AS INTEGER)
 CONST AddOpCode = "add "
 CONST IncOpCode = "inc "
 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class: rs = EqParts(r).class

 'Swap the arguments if the right operator is more complicated then
 SELECT CASE ls                                  'the left operator.
	CASE RegNm
	CASE LiteralNm, ConstNm
		 SELECT CASE rs
		  CASE VarName, ConstNm, RegNm, TempVarNm:   Eq.SwapInfo l, r
		 END SELECT
	CASE VarName, TempVarNm
		 IF rs = RegNm THEN Eq.SwapInfo l, r
 END SELECT

 ls = EqParts(l).class ' Redefine local variables since arguments may be
 rs = EqParts(r).class ' swapped.
 
 IF EqParts(OpIdx).extra THEN    'operator "+=" in reality
	'if
 END IF
 
 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg: GOSUB Do.all.ints.Add
	 CASE intvar:
		  GenRegToUse = GenWordReg: GOSUB Do.all.ints.Add
	 CASE longvar:
		  GenRegToUse = GenDWordReg: GOSUB Do.all.ints.Add
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT

 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB


Do.all.ints.Add:
 SELECT CASE ls
 CASE VarName, TempVarNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 n = EqParts(r).intval
			 IF n = 1 THEN
				n = Reg.AssignEq(GenRegToUse, l)
				OutCode IncOpCode + GetAsmValNm.Eq(l)
			 ELSEIF n <> 0 THEN
				n = Reg.AssignEq(GenRegToUse, l)
				OutCode AddOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
			 END IF

		CASE VarName, TempVarNm:
			 n = Reg.AssignEq(GenRegToUse, l)
			 OutCode AddOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)

		CASE ELSE: ReportErr 13524
	  END SELECT

 CASE LiteralNm, ConstNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 EqParts(l).class = LiteralNm
			 EqParts(l).intval = EqParts(l).intval + EqParts(r).intval
		CASE ELSE: ReportErr 13524
	  END SELECT

 CASE RegNm
	  SELECT CASE rs
		CASE VarName, RegNm, TempVarNm:
			 OutCode AddOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
		CASE LiteralNm, ConstNm:
			 n = EqParts(r).intval
			 IF n = 1 THEN
				OutCode IncOpCode + GetAsmValNm.Eq(l)
			 ELSEIF n <> 0 THEN
				OutCode AddOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
			 END IF
		CASE ELSE: ReportErr 13524
	  END SELECT

 CASE ELSE: ReportErr 13524
 END SELECT
 Eq.SwapInfo l, OpIdx   'result is returned in the operator token
RETURN

END SUB

SUB Eq.Asm.ANDORXOR (OpIdx AS INTEGER)
 DIM OpCode AS STRING
 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse AS INTEGER
 
 SELECT CASE EqParts(OpIdx).id
	 CASE logAND: OpCode = "and "
	 CASE logOR: OpCode = "or "
	 CASE logXOR: OpCode = "xor "
 END SELECT
 
 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class: rs = EqParts(r).class

 'Swap the arguments if the right operator is more complicated then
 SELECT CASE ls                                  'the left operator.
	CASE RegNm
	CASE LiteralNm, ConstNm
		 SELECT CASE rs
		  CASE VarName, ConstNm, RegNm, TempVarNm:   Eq.SwapInfo l, r
		 END SELECT
	CASE VarName, TempVarNm
		 IF rs = RegNm THEN Eq.SwapInfo l, r
 END SELECT

 ls = EqParts(l).class ' Redefine local variables since arguments may be
 rs = EqParts(r).class ' swapped.

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.AndOrXor
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.AndOrXor
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.AndOrXor
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT

 Eq.SwapInfo l, OpIdx   'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB


Do.all.ints.AndOrXor:
	  SELECT CASE ls
		CASE VarName, TempVarNm
			 SELECT CASE rs
				 CASE LiteralNm, ConstNm, VarName, TempVarNm:
					  n = Reg.AssignEq(GenRegToUse, l)
					  OutCode OpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
				 CASE ELSE: ReportErr 13524
			 END SELECT

		CASE LiteralNm, ConstNm
			 SELECT CASE rs
				 CASE LiteralNm, ConstNm:
					  EqParts(l).class = LiteralNm
					  SELECT CASE EqParts(OpIdx).id
						  CASE logAND: EqParts(l).intval = EqParts(l).intval AND EqParts(r).intval
						  CASE logOR: EqParts(l).intval = EqParts(l).intval OR EqParts(r).intval
						  CASE logXOR: EqParts(l).intval = EqParts(l).intval XOR EqParts(r).intval
					  END SELECT
				 CASE ELSE: ReportErr 13524
			 END SELECT

		CASE RegNm
			 SELECT CASE rs
				 CASE VarName, RegNm, TempVarNm, LiteralNm, ConstNm:
					  OutCode OpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
				 CASE ELSE: ReportErr 13524
			 END SELECT

		CASE ELSE: ReportErr 13524
	  END SELECT
RETURN
END SUB

SUB Eq.Asm.Assign (OpIdx AS INTEGER)
 CONST MovOpCode = "mov "

 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class: rs = EqParts(r).class


 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.assign
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.assign
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.assign
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT

 Eq.SwapInfo l, OpIdx   'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB

Do.all.ints.assign:
	SELECT CASE ls
	  CASE VarName
		   SELECT CASE rs
			 CASE LiteralNm, RegNm, ConstNm:
				  OutCode MovOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)

			 CASE VarName, TempVarNm:
				  n = Reg.AssignEq(GenRegToUse, r)
				  OutCode MovOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)

			 CASE ELSE: ReportErr 24642
		   END SELECT

	  'to allow assignments to registers for equations made in the compiler
	  'CASE RegNm
	  '     SELECT CASE rs
	  '       CASE LiteralNm, RegNm, ConstNm, VarName, TempVarNm:
	  '            OutCode MovOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
	  '       CASE ELSE: ReportErr 24642
	  '     END SELECT

	  CASE ELSE: ReportErr 24642    'Not an lvalue!
	END SELECT
RETURN

END SUB

SUB Eq.Asm.CMP (OpIdx AS INTEGER)
 CONST CmpOpCode = "cmp "
 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM k AS INTEGER
 DIM m AS INTEGER, n AS INTEGER
 DIM GenRegToUse AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class
 rs = EqParts(r).class

 '*  Determine if code optimalization is possible: it is, when this "compare"
 '   is the whole formula
 IF EqParts(l).prev = BOC AND EqParts(r).nextp = EOC AND EqParts(l).basis = 0 THEN
	ConditionJumpsOptimized = True
 END IF

 SELECT CASE TypeInfo(EqParts(l).vartype).size
	 CASE 1:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.CMP
	 CASE 2:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.CMP
	 CASE 4:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.CMP
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT

 EqParts(OpIdx).vartype = EqParts(l).vartype 'make sure vartype of result is set
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB

Do.all.ints.CMP:
	  SELECT CASE ls
		CASE RegNm
		  SELECT CASE rs
			CASE LiteralNm, ConstNm, VarName, RegNm, TempVarNm:
				 GOSUB Make.Shared.integer.CMP.Code
			CASE ELSE: ReportErr 1983
		  END SELECT

		CASE LiteralNm, ConstNm
			SELECT CASE rs
			CASE LiteralNm, ConstNm:
				SELECT CASE EqParts(OpIdx).id
					CASE Eq: EqParts(l).intval = (EqParts(l).intval = EqParts(r).intval)
					CASE JG: EqParts(l).intval = (EqParts(l).intval > EqParts(r).intval)
					CASE JL: EqParts(l).intval = (EqParts(l).intval < EqParts(r).intval)
					CASE JLE: EqParts(l).intval = (EqParts(l).intval <= EqParts(r).intval)
					CASE JGE: EqParts(l).intval = (EqParts(l).intval >= EqParts(r).intval)
					CASE JNE: EqParts(l).intval = (EqParts(l).intval <> EqParts(r).intval)
					CASE ELSE: ReportErr 1983
				END SELECT
				EqParts(OpIdx).class = LiteralNm
				EqParts(OpIdx).intval = EqParts(l).intval
				
			CASE VarName, RegNm, TempVarNm:
				n = Reg.AssignEq(GenRegToUse, l)
				GOSUB Make.Shared.integer.CMP.Code
			CASE ELSE: ReportErr 1983
			END SELECT

		CASE VarName, TempVarNm
			SELECT CASE rs
			CASE VarName, TempVarNm
				 n = Reg.AssignEq(GenRegToUse, l)
				 GOSUB Make.Shared.integer.CMP.Code
			CASE LiteralNm, ConstNm, RegNm
				 GOSUB Make.Shared.integer.CMP.Code
			CASE ELSE: ReportErr 1983
			END SELECT

		CASE ELSE: ReportErr 1983
	  END SELECT
RETURN


Make.Shared.integer.CMP.Code:
  IF DoingCondition AND ConditionJumpsOptimized THEN

	 OutCode CmpOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
	 m = NewLabel
	 IF ConditionTrueLabel <> 0 AND ConditionFalseLabel = 0 THEN
		OutCode Eq.GetCmpName(EqParts(OpIdx).id, True) + GetLabelNm(m)
		OutCode "jmp " + GetLabelNm(ConditionTrueLabel)
	 ELSEIF ConditionFalseLabel <> 0 AND ConditionTrueLabel = 0 THEN
		OutCode Eq.GetCmpName(EqParts(OpIdx).id, False) + GetLabelNm(m)
		OutCode "jmp " + GetLabelNm(ConditionFalseLabel)
	 END IF
	 Asm.PutLabel m

  ELSE

	 k = EqParts(OpIdx).id
	 EqParts(OpIdx).vartype = EqParts(l).vartype
	 n = Reg.AssignEq(GenRegToUse, OpIdx)
	 m = NewLabel
	 OutCode "xor " + RegNames(n) + Comma + RegNames(n)
	 '           / get inverse condition test opcode
	 OutCode CmpOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
	 OutCode Eq.GetCmpName$(k, True) + GetLabelNm(m)
	 OutCode "dec " + RegNames(n)
	 Asm.PutLabel m
  END IF
RETURN

END SUB

'
' To do: Optimize dividing with immediate values !!  like powers of 2 and -1
'        with right shifts.
'
SUB Eq.Asm.Div (OpIdx AS INTEGER)
 CONST DivOpCode = "idiv "
 CONST ShrOpCode = "shr "
 CONST CwdOpCode = "cwd"

 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM m AS INTEGER, n AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class
 rs = EqParts(r).class

 IF rs = LiteralNm AND EqParts(r).intval = 0 THEN
	FatalErr "Division through 0"
 END IF

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	CASE bytevar, intvar, longvar:
		 GOSUB Do.all.ints.div
	CASE ELSE:
		FatalErr OpTypesErrStr

 END SELECT

 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB

Do.all.ints.div:
	DIM ModReg AS INTEGER
	DIM DivReg AS INTEGER
	DIM TmpReg AS INTEGER

	SELECT CASE EqParts(l).vartype
	  CASE bytevar:
		   ModReg = AH: DivReg = AL: TmpReg = BL
	  CASE intvar:
		   ModReg = DX: DivReg = AX: TmpReg = cx
	  CASE longvar:
		   ModReg = EDX: DivReg = EAX: TmpReg = ECX
	END SELECT

	SELECT CASE ls
	  CASE RegNm
		SELECT CASE rs
		  CASE LiteralNm, ConstNm:
			 m = IsPowerOf2(EqParts(r).intval)
			 IF m THEN
				IF EqParts(r).intval <> 1 THEN
				   OutCode ShrOpCode + GetAsmValNm.Eq(l) + Comma + STR$(m)
				END IF
			 ELSE
				n = Reg.AssignEq(DivReg, l)    'reserve ax register / for counter
				n = Reg.AssignEq(TmpReg, r)    'reserve cx register for divider
										   'OPTIMIZE : bx or cx can be used!
				n = Reg.MakeFree(ModReg)      'free dx register   /
				OutCode CwdOpCode
				OutCode DivOpCode + GetAsmValNm.Eq(r)
			 END IF

		  CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free modulus register (dx for int)
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)

		  CASE ELSE: ReportErr 19283
		END SELECT

	  CASE LiteralNm, ConstNm
		SELECT CASE rs
		  CASE LiteralNm, ConstNm:
			 EqParts(l).intval = EqParts(l).intval \ EqParts(r).intval
		  CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)

		  CASE ELSE: ReportErr 19283
		END SELECT

	  CASE VarName, TempVarNm
		SELECT CASE rs
		  CASE LiteralNm, ConstNm:
			 m = IsPowerOf2(EqParts(r).intval)
			 IF m THEN
				IF EqParts(r).intval <> 1 THEN
				   n = Reg.AssignEq(TmpReg, l)
				   OutCode ShrOpCode + GetAsmValNm.Eq(l) + Comma + STR$(m)
				END IF
			 ELSE
				n = Reg.AssignEq(DivReg, l)    'reserve ax register / for counter
				n = Reg.AssignEq(TmpReg, r)    'reserve cx register for divider
										   'OPTIMIZE : bx or cx can be used!
				n = Reg.MakeFree(ModReg)      'free dx register   /
				OutCode CwdOpCode
				OutCode DivOpCode + GetAsmValNm.Eq(r)
			 END IF

		  CASE VarName, RegNm, TempVarNm

			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)

		  CASE ELSE: ReportErr 19283
		END SELECT

	  CASE ELSE: ReportErr 19283
	END SELECT
RETURN



END SUB

SUB Eq.Asm.FuncCall (OpIdx AS INTEGER)
 CONST CallOpCode = "call "
 DIM fun AS INTEGER
 DIM pushesFound AS INTEGER        'number of pushes found
 DIM l AS INTEGER
 DIM n AS INTEGER
 DIM m AS INTEGER
 DIM P AS INTEGER
 DIM EqTmp AS EqToken
 DIM GenRegToUse AS INTEGER
 DIM pushIdx(1 TO 40) AS INTEGER   'indexes to eq tokens of push operators
 

 fun = EqParts(EqParts(OpIdx).prev).id
 
'** Find & store indexes of push operators. Also sets vartype of push operator
'   to the one found at the param info index of the parameter for that
'   function, to allow for type checking/modification when passing parameters.
 n = EqParts(OpIdx).nextp
 IF n <> EOC THEN
  IF EqParts(n).class = Link THEN
	n = EqParts(n).extra
	DO
	   IF n <> EOC THEN
		  IF EqParts(n).class = OperatorNm AND EqParts(n).id = PushPrmOpr THEN
			 pushesFound = pushesFound + 1
			 IF pushesFound > UBOUND(pushIdx) THEN FatalErr "Argument list too long."
			 pushIdx(pushesFound) = n
			 EqParts(n).vartype = FuncArgInfo(FuncDescript(fun).ArgLstPtr + pushesFound - 1).vartype
			 IF Debugging THEN PRINT "Push operator at equation token"; n
		  END IF
	   ELSE
		  EXIT DO
	   END IF
	   n = EqParts(n).nextp
	LOOP
  END IF
 END IF

'** test number of parameter pushes
 n = FuncDescript(fun).NumArgs
 IF n <> pushesFound THEN
	FatalErr "Wrong argument list for call to " + GetSymName(FuncDescript(fun).symptr) + ". There should be" + STR$(n) + " argument(s), instead of" + STR$(pushesFound)
 END IF
 IF Debugging THEN PRINT "Total push operators found:"; pushesFound
 

'** change format of parameter list from:
'          <function identifier> <call> link< <PushPrmOpr param>* >
'   to:
'          <function identifier> <call> link< (PushPrmOpr link<param>)* >
 FOR n = 1 TO pushesFound
	 P = pushIdx(n)
	 EqTmp.class = Link
	 l = Eq.InsertToken(EqTmp, AddAfter, P)   'insert link after push op
	 EqParts(l).extra = EqParts(l).nextp      'sublist starts at param. eq
	 P = EqParts(l).nextp
	 EqParts(P).prev = BOC   'beginning of sublist in old token after push op
	 IF n < pushesFound THEN
		P = EqParts(pushIdx(n + 1)).prev
		EqParts(l).nextp = EqParts(P).nextp  'set next ptr of link to param sublist
		EqParts(P).nextp = EOC  'set end of new sublist (argument)
	 ELSE
		EqParts(l).nextp = EOC
	 END IF

	 'adjust .basis of all tokens in new eq sublist
	 m = EqParts(l).extra
	 DO
		EqParts(m).basis = l
		m = EqParts(m).nextp
	 LOOP UNTIL m = EOC

 NEXT

 Eq.Debug.Remake 0

 '** save all general purpose registers currently in use as temporary variables
 '   all other registers must be restored by the called function
 FOR n = AX TO EDX
	 IF RegInfo(n).InUse AND RegInfo(n).UsedBy THEN
		Eq.SaveAsTempVar RegInfo(n).UsedBy
	 END IF
 NEXT

 '** push all arguments, given from left to right according to BASIC call
 '   convention
 FOR n = 1 TO pushesFound
	 m = Eq.Solve.Term(pushIdx(n))
 NEXT

 '** Generate code for function call
 '**
 l = EqParts(OpIdx).prev  'index operand on right of operator
 n = EqParts(l).vartype
 IF n THEN
	SELECT CASE TypeInfo(n).size
		CASE 1: GenRegToUse = AL
		CASE 2: GenRegToUse = AX
		CASE 4: GenRegToUse = EAX
		CASE ELSE:    ReportErr 2312
	END SELECT
	n = Reg.MakeFree(GenRegToUse)        'free ax to hold return value
	OutCode "call " + GetAsmValNm.Eq(l)  'generate asm code for call
	EqParts(l).class = RegNm            'change the eq token from
	EqParts(l).id = GenRegToUse      'function call to register
	Reg.SetUsed GenRegToUse, l

 ELSE
	OutCode "call " + GetAsmValNm.Eq(l)  'generate asm code for call
 END IF

 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 EXIT SUB

END SUB

'  WARNING : REVERSING THE ORDER OF THE PARAMETERS RESULTS IN OTHER RESULTS!!
'  Virtually idenctical to Eq.Asm.Add !!!!
'  Only differences : error codes are negative
'                     other opcodes
'
SUB Eq.Asm.Minus (OpIdx AS INTEGER)
 CONST SubOpCode = "sub "
 CONST DecOpCode = "dec "

 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class
 rs = EqParts(r).class

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.Minus
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.Minus
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.Minus
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT


 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB


Do.all.ints.Minus:
 SELECT CASE ls
 CASE RegNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 IF EqParts(r).intval = 1 THEN
				OutCode DecOpCode + GetAsmValNm.Eq(l)
			 ELSEIF EqParts(r).intval <> 0 THEN
				OutCode SubOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
			 END IF
		CASE VarName, RegNm, TempVarNm:
			 OutCode SubOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
		CASE ELSE: ReportErr -13524
	  END SELECT

 CASE LiteralNm, ConstNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 EqParts(l).intval = EqParts(l).intval - EqParts(r).intval
		CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(GenRegToUse, l)
			 OutCode SubOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
		CASE ELSE: ReportErr -13524
	  END SELECT

 CASE VarName, TempVarNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 IF EqParts(r).intval = 1 THEN
				n = Reg.AssignEq(GenRegToUse, l)
				OutCode DecOpCode + GetAsmValNm.Eq(l)
			 ELSEIF EqParts(r).intval <> 0 THEN
				n = Reg.AssignEq(GenRegToUse, l)
				OutCode SubOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)
			 END IF

		CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(GenRegToUse, l)
			 OutCode SubOpCode + GetAsmValNm.Eq(l) + Comma + GetAsmValNm.Eq(r)

		CASE ELSE: ReportErr -13524
	  END SELECT

 CASE ELSE:
	  ReportErr -13524

 END SELECT
RETURN

END SUB

'   Optimize for immediate values, eg  x mod 128  ->  x and 127
'
'
SUB Eq.Asm.Mod (OpIdx AS INTEGER)
 CONST DivOpCode = "idiv "
 CONST CwdOpCode = "cwd"

 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class
 rs = EqParts(r).class

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	CASE bytevar, intvar, longvar:
		 GOSUB Do.all.ints.Mod
	CASE ELSE:
		FatalErr OpTypesErrStr

 END SELECT

 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB

Do.all.ints.Mod:
 DIM ModReg AS INTEGER
 DIM DivReg AS INTEGER
 DIM TmpReg AS INTEGER

 SELECT CASE EqParts(l).vartype
	CASE bytevar:
		 ModReg = AH: DivReg = AL: TmpReg = BL
	CASE intvar:
		 ModReg = DX: DivReg = AX: TmpReg = cx
	CASE longvar:
		 ModReg = EDX: DivReg = EAX: TmpReg = ECX
 END SELECT

 SELECT CASE ls
 CASE RegNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.AssignEq(TmpReg, r)    'reserve cx register for divider
									   'OPTIMIZE : bx or cx can be used!
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)
			 'Assign DX as result to right operand
			 Reg.SetFree DivReg
			 Reg.SetUsed ModReg, l

		CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free ModReg register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)
			 'Assign DX as result to right operand
			 Reg.SetFree DivReg
			 Reg.SetUsed ModReg, l

		CASE ELSE: ReportErr 19283
	  END SELECT

 CASE LiteralNm, ConstNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 EqParts(l).intval = EqParts(l).intval \ EqParts(r).intval
		CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)
			 'Assign ModReg as result to right operand
			 Reg.SetFree DivReg
			 Reg.SetUsed ModReg, l

		CASE ELSE: ReportErr 19283
	  END SELECT

 CASE VarName, TempVarNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.AssignEq(TmpReg, r)    'reserve cx register for divider
									   'OPTIMIZE : bx or cx can be used!
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)
			 'Assign DX as result to right operand
			 Reg.SetFree DivReg
			 Reg.SetUsed ModReg, l

		CASE VarName, RegNm, TempVarNm:
			 n = Reg.AssignEq(DivReg, l)    'reserve ax register
			 n = Reg.MakeFree(ModReg)    'free dx register
			 OutCode CwdOpCode
			 OutCode DivOpCode + GetAsmValNm.Eq(r)
			 ' Assign DX as result to right operand
			 Reg.SetFree DivReg
			 Reg.SetUsed ModReg, l

		CASE ELSE: ReportErr 19283
	  END SELECT

 CASE ELSE: ReportErr 19283
 END SELECT
RETURN

END SUB

' Eq.Asm.Mul  : handles the multiplication operator.
'   Input     : OpIdx = index to token containing the multiply operator.
'   Returns   : nothing
'   Changes   : the equation list at the index of the operators and operandi
'               Eq. result will ALLWAYS be returned in the LEFTHAND operand!!
'
'   Uses      : function GetAsmValNm.Eq
'               sub OutCode, Reg.AssignEq
'
'   To do   :  optimize multiplication of immediate values using "shl"
'   Bugs    :
'
SUB Eq.Asm.Mul (OpIdx AS INTEGER)
 CONST MulOpCode = "imul "
 CONST ShlOpCode = "shl "

 DIM l AS INTEGER, ls AS INTEGER
 DIM r AS INTEGER, rs AS INTEGER
 DIM m AS INTEGER, n AS INTEGER

 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator
 ls = EqParts(l).class: rs = EqParts(r).class

 'Swap the arguments if the right operator is more complicated then
 SELECT CASE ls                                  'the left operator.
	CASE RegNm
	CASE LiteralNm, ConstNm
		 SELECT CASE rs
		  CASE VarName, ConstNm, RegNm, TempVarNm:
			   Eq.SwapInfo l, r
		 END SELECT
	CASE VarName, TempVarNm
		 IF rs = RegNm THEN Eq.SwapInfo l, r
 END SELECT

 ls = EqParts(l).class ' Redefine local variables since arguments may be
 rs = EqParts(r).class ' swapped.

 IF rs = LiteralNm AND EqParts(r).intval = 0 THEN
	Warning "Multiplication with 0"
	EqParts(l).class = LiteralNm
	EqParts(l).intval = 0
 END IF

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar, intvar, longvar:
		  GOSUB Do.all.ints.Mul
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT
 
 Eq.SwapInfo l, OpIdx  'result is returned in the operator token
 Eq.DelToken l
 Eq.DelToken r
 EXIT SUB


Do.all.ints.Mul:
 DIM ExtReg AS INTEGER
 DIM MulReg AS INTEGER
 DIM TmpReg AS INTEGER

 SELECT CASE EqParts(l).vartype
	CASE bytevar:
		 ExtReg = AH: MulReg = AL: TmpReg = BL
	CASE intvar:
		 ExtReg = DX: MulReg = AX: TmpReg = cx
	CASE longvar:
		 ExtReg = EDX: MulReg = EAX: TmpReg = ECX
 END SELECT

 SELECT CASE ls
 CASE VarName, TempVarNm
	  SELECT CASE rs
		CASE LiteralNm:
			 m = IsPowerOf2(EqParts(r).intval)
			 IF m THEN
				IF EqParts(r).intval <> 1 THEN
				   n = Reg.AssignEq(GenWordReg, l)
				   OutCode ShlOpCode + GetAsmValNm.Eq(l) + Comma + STR$(m)
				END IF
			 ELSE
				n = Reg.AssignEq(MulReg, l)  'reserve ax register
				n = Reg.AssignEq(TmpReg, r)  'reserve cx register for divider
									   'OPTIMIZE : bx or cx can be used!
				n = Reg.MakeFree(ExtReg) 'free dx register
				OutCode MulOpCode + GetAsmValNm.Eq(r)
			 END IF

		CASE VarName, TempVarNm:
			 n = Reg.AssignEq(MulReg, l)     'reserve ax register
			 n = Reg.MakeFree(ExtReg)    'free dx register
			 OutCode MulOpCode + GetAsmValNm.Eq(r)

		CASE ELSE: ReportErr 321
	  END SELECT

 CASE LiteralNm
	  SELECT CASE rs
		CASE LiteralNm, ConstNm:
			 EqParts(l).intval = EqParts(l).intval * EqParts(r).intval
		CASE ELSE: ReportErr 32211
	  END SELECT

 CASE RegNm
	  SELECT CASE rs
		CASE RegNm:
			 IF EqParts(r).id = MulReg THEN SWAP l, r
			 n = Reg.AssignEq(MulReg, l)     'reserve ax register
			 n = Reg.MakeFree(ExtReg)    'free dx register
			 OutCode MulOpCode + GetAsmValNm.Eq(r)

		CASE VarName, TempVarNm:
			 n = Reg.AssignEq(MulReg, l)     'reserve ax register
			 n = Reg.MakeFree(ExtReg)    'free dx register
			 OutCode MulOpCode + GetAsmValNm.Eq(r)

		CASE LiteralNm:  'optimize this for powers of 2 !!
			 m = IsPowerOf2(EqParts(r).intval)
			 IF m THEN
				IF EqParts(r).intval <> 1 THEN
				   OutCode ShlOpCode + GetAsmValNm.Eq(l) + Comma + STR$(m)
				END IF
			 ELSE
				n = Reg.AssignEq(MulReg, l)  'reserve ax register
				n = Reg.AssignEq(TmpReg, r)  'reserve cx register for divider
									   'OPTIMIZE : bx or cx can be used!
				n = Reg.MakeFree(ExtReg) 'free dx register
				OutCode MulOpCode + GetAsmValNm.Eq(r)
			 END IF
			  
		CASE ELSE: ReportErr 32211
	  END SELECT

 CASE ELSE: ReportErr 32211

 END SELECT
RETURN

END SUB

SUB Eq.Asm.Neg (OpIdx AS INTEGER)
 CONST NegOpCode = "neg "
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse AS INTEGER

 r = EqParts(OpIdx).nextp  'index operand on right of operator
 rs = EqParts(r).class

 SELECT CASE EqParts(r).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)

	 CASE bytevar:
		  ' Negation is not supported for the byte type since it
		  ' represents an unsigned number.
		  GenRegToUse = GenByteReg
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.negate
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.negate
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT

 Eq.SwapInfo r, OpIdx  'result is returned in the operator token
 Eq.DelToken r
 EXIT SUB


Do.all.ints.negate:
 SELECT CASE rs
   CASE VarName, TempVarNm
		n = Reg.AssignEq(GenRegToUse, r)
		OutCode NegOpCode + GetAsmValNm.Eq(r)
   CASE LiteralNm
		EqParts(r).intval = -EqParts(r).intval
   CASE RegNm
		OutCode NegOpCode + GetAsmValNm.Eq(r)
   CASE ELSE: ReportErr 32211
 END SELECT
RETURN

END SUB

SUB Eq.Asm.NOT (OpIdx AS INTEGER)
 CONST NotOpCode = "not "
 DIM r AS INTEGER, rs AS INTEGER
 DIM n AS INTEGER
 DIM GenRegToUse  AS INTEGER

 r = EqParts(OpIdx).nextp  'index operand on right of operator
 rs = EqParts(r).class

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.NOT
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.NOT
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.NOT
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT
 
 Eq.SwapInfo r, OpIdx  'result is returned in the operator token
 Eq.DelToken r
 EXIT SUB


Do.all.ints.NOT:
 SELECT CASE rs
   CASE VarName, TempVarNm
		n = Reg.AssignEq(GenRegToUse, r)
		OutCode NotOpCode + GetAsmValNm.Eq(r)
   CASE LiteralNm, ConstNm
		EqParts(r).intval = NOT EqParts(r).intval
   CASE RegNm
		OutCode NotOpCode + GetAsmValNm.Eq(r)
   CASE ELSE: ReportErr 32211
 END SELECT
RETURN

END SUB

SUB Eq.Asm.PushParam (OpIdx AS INTEGER)
 CONST PushOpCode = "push "
 DIM r AS INTEGER
 DIM n AS INTEGER

 r = EqParts(OpIdx).nextp  'index operand on right of operator
 
 '** Check parameters for their type
 IF Eq.TypeMatch(r, OpIdx) = False THEN FatalErr "Function argument type mismatch."

 SELECT CASE EqParts(r).class
   CASE VarName, TempVarNm, LiteralNm, ConstNm, RegNm
		IF TypeInfo(EqParts(r).vartype).size = 1 THEN ConvertType r, intvar
		OutCode PushOpCode + GetAsmValNm.Eq(r)
   CASE ELSE: FatalErr "Internal error: illegal push operation."
 END SELECT
 Eq.DelToken OpIdx
 Eq.DelToken r

END SUB

SUB Eq.Asm.ZeroTest (idx AS INTEGER)
 CONST OpCode = "or "
 DIM GenRegToUse  AS INTEGER

 SELECT CASE EqParts(l).vartype  'left and right vartypes will always be the
								 'same (see Eq.Solve.Term)
	 CASE bytevar:
		  GenRegToUse = GenByteReg
		  GOSUB Do.all.ints.ZeroTest
	 CASE intvar:
		  GenRegToUse = GenWordReg
		  GOSUB Do.all.ints.ZeroTest
	 CASE longvar:
		  GenRegToUse = GenDWordReg
		  GOSUB Do.all.ints.ZeroTest
	 CASE ELSE:
		  FatalErr OpTypesErrStr
 END SELECT
 EXIT SUB

Do.all.ints.ZeroTest:
 SELECT CASE EqParts(idx).class
   CASE VarName, TempVarNm
		n = Reg.AssignEq(GenRegToUse, idx)
		OutCode OpCode + GetAsmValNm.Eq(idx) + Comma + GetAsmValNm.Eq(idx)
   CASE LiteralNm, ConstNm
   CASE RegNm
		OutCode OpCode + GetAsmValNm.Eq(idx) + Comma + GetAsmValNm.Eq(idx)
   CASE ELSE:

		ReportErr 3573
 END SELECT
RETURN

END SUB

SUB Eq.Debug.List
 IF Debugging = 0 THEN EXIT SUB
 DIM n AS INTEGER
 
 Eq.Debug.Remake 0
 GOSUB EqDebugListPrint
 FOR n = 1 TO UBOUND(EqParts)
	 IF EqParts(n).class THEN GOSUB EqDebugListPrint
 NEXT
 'FOR n = AX TO DX
 'NEXT
 EXIT SUB

EqDebugListPrint:
	COLOR 4
	PRINT "     "; n;
	COLOR 7
	LOCATE , 11
	IF EqParts(n).class = Link THEN
	   PRINT "--new sublist--";
	ELSE
	   Eq.Debug.Print n
	END IF
	COLOR 15
	LOCATE , 26: PRINT EqParts(n).class;
	LOCATE , 29: PRINT EqParts(n).id;
	LOCATE , 32: PRINT EqParts(n).vartype;
	COLOR 14
	LOCATE , 37: PRINT EqParts(n).prev;
	LOCATE , 41: PRINT EqParts(n).nextp;
	COLOR 15
	LOCATE , 46: PRINT EqParts(n).basis;
	LOCATE , 50: PRINT EqParts(n).extra;
	COLOR 7, 0
	PRINT
	RETURN

END SUB

SUB Eq.Debug.Print (n AS INTEGER)
   IF Debugging = 0 THEN EXIT SUB
   SELECT CASE EqParts(n).class
	CASE -1
		  PRINT " (";
		  Eq.Debug.Remake n
		  PRINT ")";
		  
	CASE OperatorNm:   PRINT " "; GetSymName(OperatorInfo(EqParts(n).id).symptr); " ";
	CASE VarName:      PRINT GetSymName(VarInfo(EqParts(n).id).symptr);
	CASE FunctionNm:   PRINT GetSymName(FuncDescript(EqParts(n).id).symptr);
	CASE TypeNm:       PRINT GetSymName(TypeInfo(EqParts(n).id).symptr);
	CASE KeyWordNm:    PRINT GetSymName(EqParts(n).symptr);

	CASE LiteralNm:    PRINT EqParts(n).intval;
	CASE LabelNm, ConstNm:  ReportErr 2390 'PRINT LabelNames(EqParts(n).id);
	CASE RegNm:        PRINT "reg."; GetAsmValNm.Eq(n);
	CASE TempVarNm:
					   PRINT Eq.GetTempVarNm(EqParts(n).id, TypeInfo(EqParts(n).vartype).size);

	CASE ArrayNm:      PRINT GetSymName(ArrayInfo(EqParts(n).id).symptr);
	CASE ELSE:         PRINT "unknown"; EqParts(n).class; EqParts(n).id;
   END SELECT

END SUB

'
'!!!  Made only for debugging purposes !!!!!!
'
SUB Eq.Debug.Remake (StartIndex AS INTEGER)
 
 DIM n AS INTEGER        ' counter: may not be changed otherwise then by loop

 n = EqParts(StartIndex).extra
 DO
   Eq.Debug.Print n
   IF EqParts(n).nextp <= 0 THEN EXIT DO
   n = EqParts(n).nextp
 LOOP
 IF StartIndex = 0 THEN PRINT

END SUB

' Eq.Deltoken deletes an token from the equation list by changing the
'               pointers to it. The class token is set to zero also, so
'               empty tokens are easily recongnized.
'
' Input   :  n : index number of eq token to delete
' OutPut  :  none
' Changes :  shared array EqParts, shared array RegInfo, FreeTmpSpacePtr
' Calls   :  none
' See also:  Eq.InsertToken
'
' Extra information: Essential role in freeing registers that are not
'                    anymore used !
'
SUB Eq.DelToken (n AS INTEGER)
   DIM m AS INTEGER

   'additional class-dependent stuff to do when deleting an eq token that is
   'no longer used
   SELECT CASE EqParts(n).class
	  CASE ArrayNm
			m = EqParts(n).extra
			Eq.DelToken n                'delete array addressing
			Eq.DelToken EqParts(n).nextp 'sub list
	  CASE RegNm:
		   Reg.SetFree EqParts(n).id
	  CASE TempVarNm:
		   'FreeTmpSpacePtr = FreeTmpSpacePtr - TypeInfo(EqParts(n).vartype).size
   END SELECT

   EqParts(n).class = 0  'set .class to zero : signal that the token is free
						'for use (this feature is used by Eq.InsertToken)

   IF EqParts(n).prev = BOC THEN 'token n at beginning of a chain
	 IF EqParts(n).nextp = EOC THEN   'and also last element in linked list:
		Eq.DelToken EqParts(n).basis  'remove link
	 ELSE
		EqParts(EqParts(n).basis).extra = EqParts(n).nextp
		EqParts(EqParts(n).nextp).prev = EqParts(n).prev
	 END IF
   ELSE
	 IF EqParts(n).nextp = EOC THEN    'token n at end of a chain
		EqParts(EqParts(n).prev).nextp = EOC
	 ELSE                       'token n at beginning or end of a chain
		EqParts(EqParts(n).prev).nextp = EqParts(n).nextp
		EqParts(EqParts(n).nextp).prev = EqParts(n).prev
	 END IF
   END IF

END SUB

FUNCTION Eq.FindFreeToken%
  DIM n AS INTEGER
  FOR n = 1 TO UBOUND(EqParts)
	  IF EqParts(n).class = 0 THEN Eq.FindFreeToken = n: EXIT FUNCTION
  NEXT
  FatalErr "Formula too complex."
END FUNCTION

' Eq.FindNextOp finds the first operator starting at the equation token FromEq
' and returns it's index.
' Used by: Eq.Solve.Whole
'
FUNCTION Eq.FindNextOp% (FromEq AS INTEGER)
  DIM m AS INTEGER
  DIM n AS INTEGER

   n = FromEq
   IF EqParts(n).class = OperatorNm THEN
	  Eq.FindNextOp = n
	  EXIT FUNCTION
   END IF

   DO
	  m = m + 1
	  IF m > 1 THEN FatalErr SyntaxErrStr + "No operator between equation elements."
	  n = EqParts(n).nextp
	  IF n = EOC THEN
		 EXIT DO
	  ELSE
		 IF EqParts(n).class = OperatorNm THEN EXIT DO
	  END IF
   LOOP

   Eq.FindNextOp = n

END FUNCTION

FUNCTION Eq.GetCmpName$ (RelOp AS INTEGER, Inverse AS INTEGER)

 SELECT CASE RelOp
	  CASE Eq: IF Inverse THEN Eq.GetCmpName = "jne " ELSE Eq.GetCmpName = "je "
	  CASE JG: IF Inverse THEN Eq.GetCmpName = "jle " ELSE Eq.GetCmpName = "jg "
	  CASE JL: IF Inverse THEN Eq.GetCmpName = "jge " ELSE Eq.GetCmpName = "jl "
	  CASE JLE: IF Inverse THEN Eq.GetCmpName = "jg " ELSE Eq.GetCmpName = "jle "
	  CASE JGE: IF Inverse THEN Eq.GetCmpName = "jl " ELSE Eq.GetCmpName = "jge "
	  CASE JNE: IF Inverse THEN Eq.GetCmpName = "je " ELSE Eq.GetCmpName = "jne "
	  CASE ELSE:
		   ReportErr 3985
 END SELECT


END FUNCTION

FUNCTION Eq.GetTempVarNm$ (id AS INTEGER, size AS INTEGER)
  DIM str AS STRING
  DIM n AS INTEGER

  str = Asm.GetMemPtrNm(size)

  IF n THEN
	 Eq.GetTempVarNm = str + "[$_temp_data+" + STR$(size) + "]"
  ELSE
	 Eq.GetTempVarNm = str + "[$_temp_data]"
  END IF

END FUNCTION

' Put instruction tokens into equation tokens (Eqtoken array EqParts).
' Assign params from instr. tokens into eq tokens.
'
' Parameters:  - InstrStart : index in instruction token array eq starts
'              - InstrEnd : index in instruction token array eq ends
'              - basis :  index number of link to current chain
'                        if 0 then: at real start of eq, else:not
'
' EqStr is DESTROYED by this procedure
'
'  WARNING : EQUATION HANDLING STILL NEEDS A LOT OF ERROR CHECKING
'            FOR EXAMPLE: NO CHECKING FOR EQUAL NUMBER OF "(" AND ")" !!!!
'
'
SUB Eq.GetTokens (BYVAL InstrStart AS INTEGER, BYVAL InstrEnd AS INTEGER, BYVAL basis AS INTEGER)
 STATIC ECnt AS INTEGER  ' Contains number of next arraytoken that can be
						 ' used; Must be preserved throughout recursive calls

 STATIC maxECnt AS INTEGER   ' Top of used eq tokens. Is set after calls to
							 ' Eq.InsertToken that makes the increase of ECnt
							 ' to find the next free eq token incorrect.
							 ' Used only if set. Reset during every loop


 STATIC OpenParentheses AS INTEGER
 STATIC InstrCnt AS INTEGER  ' Counter: current instruction token looked at
 STATIC MinInstrEl AS INTEGER
 STATIC MaxInstrEl AS INTEGER

 'semantics of comma: =0         : no reason for comma, error if occurs
 '                    =PushPrmOpr: passing operator in function parameter list
 '                    =ArySubscriptOpr :
 DIM EntryCommaMeaning AS INTEGER
 STATIC CommaMeaning AS INTEGER

 DIM prev AS INTEGER
 DIM n AS INTEGER
 DIM EqTmp AS EqToken
 
 'Start of the analysis of a new equation is signalled by basis = 0
 IF basis = 0 THEN
	'**  Reset the (static !) token array.
	ERASE EqParts
	ECnt = 0  'reset element counter on beginning of each new equation
	maxECnt = 0
	EqParts(0).prev = BOC
	EqParts(0).nextp = EOC
	InstrCnt = InstrStart - 1
	IF InstrEnd = 0 THEN MaxInstrEl = TotInstrTokens ELSE MaxInstrEl = InstrEnd
	CommaMeaning = 0
	EntryCommaMeaning = 0
 END IF

 prev = BOC  ' give first read token beginning of (sub)list signature
				   ' subparts have no pointers to their link, subparts can
				   ' be treated as autonomous units.


 EntryCommaMeaning = CommaMeaning
 EqParts(basis).extra = ECnt + 1

 '// divide equation in tokens and save these in array EqParts
 DO
 
   InstrCnt = InstrCnt + 1

   IF maxECnt THEN
	  ECnt = maxECnt + 1
	  maxECnt = 0
   ELSE
	  ECnt = ECnt + 1
   END IF

   IF ECnt > UBOUND(EqParts) THEN FatalErr "Formula too complex."

   '// If token is a "(" : sublist creation
   IF InstrParts(InstrCnt).class = KeyWordNm AND InstrParts(InstrCnt).id = LP THEN

			OpenParentheses = OpenParentheses + 1

			'// Make a new link to subdata; signalled by class = Link
			'   .extra is an index to the beginning of the subdata.
			EqParts(ECnt).class = Link  ' signal opening of sub-equation
			EqParts(ECnt).extra = ECnt + 1   'reference to sub-equation
			EqParts(ECnt).prev = prev  'install pointer to previous part
			EqParts(ECnt).basis = basis

			'.nextp is set at beginning of the to be done recursive call

			prev = ECnt 'Save the position of the link, because ECnt
						'is changed by the recursive call, needed for
						'the analysis of the subgroup.

			Eq.GetTokens ECnt, 0, prev   'ECnt -> base
		   
			'If the previous token was a function call and the current
			'a left parentheses then insert a "," operator !
			'This is needed since the following token will be an argument
			'worked upon by the "," operator which is a righthanded unary
			'operator, that pushes its operand onto the stack.
			IF CommaMeaning THEN
			   EqTmp.class = OperatorNm
			   EqTmp.id = CommaMeaning  'push parameter, or array subscript
			   n = EqParts(prev).extra
			   maxECnt = Eq.InsertToken(EqTmp, AddBefore, n)
			END IF

   '// If token is a  ")" : sublist is closed
   ELSEIF InstrParts(InstrCnt).class = KeyWordNm AND InstrParts(InstrCnt).id = RP THEN

			OpenParentheses = OpenParentheses - 1
			IF OpenParentheses < 0 THEN FatalErr "Too many left parentheses: ) ."

			IF EqParts(EqParts(basis).extra).class = 0 THEN FatalErr SyntaxErrStr + "Parentheses enclosing nothing."
			
			'// Close a list of subdata; signalled by : next = EOC .
			ECnt = ECnt - 1    'no new token
			EqParts(basis).nextp = EOC
			EqParts(ECnt).nextp = EOC

			'// If the eq token before the link whose sublist is now
			'   terminated, was a function call, then the end of the parsing
			'   of a parameter list is reached.
			n = EqParts(EqParts(ECnt).basis).prev
			IF EqParts(n).class = OperatorNm AND EqParts(n).class = CallOpr THEN
			   CommaMeaning = False
			END IF

			EXIT DO  'end of subformula encountered: end parsing of this part


   ELSE     '** register tokens other then parentheses

			SELECT CASE InstrParts(InstrCnt).class
				CASE OperatorNm, VarName
					 EqParts(ECnt).class = InstrParts(InstrCnt).class
					 EqParts(ECnt).id = InstrParts(InstrCnt).id
					 EqParts(ECnt).vartype = InstrParts(InstrCnt).vartype

				CASE ArrayNm
					 EqParts(ECnt).class = InstrParts(InstrCnt).class
					 EqParts(ECnt).id = InstrParts(InstrCnt).id
					 EqParts(ECnt).vartype = InstrParts(InstrCnt).vartype
					 EqParts(ECnt).prev = prev: prev = ECnt
					 EqParts(ECnt).basis = basis
					 EqParts(ECnt).nextp = ECnt + 1
					 ECnt = ECnt + 1
					 EqParts(ECnt).class = OperatorNm  'insert an "array acces"
					 EqParts(ECnt).id = AryAccessOpr   'operator

					 IF InstrParts(InstrCnt + 1).class = KeyWordNm AND InstrParts(InstrCnt + 1).id = LP THEN
						   CommaMeaning = ArySubOpr
					 ELSE FatalErr "Expected: array subscripts between parentheses"
					 END IF
					 
				CASE FunctionNm
					 EqParts(ECnt).class = InstrParts(InstrCnt).class
					 EqParts(ECnt).id = InstrParts(InstrCnt).id
					 EqParts(ECnt).vartype = InstrParts(InstrCnt).vartype
					 EqParts(ECnt).prev = prev: prev = ECnt
					 EqParts(ECnt).basis = basis
					 EqParts(ECnt).nextp = ECnt + 1
					 ECnt = ECnt + 1
					 EqParts(ECnt).class = OperatorNm  ' insert a "call"
					 EqParts(ECnt).id = CallOpr     ' operator
					 'EqTmp.class = OperatorNm'EqTmp.id = CallOpr'maxECnt = Eq.InsertToken(EqTmp, AddBefore, ECnt)

					 IF FuncDescript(InstrParts(InstrCnt).id).NumArgs > 0 THEN
						IF InstrParts(InstrCnt + 1).class = KeyWordNm AND InstrParts(InstrCnt + 1).id = LP THEN
						   CommaMeaning = PushPrmOpr
						ELSE FatalErr SyntaxErrStr + "Parameter list expected after function call."
						END IF
					 END IF
					 ' External representation of function:
					 '   <function identifier> [( arg [, arg]* )]
					 ' Internal representation of function after Eq.GetTokens:
					 '   <function identifier> <call operator> link< <,arg>* >

				' it's an immediate
				CASE LiteralNm, ConstNm
					 EqParts(ECnt).class = LiteralNm
					 EqParts(ECnt).id = InstrParts(InstrCnt).id
					 EqParts(ECnt).vartype = InstrParts(InstrCnt).vartype
					 EqParts(ECnt).intval = InstrParts(InstrCnt).intval

				CASE KeyWordNm:

					 '// a "," in a function argument list : push parameter operator
					 IF InstrParts(InstrCnt).id = kwComma AND CommaMeaning THEN
						EqParts(ECnt).class = OperatorNm
						EqParts(ECnt).id = CommaMeaning    'push parameter, or array subscript
					 ELSE
						FatalErr GetTokenName(InstrCnt) + " : illegal in equations."
					 END IF

				CASE UnknownNm:
					 FatalErr GetTokenName(InstrCnt) + " : unknown symbol"
				CASE ELSE
					 FatalErr GetTokenName(InstrCnt) + " : illegal in equations."
					 
			END SELECT

			IF prev > 0 THEN
			 IF EqParts(prev).class = Link THEN
			   EqParts(prev).nextp = ECnt
			 END IF
			END IF

			EqParts(ECnt).symptr = InstrParts(InstrCnt).symptr

			'// set up variables for possible following loop
			IF maxECnt THEN  ' install pointer to next eq. part
			   EqParts(ECnt).nextp = maxECnt + 1
			ELSE
			   EqParts(ECnt).nextp = ECnt + 1
			END IF
			EqParts(ECnt).prev = prev ' install pointer to previous part
			EqParts(ECnt).basis = basis
			prev = ECnt
			
   END IF
  
 LOOP UNTIL InstrCnt = MaxInstrEl

 ' unequal number of "(" and ")" parentheses produces an error
 IF basis = 0 AND OpenParentheses > 0 THEN FatalErr "Missing a left parenthesis ) ."

 ' give end-of-list sign, deinstall last pointer
 EqParts(ECnt).nextp = EOC
 
 CommaMeaning = EntryCommaMeaning

' The tokens forming equations are converted into another format which is used
' in the compilation of the equation. The format used is a double linked list
' allowing sub-lists, whose tokens are actually the same as the instruction
' tokens. This format is used since it is relatively easy to add and remove
' equation tokens and to allow the existence of sub-lists, that represent
' sub-equations (parts of equations enclosed with parentheses).

' External representation of function:
'   <function identifier> [( arg [, arg]* )]
' Internal representation of function after Eq.GetTokens:
'   <function identifier> <call operator> link< <,arg>* >
' Ultimate internal representation of function in Eq.Asm.FuncCall:
'   <function identifier> <call operator> link< (PushParamOp link<arg>)* >
'
' This last conversion is not done in Eq.GetTokens, but in the procedure
' handling function calls: Eq.Asm.FuncCall. After conversion Eq.Asm.FuncCall
' calls Eq.Solve.Whole, passing the index of the link for each argument.
'   The number of arguments can be checked by counting the number of argument
' push operators in the subequation following the call operator.
'   Parameter types can be checked by the parameter passing routine
' Eq.Asm.PushParam, because Eq.Asm.FuncCall has put the parameter info index
' into the .extra element of the parameter push operator's equation token.
							 

 ' Probleem bij analyse formule in elementen: Het opdelen in subonderdelen..
 '
 ' Wat is de bedoeling :
 '
 '  Als de parser een "(" tegenkomt, dan wordt het volgende deel tot de daar-
 '  bijbehorende ")" apart geanalyseerd. Binnen deze haakjes kunnen ook weer
 '  subdelen voorkomen (het zijn dus sub-sub-delen). En binnen deze wederom
 '  subdelen (sub-sub-sub-delen), enzovoort.
 '  Een subdeel wordt in de lijst gerepresenteerd door een token dat van
 '  het soort "link" is; d.w.z. dit token bevat een verwijzing naar het
 '  subdeel. Voordat dit subdeel gebruikt kan worden in de operatie waar hij
 '  voor nodig is, moet de waarde ervan berekend worden. Als bij het vertalen
 '  van een operatie blijkt dat een van de operandi een link is, wordt eerst
 '  de waarde van het deel dat achter deze link schuilgaat berekent.
 '  Hiertoe wordt de procedure die de formules uitrekent aangeroepen met
 '  als parameter het indexnummer in de elementenarray waar de beschrijving
 '  van de subformule begint. Als er in deze subformule weer een subformule
 '  bevindt, roept de functie zichzelf aan (recursie) met als parameter het
 '  indexnummer in de elementenarray waar de beschrijving van deze subformule
 '  begint.
 '  Van recursie kan ook gebruik gemaakt worden om de indeling in elementen
 '  te bewerkstelligen met links naar subonderdelen. Als de parser een "("
 '  tegenkomt, dan moet er een link gecreeerd worden naar een subformule.
 '  Om deze subformule te analyseren roept de analyserende procedure zichzelf
 '  aan. Aangezien de plek waar de subformule begint (de eerstvolgende
 '  positie in de array) variabel is, moet de procedure deze positie doorgeven
 '  aan zijn evenbeeld.
 '  Als de procedure voor het eerst wordt aangeroepen (dat wil zeggen niet
 '  door zichzelf) heeft de startpositie een vaste waarde (0) .
 '
 '  Elementen die van de soort "link" zijn, hoeven helemaal niet het einde
 '  van de ketting te zijn. Bijvoorbeeld: " x * link(bv. a-b/c ) + y "
 '  Zij moet de plaats van de volgende schakel in de formule ( "+" ) in
 '  de elementen array weten, omdat de elementen array feitelijk een linked
 '  list vormt.
END SUB

' Eq.InsertToken : insert an token in the equation tokens list
'                 mainly used to build up formula's or add tokens to them
'                 while saving the already loaded equation
'
'  Input : - Newtoken (Eqtoken) : defines token to be inserted
'          - AfterOrBefore : if AddBefore then( insert before Idx token )
'                            elseif AddAfter then( insert after Idx token )
'          - Idx : token before or after which token is inserted
'
FUNCTION Eq.InsertToken% (NewToken AS EqToken, BYVAL AfterOrBefore AS INTEGER, BYVAL idx AS INTEGER)
 DIM n AS INTEGER
 DIM NewIdx AS INTEGER


 ' Find a free EqParts token : signalled by EqParts().class = 0
 IF AfterOrBefore <> AddAt THEN
	NewIdx = Eq.FindFreeToken
 END IF
 
 IF AfterOrBefore = AddAt THEN   'insert new token _into _ Idx

	NewToken.extra = EqParts(idx).extra  'prevent change of pointers
	NewToken.basis = EqParts(idx).basis
	NewToken.prev = EqParts(idx).prev
	NewToken.nextp = EqParts(idx).nextp
	EqParts(idx) = NewToken


 ELSEIF AfterOrBefore = AddAfter THEN   'insert new token _after_ Idx

	EqParts(NewIdx) = NewToken
	IF EqParts(idx).nextp <> EOC THEN EqParts(EqParts(idx).nextp).prev = NewIdx
	EqParts(NewIdx).nextp = EqParts(idx).nextp
	EqParts(NewIdx).prev = idx
	EqParts(NewIdx).basis = EqParts(idx).basis
	EqParts(idx).nextp = NewIdx

 ELSEIF AfterOrBefore = AddBefore THEN   'insert new token _before_ Idx

	EqParts(NewIdx) = NewToken

	IF EqParts(idx).prev = BOC THEN
	   EqParts(EqParts(idx).basis).extra = NewIdx
	ELSE
	   EqParts(EqParts(idx).prev).nextp = NewIdx
	END IF

	EqParts(NewIdx).prev = EqParts(idx).prev
	EqParts(NewIdx).nextp = idx
	EqParts(NewIdx).basis = EqParts(idx).basis
	EqParts(idx).prev = NewIdx
	
 END IF

 Eq.InsertToken = NewIdx

END FUNCTION

' Eq.LValue checks whether the equation token at index eq is an lvalue:
' if so, it returns TRUE, else FALSE
'
FUNCTION Eq.LValue% (Eq AS INTEGER)

	SELECT CASE EqParts(Eq).class
	  CASE VarName: Eq.LValue = True
	  CASE ELSE:    Eq.LValue = False
	END SELECT

END FUNCTION

' Eq.Postprocess postprocesses the equation after it has been split in parts.
'
SUB Eq.Postprocess (StartIndex AS INTEGER)

 DIM n AS INTEGER        ' counter: may not be changed otherwise then by loop
 DIM k AS INTEGER        ' \
 DIM l AS INTEGER        '  temporary variables
 DIM m AS INTEGER        ' /

 DIM flag AS INTEGER
 DIM Pass1 AS INTEGER    ' use only for gosub calls to insert or to delete
						 ' tokens in the linked list !


 ' 1) Take care of prefixes like "-" as negation, and operators as
 '    "<>", ">=", "<=", and assignments like "+=", "*=", etc
 
  n = EqParts(StartIndex).extra
  DO
	 flag = 0

	 k = EqParts(n).prev
	 IF k > 0 THEN   'not the first token in a chain
	  IF EqParts(k).class = OperatorNm THEN
	   
	   l = EqParts(k).prev
	   'item is prefixed by "-" now check if it is a real prefix
	   IF EqParts(k).id = minus OR EqParts(k).id = Negate THEN
	   
		 IF EqParts(k).id = minus AND l = BOC THEN     'prefix-operator at beginning of equation
			IF EqParts(n).class = LiteralNm THEN
			   EqParts(n).intval = -EqParts(n).intval  'negate literal
			   Eq.DelToken k                         'erase "-"
			ELSE
			   EqParts(k).id = Negate
			END IF
			flag = 1

		 ELSEIF l <> BOC THEN 'prefix-operator in the middle of the equation
		
		   IF EqParts(l).class = OperatorNm THEN
			SELECT CASE EqParts(l).id
			  CASE Add:
						' "+-" encountered : change it into a single "-"
						Eq.DelToken l
						flag = 1

			  CASE minus, Negate:
						' "--" encountered : change it into a single "+"
						Eq.DelToken l   'remove "-" from "--"
						EqParts(k).id = Add 'change left "-" into "+"
						flag = 1

			  CASE ELSE:
						' "-" is prefixed by an operator that is not a "+"/"-"
						IF EqParts(n).class = LiteralNm THEN
						   EqParts(n).intval = -EqParts(n).intval  'negate literal
						   Eq.DelToken k                         'erase "-"
						   flag = 1
						ELSE
						   IF EqParts(k).id <> Negate THEN flag = 1
						   EqParts(k).id = Negate
						END IF
			END SELECT
		   END IF
		 END IF
		   
	   ELSEIF EqParts(k).id = Add THEN
	  
		 IF l = BOC THEN   'prefix-operator at beginning of equation
		   Eq.DelToken k    ' =>  "+" is a prefix
		   flag = 1

		 ELSE 'prefix-operator in between equation
		
		  IF EqParts(l).class = OperatorNm THEN
			SELECT CASE EqParts(l).id
			
			  CASE minus:
						' "-+" encountered : change it into a single "+"
						Eq.DelToken k         'remove "+" from "-+"
						flag = 1

			  CASE ELSE:
						'"+" is prefixed by another operator that is not a "-"
						Eq.DelToken k   'thus remove "+" from list
						flag = 1
			END SELECT
		  END IF
		 END IF

	   ELSEIF EqParts(k).id = Eq THEN
		 IF l <> BOC THEN   'prefix-operator at beginning of equation
		  IF EqParts(l).class = OperatorNm THEN
			SELECT CASE EqParts(l).id

			  CASE JG:
						' ">=" encountered : change it into a single JGE
						Eq.DelToken l             'remove ">" from ">="
						EqParts(k).id = JGE     'change left "=" into JGE
						flag = 1

			  CASE JL:
						' "<=" encountered : change it into a single JLE
						Eq.DelToken l             'remove "<" from "<="
						EqParts(k).id = JLE     'change left "=" into JLE
						flag = 1
			END SELECT
		  END IF
		 END IF

	   ELSEIF EqParts(k).id = JG THEN

		 IF l <> BOC THEN   'prefix-operator at beginning of equation
			IF EqParts(l).class = OperatorNm AND EqParts(l).id = JL THEN
			   ' "<>" encountered : change it into a single JNE
			   Eq.DelToken l             'remove "<" from "<>"
			   EqParts(k).id = JNE     'change left ">" into JNE
			   flag = 1
			END IF
		 END IF

	   END IF
		   
	 END IF
	END IF

   IF EqParts(n).class = Link THEN Eq.Postprocess n
   IF flag THEN
	  n = EqParts(StartIndex).extra
   ELSE
	  n = EqParts(n).nextp
   END IF

 LOOP UNTIL n = EOC


'
' 2) Swap order of some operandii, so more efficient code can be generated.
'
' Why should we swap the code ?
'
'   Examine the following formula :  y = 1 + function1(x,y)
'
'   Equations are always handled from left to right. A register will be loaded
'   with the value of the first operand and the value of the second operand
'   will be added. In some cases some or maybe all registers will be destroyed
'   when calculating the second value. The value of the first operand will
'   then have to be saved (for example on the stack) and afterwards restored.
'   This need to temporarily store a value can be prevented if we simply swap-
'   ped the order of the operandi. In our example this will result in the
'   formula :  y = function1(x,y) + 1 .
'   Now we do not need to save a temporary value because the adding of a
'   constant doesn't even need any registers.
'
' Given the operandi, when should the order be swapped ?
'
'   In the case of :
'
'       constant <operator> part with higher priority
'       constant <operator> array variable
'       constant <operator> type variable
'       constant <operator> function
'       simple variable <operator> part with higher priority
'       simple variable <operator> array variable
'       simple variable <operator> type variable
'       simple variable <operator> function
'       array variable <operator> part with higher priority
'       array variable <operator> function
'       type variable <operator> part with higher priority
'       type variable <operator> function
'
'
' What are the conditions that should be met to allow swapping operandi ?
'
'   Swapping is only allowed if the order of operandi doesn't influence the
'   result of the operation. This means swapping may not be used with the
'   operators "/", "-" and "mod" .
'
'

END SUB

SUB Eq.ResetForBuild

	ERASE EqParts
	EqParts(0).extra = 1
	EqParts(1).prev = BOC
	EqParts(1).nextp = EOC

END SUB

' Eq.SaveAsTempvar saves an equation token to a temporary variable. These
' are used for equation solving and condition variables in if..then and
' select case and loops. Temporary variables' use is deleted by restoring
' FreeTmpSpacePtr to it's value before usage of this procedure.
'
SUB Eq.SaveAsTempVar (idx AS INTEGER)
 DIM size AS INTEGER
 DIM n AS INTEGER

 size = TypeInfo(EqParts(idx).vartype).size
 
 IF FreeTmpSpacePtr + size > TmpSpaceAllocated THEN  'not enough temporary space
	TmpSpaceAllocated = FreeTmpSpacePtr + size
 END IF

 SELECT CASE EqParts(idx).class
   CASE VarName, TempVarNm
		n = Reg.AssignEq(GenWordReg, idx)
		OutCode "mov " + Eq.GetTempVarNm(FreeTmpSpacePtr, size) + Comma + GetAsmValNm.Eq(idx)
   CASE LiteralNm, ConstNm, RegNm
		OutCode "mov " + Eq.GetTempVarNm(FreeTmpSpacePtr, size) + Comma + GetAsmValNm.Eq(idx)
		IF EqParts(idx).class = RegNm THEN
		   Reg.SetFree EqParts(idx).id
		END IF
   CASE ELSE: ReportErr 2368
 END SELECT

 EqParts(idx).class = TempVarNm
 EqParts(idx).id = FreeTmpSpacePtr
 '.vartype is inherited from the old token

 FreeTmpSpacePtr = FreeTmpSpacePtr + size

END SUB

'  Eq.Solve.Term translates the expression around or right of (in the case of
'  logical not) to assembler and updates all links in the list accordingly.
'
'  Input : the index number in the token array of the operator in question.
'  Returns : index of token that contains result
'
FUNCTION Eq.Solve.Term% (OpIdx AS INTEGER)

 DIM l AS INTEGER
 DIM r AS INTEGER
 DIM n AS INTEGER

 '- Print the term resolved: for debugging purposes
 IF Debugging THEN
	IF EqParts(OpIdx).prev > 0 THEN Eq.Debug.Print EqParts(OpIdx).prev  'left operand
	Eq.Debug.Print OpIdx              'operator
	IF EqParts(OpIdx).nextp > 0 THEN Eq.Debug.Print EqParts(OpIdx).nextp  'right operand
	PRINT
 END IF

   
 l = EqParts(OpIdx).prev  'index operand on left of operator
 r = EqParts(OpIdx).nextp  'index operand on right of operator

 'check for LValue if operator is an assignment or "<operator>=" like
 IF (EqParts(OpIdx).id = Assign) OR EqParts(OpIdx).extra THEN
	IF NOT Eq.LValue(l) THEN FatalErr "Cannot assign a value to operand at left of assignment."
 END IF

 'IF Debugging THEN SLEEP

 n = OperatorInfo(EqParts(OpIdx).id).OperandSide
 IF n <> 1 THEN
	IF l < 0 THEN FatalErr "Expected operand at left"
	'if there's a left operand on which the operator works
	IF EqParts(l).class = Link THEN
	   IF Debugging THEN PRINT : PRINT : PRINT : COLOR 14: PRINT "SUB EQUATION": COLOR 7
	   Eq.Solve.Whole 0, l
	   IF Debugging THEN COLOR 14: PRINT ">>>> END SUB EQUATION": COLOR 7
	END IF
 END IF
 IF n <> 2 THEN
	IF r < 0 THEN FatalErr "Expected operand at right"
	'if there's a right operand on which the operator works
	IF EqParts(r).class = Link THEN
	   IF Debugging THEN PRINT : PRINT : PRINT : COLOR 14: PRINT "SUB EQUATION": COLOR 7
	   Eq.Solve.Whole 0, r
	   IF Debugging THEN COLOR 14: PRINT ">>>> END SUB EQUATION": COLOR 7
	END IF
 END IF

 '*** Do some automatic type conversion if there are different operandi.
 n = EqParts(OpIdx).id

 '*** If operator is really (not in the fake way the call operator does)
 '    using 2 operands, check if both operands have the same type.
 '    If not : error!
 IF OperatorInfo(n).OperandSide = 0 AND n <> CallOpr THEN
	IF Eq.TypeMatch(l, r) = False THEN FatalErr "Type mismatch."
 END IF

 '**** Generate the assembly code !!
 SELECT CASE n           'hmmm.. I wish basic had function ptrs
   CASE CallOpr: Eq.Asm.FuncCall OpIdx
   CASE PushPrmOpr: Eq.Asm.PushParam OpIdx
   CASE AryAccessOpr: Eq.Asm.AccessAry OpIdx
   CASE Negate:  Eq.Asm.Neg OpIdx
   CASE Add:    Eq.Asm.Add OpIdx
   CASE minus:   Eq.Asm.Minus OpIdx
   CASE mul:     Eq.Asm.Mul OpIdx
   CASE Div:     Eq.Asm.Div OpIdx
   CASE Modulus: Eq.Asm.Mod OpIdx
   CASE logNOT:  Eq.Asm.NOT OpIdx
   CASE logAND, logOR, logXOR: Eq.Asm.ANDORXOR OpIdx
   CASE Assign:  Eq.Asm.Assign OpIdx
   CASE Eq, JG, JL, JLE, JGE, JNE:
				 Eq.Asm.CMP OpIdx
   CASE ELSE: ReportErr 1985
 END SELECT
 'The Eq.Asm.* functions also _DELETE_ the resolved tokens from the
 'list, EXCEPT THE RESULT which is placed into THE OPERATOR token
 'The result of the term will ALLWAYS be returned in the OPERATOR token!
 'If there is no result, this can be checked: EqParts(OpIdx).class will
 'then be zero.

 IF EqParts(OpIdx).class = 0 THEN
	Eq.Solve.Term = 0
 ELSE
	'- if token is only one left in chain then put the result in the link
	IF EqParts(OpIdx).prev = BOC AND EqParts(OpIdx).nextp = EOC THEN
	   n = EqParts(OpIdx).basis
	   EqParts(OpIdx).prev = EqParts(n).prev
	   EqParts(OpIdx).nextp = EqParts(n).nextp
	   EqParts(OpIdx).basis = EqParts(n).basis
	   EqParts(n) = EqParts(OpIdx)

	   'if the token used a register: update the link from the RegInfo to
	   'the eq array token
	   IF EqParts(n).class = RegNm THEN
		  Reg.SetUsed EqParts(n).id, n
	   END IF

	   Eq.Solve.Term = n
	ELSE

	   ' put equation result into token
	   Eq.Solve.Term = OpIdx

	END IF
 END IF
	
 IF Debugging THEN
	PRINT "Complete formula: ";
	Eq.Debug.Remake 0
	'SLEEP
 END IF

' The cpu can use 3 types of input for calculations:
'     1) values in registers
'     2) values in memory locations
'     3) immediate values
' There is a need for a registration for each token where it can be found
' Proposal :  type CPUinputType
'                  int DataSort   'reg,mem,constant
'                  int DataExtraInfo
'                  int
'             end type
'
' The data elements of the language can be represented in just 2 types :
'     - memory locations (eg variables)
'     - immediate values (eg constants)
'
' The parser can identify the tokens in the list and replace them for the
' appropriate cpu names. Eg variable names are replaced by memory references,
' constants are replaced by their immediate value.
' This way it will be easier to output assembly code, since it is not
' necessary anymore to cope with all the different identifier, but restrict
' it to the use of registers, memory references and immediates.
'
' The memory references can be split up into a number of types:
'     - references to static data  which are situated in the data segment
'     - references to dynamic data which are situated in the stack segment
' To address both types it is necessary to store their offset relative to
' some place, preferably SI = 0 respectively BP at the point of entry of
' the last namespace.
' This relative offset is stored in the id element of th eq. tokens
' type at parsing time (to be precise in the sub Eq.GetTokens).
'
' There are some complications however :
'
'    External variables must be represented by a name in the asm file.
'    This can be handled with by storing the scope of a variable in an
'    token ......
'
' Working with values in registers goes a lot faster then values in memory
' locations. That's why we need to use them as much as possible. If we need
' a register and no registers are free, registers will be freed by pushing
' their values on the stack. These values will have to be taken from the
' stack when we need them again in
'
' It is important to have a good administration of which registers are not
' free and which values were pushed on the stack.

END FUNCTION

'  Eq.Solve.Whole roept zichzelf recursief aan, direct nadat een operator
'  gevonden is, waarbij de prioriteit van deze als parameter wordt
'  doorgegeven. Als de prioriteit van de volgende operator hoger is dan de
'  doorgegeven waarde, dan roept de functie zichzelf weer aan met deze hogere
'  prioriteit als parameter. zoniet dan wordt de instructie uitgewerkt.
'
' Translates the equation given by the tokens array starting at the
' token with the number StartIndex. If a link is encountered Eq.Solve.Whole will
' call itself (recursion) with StartIndex = token number of link.
'
'
'
SUB Eq.Solve.Whole (BYVAL OpIdx AS INTEGER, BYVAL basis AS INTEGER)

 DIM n AS INTEGER        ' counter: may not be changed otherwise then by loop
 DIM k AS INTEGER        ' \
 DIM l AS INTEGER        '  temporary variables
 DIM m AS INTEGER        ' /

 DIM PrevOpIdx AS INTEGER
 DIM NextOpIdx AS INTEGER
 DIM PrevPriorValue AS INTEGER
	
 IF OpIdx = 0 THEN       ' Find first operator in current level ...
	n = EqParts(basis).extra
	OpIdx = Eq.FindNextOp(n)
	IF OpIdx = EOC THEN
	   '* sub equation of only one token (else: error from Eq.FindNextOp)
	   '  starting at n
	   IF EqParts(n).class = Link THEN
		   Eq.Solve.Whole 0, n   'but the class was a link: so follow it!
		ELSE
		   'a single token between parentheses: take it out of the parentheses
		   Eq.SwapInfo basis, n
		   EqResult = basis
		END IF
		EXIT SUB
	END IF
 END IF

 PrevOpIdx = OpIdx
 PrevPriorValue = OperatorInfo(EqParts(OpIdx).id).priority

 '* Find next operator
 n = EqParts(PrevOpIdx).nextp
 IF n = EOC THEN NextOpIdx = EOC ELSE NextOpIdx = Eq.FindNextOp(n)

 'PRINT "First operator:"; PrevOpIdx; "  priority="; PrevPriorValue
 IF NextOpIdx <> EOC THEN   'Found a next operator
	  
	l = EqParts(NextOpIdx).id  'Get typenumber of operator.
	'PRINT "Next operator:"; NextOpIdx; "  priority="; OperatorInfo(l).Priority

	IF OperatorInfo(l).priority < PrevPriorValue THEN
	   '// Next operator has higher priority than previous
	   Eq.Solve.Whole NextOpIdx, EqParts(NextOpIdx).basis
	   Eq.Solve.Whole 0, EqParts(NextOpIdx).basis

	ELSE

	   '// Next operator has lower or equal priority than previous
	   EqResult = Eq.Solve.Term(PrevOpIdx)  '// Work out the subequation
	   Eq.Solve.Whole 0, EqParts(NextOpIdx).basis
		 
	END IF
	  
 ELSE   'End of equation : no next operator

	'// No next operator : end of equation.
	EqResult = Eq.Solve.Term(PrevOpIdx)   '// Work out the subequation

 END IF


END SUB

' Swaps the information of 2 tokens of the equation list.
' The links however are not changed : the order stays the same !!
'
SUB Eq.SwapInfo (l AS INTEGER, r AS INTEGER)

   'if an token to be swapped used a register : change the reference in
   'the RegInfo array
   IF EqParts(l).class = RegNm THEN RegInfo(EqParts(l).id).UsedBy = r
   IF EqParts(r).class = RegNm THEN RegInfo(EqParts(r).id).UsedBy = l
   

   SWAP EqParts(l), EqParts(r)
   SWAP EqParts(l).prev, EqParts(r).prev     'Do not change any pointer !!!
   SWAP EqParts(l).nextp, EqParts(r).nextp   'Only the eq info data should
   SWAP EqParts(l).basis, EqParts(r).basis   'be swapped !
   
		'n = EqParts(OpIdx).basis
		'EqParts(OpIdx).prev = EqParts(n).prev
		'EqParts(OpIdx).nextp = EqParts(n).nextp
		'EqParts(OpIdx).basis = EqParts(n).basis
		'EqParts(n) = EqParts(OpIdx)

END SUB

' Eq.TypeMatch makes sure that the .vartype of eq token Op is the same as the
' .vartype of eq token Ref.
' *NOT IMPLEMENTED YET*
' If they are not the same, then one of them is converted.
' If this is not possible it returns the errorcode False.
'
FUNCTION Eq.TypeMatch% (Op1 AS INTEGER, Op2 AS INTEGER)

	IF EqParts(Op1).vartype <> EqParts(Op2).vartype THEN
	   Eq.TypeMatch = False
	ELSE
	   Eq.TypeMatch = True
	END IF

END FUNCTION

' Equation is the main routine for solving equations, conditions as well as
'          assignments.
'          Changes first primary "=" from an equivalence test into an
'          assignment operator.
'
'
' Input:  * integer Modus:
'               = AssignEq:   the equation to solve is an assignment
'                 as a result:  - changes first EQ operator into an Assign
'                               - checks left operand of Assign for L-value
'               = ConditionEq:  the equation to solve is a condition test
'                 as a result:  - args TrueLabel and FalseLabel are used
'                               - setup and reset of condition optimalization
'                               - result is test for zero and jumps are accor-
'                                 dingly installed using True- and FalseLabel
'               = JustDoItEq: the eq has to be done as given, no jumps and
'                             no EQ change in Assign
'         * integer Where:
'               = DirectFromEq: use EqParts() as available
'                 This modus is meant to be used only with "handmade" eq's !
'               = FromInstr:   reread EqParts() from InstrParts()
'         * integer InstrStart   (only used if Modus = FromInstr)
'               index of InstrParts() to start copying into EqParts()
'         * integer InstrEnd   (only used if Modus = FromInstr)
'               index of InstrParts() to end copying into EqParts()
'         * integer TrueLabel
'               test if eq gives true as result and then jump to TrueLabel
'         * integer FalseLabel
'               test if eq gives false as result and then jump to FalseLabel
'
SUB Equation (modus AS INTEGER, where AS INTEGER, InstrStart AS INTEGER, InstrEnd AS INTEGER, TrueLabel AS INTEGER, FalseLabel AS INTEGER)
  DIM n AS INTEGER

  '**  Reset register usage info.
  ERASE RegInfo

  IF where = FromInstr THEN
	'**  Read new equation into token list.
	Eq.GetTokens InstrStart, InstrEnd, 0
  END IF

  IF modus = AssignEq THEN
	 GOSUB ChangeEQtoAssign
  ELSEIF modus = ConditionEq THEN
	 '*  Set up global variables used in optimization of condition tests.
	 DoingCondition = True
	 ConditionJumpsOptimized = False
	 ConditionFalseLabel = FalseLabel
	 ConditionTrueLabel = TrueLabel
  END IF

  '**  Handle prefixes and postfixes in equation.
  Eq.Postprocess 0

  n = FreeTmpSpacePtr       ' save tempvar ptr for restore after eq solving
  Eq.Solve.Whole 0, 0       '**  Output the assembly language code
  FreeTmpSpacePtr = n       '    restore tempvar ptr

  IF modus = ConditionEq THEN
	 GOSUB TestResultAndJump
	 DoingCondition = False
  END IF

  EXIT SUB


ChangeEQtoAssign:
  '** Change the appropriate equality test to assignment
  n = EqParts(0).extra
  DO
	IF EqParts(n).class = OperatorNm THEN
	   IF EqParts(n).id = Eq THEN
		  EqParts(n).id = Assign: EXIT DO
	   ELSEIF EqParts(n).id = Assign THEN EXIT DO
	   END IF
	END IF
	n = EqParts(n).nextp
  LOOP UNTIL n = EOC
RETURN


TestResultAndJump:
  '** Install jumps to specified labels for result of test if not already
  '   with code optimalization in Eq.Asm.CMP .
  IF ConditionJumpsOptimized = False THEN
	 Eq.Asm.ZeroTest EqResult  'test token for zero : result in CPU flag
	 IF TrueLabel <> 0 AND FalseLabel = 0 THEN
		OutCode "jz $+5"
		OutCode "jmp " + GetLabelNm(TrueLabel)
	 ELSEIF FalseLabel <> 0 AND TrueLabel = 0 THEN
		OutCode "jnz $+5"
		OutCode "jmp " + GetLabelNm(FalseLabel)
	 END IF
  END IF
RETURN

END SUB

FUNCTION GetAsmValNm$ (ViaEq AS INTEGER, idx AS INTEGER, class AS INTEGER, id AS INTEGER) STATIC
 DIM str AS STRING

'CONST StaticVar = 1
'CONST ByRefParam = 2
'CONST ByValParam = 3
'CONST TempVar = 4       '**not yet implemented: still an apart class**
'CONST StackVar = 5

 SELECT CASE class
	 CASE FunctionNm: GetAsmValNm = "_" + GetSymName(FuncDescript(id).symptr)

	 CASE VarName:
				   IF ViaEq THEN
					  str = Asm.GetMemPtrNm(TypeInfo(EqParts(idx).vartype).size)
				   ELSE
					  str = Asm.GetMemPtrNm(TypeInfo(InstrParts(idx).vartype).size)
				   END IF
				   
				   SELECT CASE VarInfo(id).storage
				   CASE StaticVar: ReportErr 23494
				   CASE ByRefParam: ReportErr 23497'GetAsmValNm = "" + GetSymName(VarInfo(id).symPtr)
				   CASE ByValParam: GetAsmValNm = str + "[bp+" + STR$(VarInfo(id).stackptr) + "]"
				   CASE TempVar: ReportErr 23496
				   CASE LocalVar: GetAsmValNm = str + "[bp-" + STR$(VarInfo(id).stackptr) + "]"
				   CASE GlobalVar: GetAsmValNm = "_" + GetSymName(VarInfo(id).symptr)
				   CASE ELSE: ReportErr 9375
				   END SELECT

	 CASE ArrayNm:
				   IF NOT ViaEq THEN ReportErr 2371
				   IF ArrayInfo(id).storage = StaticVar THEN
					  str = "[_" + GetSymName(ArrayNm)
				   ELSE
					  str = "["
				   END IF
				   n = EqParts(idx).extra
				   IF EqParts(n).class THEN    'class should be RegNm
					  str = str + "+" + RegNames(EqParts(n).id)
				   END IF
				   n = EqParts(n).nextp
				   IF EqParts(n).class THEN    'class should be RegNm
					  str = str + "+" + RegNames(EqParts(n).id)
				   END IF
				   n = EqParts(idx).intval
				   IF n THEN
					  str = str + "+" + STR$(n)
				   END IF
				   str = str + "]"
				   n = EqParts(idx).extra
				   
	 CASE LiteralNm:
				   IF ViaEq THEN
					  GetAsmValNm = STR$(EqParts(idx).intval)
				   ELSE
					  GetAsmValNm = STR$(InstrParts(idx).intval)
				   END IF

	 CASE RegNm:     GetAsmValNm = RegNames(id)
	 CASE TempVarNm: GetAsmValNm = Eq.GetTempVarNm(id, TypeInfo(EqParts(idx).vartype).size)
	 CASE ELSE:      ReportErr 4321  'illegal parameter
 END SELECT
END FUNCTION

FUNCTION GetAsmValNm.Eq$ (i AS INTEGER) STATIC

 GetAsmValNm.Eq = GetAsmValNm(1, i, EqParts(i).class, EqParts(i).id)


 'At least one of the operands must be in an register!!
 ' if (left in stack or mem) and (right in stack or mem) then
 '          ( get left in reg )
 '             |
 '              \  How to accomplish this?
 '                 If all regs filled, free whatever you need.
 '                 Since these regs must be restored the parameters of the
 '                 token that was using this reg must be changed to
 '                 point to the new position on the stack.
 '                 The old values will not be taken from the stack as soon as
 '                 the calculation is done.
 '                 When returning a stack value into a register, popping
 '                 should be used whenever it's the last value on the stack.
 '
 ' How to register the temporary storage in regs and stacks ??
 '
 ' 1) regs:   class    =  RegNm
 '            type    =  which reg
 '            id  =  - general purpose regs: * low byte  (AL,BL,CL,CH)
 '                                               * high byte (AH,BH,CH,DH)
 '                                               * word      (AX,BX,CX,DX)
 '                                               * dword     (EAX,EBX,ECX,EDX)
 '                       - pointer regs: * far ptr  (DS:SI,ES:DI)
 '                                       * near ptr (DI,SI)
 '
 ' 2) stack:  class    =  StackNm
 '            id  =  position relative to BP which is set to SP after
 '                       the routine was entered => this is a negative number
 '            type    =  no of bytes (since bytes,words or dwords can be pushed)
 '
 '
 ' How to incorporate this easily into the compiler ?
 '
 '     A function that takes the token as an argument will return a string
 '     containing all the code to access the token. For example, if you
 '     have an token which is a far pointer to some data, it will return
 '     "ds:[si+bx+100]"  or something like that. It will also generate the
 '     neccesary code to free registers when needed.
 '
 '

END FUNCTION

FUNCTION GetAsmValNm.I$ (i AS INTEGER) STATIC

   GetAsmValNm.I = GetAsmValNm(0, i, InstrParts(i).class, InstrParts(i).id)

END FUNCTION

'Reads an instruction from a source file.
'Also strips comments, handles multiple instructions on one line and
'handles line continuation characters.
'
'Input:   * shared variable InputFileHandle     : file ID
'
'Returns: * string containing whole next instruction in shared string SrcLine
'
SUB GetInstructFromFile
   CONST tb = 9
   CONST Sp = 32
   CONST Quote = 34
   CONST Remark = 39
   CONST Continue = 95
   CONST NewInstr = 58
   STATIC LeftOver AS STRING   'string left over after last read
							   'is only unequal to null when ":" was met
   STATIC tempstr AS STRING
   DIM rstr AS STRING
   DIM C AS INTEGER
   DIM m AS INTEGER
   DIM n AS INTEGER
   DIM P AS INTEGER
   DIM starti AS INTEGER
   DIM endi AS INTEGER
   DIM LnContinue AS INTEGER

   DO
	  IF LEN(LeftOver) THEN
		 rstr = LeftOver
		 LeftOver = ""
	  ELSE
		IF EOF(InputFileHandle) THEN
			EndOfSource = True
			EXIT SUB
		ELSE
			IF LnContinue THEN rstr = tempstr ELSE rstr = ""
			LINE INPUT #InputFileHandle, tempstr
			rstr = rstr + tempstr
			SrcLineNo = SrcLineNo + 1
		END IF
	 END IF

	 LnContinue = False

	 GOSUB JustGetTheCode
	 rstr = UCASE$(Trim(rstr))
   LOOP WHILE (rstr = "") OR (LnContinue = True)

   SrcLine = rstr
   EXIT SUB



JustGetTheCode:

	IF UCASE$(MID$(rstr, 1, 4)) = "REM " THEN
	   rstr = ""
	   RETURN
	END IF

	DEF SEG = SSEG(rstr)
	P = SADD(rstr)
	C = 0
	FOR n = 1 TO LEN(rstr)
		m = PEEK(P)
		SELECT CASE m
		  CASE tb:       POKE P, Sp 'change tab into a space so l/r trim work
		  CASE Quote:    C = C + 1

		  CASE Remark:   'Remark found : between quotes ?
						 IF (C AND 1) = 0 THEN rstr = LEFT$(rstr, n - 1): EXIT FOR

		  CASE NewInstr: 'end of instruction ":" found: between quotes ?
						 IF (C AND 1) = 0 THEN
							LeftOver = MID$(rstr, n + 1)
							rstr = LEFT$(rstr, n - 1)
							EXIT FOR
						 END IF
		END SELECT
		P = P + 1
	NEXT

	IF C AND 1 THEN FatalErr "odd number of quotes in string"

	rstr = Trim(rstr)
	IF RIGHT$(rstr, 1) = "_" THEN
	   tempstr = LEFT$(rstr, LEN(rstr) - 1)
	   LnContinue = True
	END IF
  RETURN

END SUB

FUNCTION GetLabelNm$ (LabelNum AS INTEGER)

	  GetLabelNm = "@" + LTRIM$(STR$(LabelNum))

END FUNCTION

SUB GetNextInstruction

  GetInstructFromFile
	 IF EndOfSource THEN
		IF OpenStructs > 0 THEN FatalErr SyntaxErrStr + "not all open structures are closed."
		EXIT SUB
	 END IF
	 IF Debugging THEN PRINT SrcLine
	 PRINT #OutputFileHandle, CrLf; ";"; LCASE$(SrcLine)

  Scan.Instruction
	 P.Init

END SUB

FUNCTION GetTokenName$ (t AS INTEGER)

   GetTokenName$ = MID$(SrcLine, InstrParts(t).PosInStr, InstrParts(t).TokenStrLen)

END FUNCTION

'  IdentifyToken identifies identifiers, using the symbol table, returning
'  info about the token with that name declared in the lowest scope.
'
'  Input: - nm        : the string containing the name to check
'         - fromScope : the current scope
'
'  Output:- class     : variable to which the class is returned
'         - retToken  : token to return. Members which are set here are:
'                       class, id, symPtr, and in case of a literal:
'                       intval, vartype
SUB IdentifyToken (nm AS STRING, fromScope AS INTEGER, retToken AS InstrToken)
 DIM k AS INTEGER
 DIM m AS INTEGER
 DIM sc AS INTEGER
 k = GetSymKey(nm)

 FOR sc = fromScope TO 0 STEP -1   ' Look in symbol table for name and
	 m = SearchSymbol(nm, sc, k)   ' get the symbol using this name that
	 IF m <> -1 THEN               ' has the least scope.

		retToken.class = SymTable(m).class
		retToken.id = SymTable(m).id
		retToken.symptr = m

		'** Additional class specific registration
		SELECT CASE retToken.class
		CASE OperatorNm, KeyWordNm, TypeNm
			 'nothing

		CASE VarName:   retToken.vartype = VarInfo(retToken.id).vartype
			 
		CASE FunctionNm: retToken.vartype = FuncDescript(retToken.id).vartype

		CASE ConstNm
			 m = ConstInfo(retToken.id).vartype
			 retToken.vartype = m
			 SELECT CASE m
				CASE bytevar, intvar, longvar
					 retToken.class = LiteralNm
					 retToken.intval = ConstInfo(retToken.id).intval
			 END SELECT
		END SELECT

		EXIT SUB

	 END IF
 NEXT

 m = IsLiteral(nm)
 IF m THEN
	retToken.class = LiteralNm
	retToken.vartype = m
	retToken.intval = VAL(nm)
	EXIT SUB
 END IF

 retToken.class = UnknownNm
 'FatalErr "Unknown token in instruction: "

END SUB

SUB IncrOpenStructs

	OpenStructs = OpenStructs + 1
	IF OpenStructs > UBOUND(StructStack) THEN FatalErr "Too much opened structures."

END SUB

SUB Init
  DIM m AS INTEGER
  DIM n AS INTEGER
  DIM str AS STRING

  RESTORE RegNameData
  n = 0
  DO
	n = n + 1
	READ str
	IF LEN(str) = 0 THEN EXIT DO
	RegNames(n) = str
	READ RegSize(n)
  LOOP
  
  RESTORE DefKeyWordNames
  n = 0
  DO
	n = n + 1
	READ str
	m = AddSymbol(str, 0, KeyWordNm, n)
  LOOP WHILE LEN(str)

  RESTORE DefTypeNames
  n = 0
  DO
	READ str
	IF LEN(str) = 0 THEN EXIT DO
	totTypes = totTypes + 1
	READ TypeInfo(totTypes).size
	READ TypeInfo(totTypes).class
	TypeInfo(totTypes).symptr = AddSymbol(str, 0, TypeNm, totTypes)
  LOOP

  RESTORE DefOperatorNames
  n = 0
  DO
	n = n + 1
	READ str
	IF LEN(str) = 0 THEN EXIT DO
	m = AddSymbol(str, 0, OperatorNm, n)
	OperatorInfo(n).symptr = m
	READ OperatorInfo(n).priority
	READ OperatorInfo(n).OperandSide
  LOOP
  totOperators = n

END SUB

'
' This function determines what sort of literal a given string represents.
' If the string isn't a literal (ie a number or string) then the value 0
' is returned otherwise it returns the type ID.
'
FUNCTION IsLiteral% (str AS STRING)
  DIM n AS INTEGER, ascval AS INTEGER, t AS STRING

  t = str

  'check if decimal number
  ascval = ASC(MID$(t, 1, 1))
  IF ascval >= 48 AND ascval <= 57 THEN
	IF LEN(t) = 1 THEN
		IsLiteral = intvar
		EXIT FUNCTION
	END IF
	FOR n = 2 TO LEN(t)
		ascval = ASC(MID$(t, n, 1))
		IF ascval < 48 OR ascval > 57 THEN
		   EXIT FOR
		ELSEIF n = LEN(t) THEN
		   IsLiteral = intvar
		   EXIT FUNCTION
		END IF
	NEXT n
  END IF

  'check if string
  IF ascval = 34 AND ASC(RIGHT$(t, 1)) = 34 THEN
	 IsLiteral = stringvar
	 EXIT FUNCTION
  END IF

  'check if hexadecimal number
  IF MID$(t, 1, 2) = "&H" THEN
	FOR n = 3 TO LEN(t)
		ascval = ASC(MID$(t, n, 1))
		IF (ascval >= 48 AND ascval <= 57) OR (ascval >= 65 AND ascval <= 70) THEN
		  IF n = LEN(t) THEN IsLiteral = intvar: EXIT FUNCTION
		ELSE
		  EXIT FOR
		END IF
	NEXT n
  END IF

END FUNCTION

SUB Junk

'** test for speed of GetInstructFromFile
' InputFileHandle = FREEFILE: OPEN "newqbtst.bas" FOR INPUT AS InputFileHandle
' mcnt = 30: t! = TIMER
' FOR c = 1 TO mcnt: GetInstructFromFile: NEXT
' t! = TIMER - t!: PRINT t!, t! / mcnt, 1 / (t! / mcnt): END

'** test for speed of symbol table routine AddSymbol
'  RANDOMIZE TIMER: mcnt = 250: t! = TIMER
'  FOR c = 1 TO mcnt: n = AddSymbol(CHR$(RND * 255), c, 3): NEXT
'  t! = TIMER - t!: PRINT t!, t! / mcnt, 1 / (t! / mcnt)
'  END
'** test for speed of symbol table routine IdentifyToken
'  n = AddSymbol("m", 0, 3):mcnt = 10000:t! = TIMER
'  FOR c = 1 TO mcnt: n = IdentifyToken("m", 0): NEXT
'  t! = TIMER - t!: PRINT t!, t! / mcnt, 1 / (t! / mcnt)
'  END
'** test for symbol table routine IdentifyToken
'  CLS
'  maxscope = 0
'  DO
'    INPUT "Symbol name to store"; nm$
'    nm$ = UCASE$(RTRIM$(LTRIM$(nm$)))
'    IF nm$ = "" THEN EXIT DO
'    INPUT "Scope of symbol"; sc
'    n = AddSymbol(nm$, sc, 111)
'    IF sc > maxscope THEN maxscope = sc
'    PRINT LEFT$(SymTable(n).nm, SymTable(n).nmlen); " is put into entry"; n
'    PRINT
'  LOOP
'  DO
'    INPUT "Enter symbol name to look up"; nm$
'    nm$ = UCASE$(RTRIM$(LTRIM$(nm$)))
'    IF nm$ = "" THEN END
'
'    n = IdentifyToken(nm$, maxscope)
'    IF n = -1 THEN
'       PRINT "Symbol name "; nm$; " of scope"; sc%; " not found."
'    ELSE
'       PRINT "Symbol found at entry"; n
'       PRINT LEFT$(SymTable(n).nm, SymTable(n).nmlen); " is a symbol of class"; SymTable(n).class; " and scope"; SymTable(n).scope
'    END IF
'    PRINT
'  LOOP

'***** THIS CODE WAS USED TO TEST THE AddVar2List FUNCTION *****
'  RANDOMIZE TIMER
'  CLS
'  TotVars = 0
'  DIM VarName AS STRING
'  DIM VarSort AS INTEGER
'
'  FOR n = 1 TO 5
'    VarName = ""
'    FOR x = 1 TO 1 + INT(RND * 2)
'     VarName = VarName + CHR$(65 + RND * 3)
'    NEXT x
'    IF RND > .5 THEN
'        VarName = VarName + MID$("%&!#$", 1 + INT(RND * 5), 1)
'        VarSort = 0
'    ELSE
'        VarSort = 1 + INT(RND * 5)
'    END IF
'    PRINT n; VarSort; VarName,
'    x = AddVar2List%(VarName, VarSort)
'    PRINT
'  NEXT n
'  PRINT
'  PRINT "Total variables ="; TotVars
'  FOR n = 1 TO TotVars
'   PRINT , n; VarType(n), VarNames(n)
'  NEXT n
'  END

'***** THIS CODE WAS USED TO TEST THE GetVars FUNCTION *****
'  CLS
'  DIM Args$(1 TO 12)
'  n = GetArgs%("mijn naamISTOCHmarcel", Args$(), "ISTOCH")
'  COLOR 15, 1
'  FOR m = 1 TO n
'    PRINT Args$(m);
'    PRINT ASC(RIGHT$(Args$(m), 1))
'  NEXT m
'  END

END SUB

SUB LegalName (str AS STRING)
   DIM NameErrStr AS STRING
   DIM n AS INTEGER
   DIM char AS STRING
   DIM LegalChars AS STRING

   NameErrStr = "Illegal symbol name: " + str

   IF LEN(str) > MaxNameLength THEN FatalErr NameErrStr + ". Name is too long."

   LegalChars = Alphabet + Numbers + "_"

   'Check first letter : only letters in the alphabet and "_" are allowed
   char = MID$(str, 1, 1)
   IF INSTR(Alphabet, char) = 0 AND char <> "_" THEN
	  FatalErr NameErrStr + ". " + char + " is an illegal first character for a name."
   END IF

   'Check the rest of the string
   FOR n = 2 TO LEN(str)
	 char = MID$(str, n, 1)
	 IF INSTR(LegalChars, char) = 0 THEN
		FatalErr NameErrStr + " " + char + " is an illegal character for a name."
	 END IF
   NEXT

   'Check last letter for "_" : only letters and numbers are allowed at end
   IF char = "_" THEN
	  FatalErr NameErrStr + ". Underscores are not allowed as the last character of identifiers."
   END IF

END SUB

FUNCTION NewLabel%
   STATIC LabelCnt

   LabelCnt = LabelCnt + 1
   NewLabel = LabelCnt

END FUNCTION

SUB OutAsmLn (t AS STRING)

  IF Debugging THEN
	 PRINT "  ";
	 COLOR 14, 4
	 PRINT t;
	 COLOR 7, 0
	 Reg.Debug.Print
	 PRINT
  END IF

  PRINT #OutputFileHandle, "  "; t
  
  'Eq.Debug.Remake 0
  'SLEEP

END SUB

SUB OutCode (t AS STRING)

	IF CurSeg <> CodeSeg THEN
	   OutAsmLn ".CODE"
	   CurSeg = CodeSeg
	END IF

	OutAsmLn t

END SUB

SUB OutData (t AS STRING)

	IF CurSeg <> DataSeg THEN
	   OutAsmLn ".DATA"
	   CurSeg = DataSeg
	END IF

	OutAsmLn t

END SUB

SUB P.Const
  DIM n AS INTEGER

  P.Need KeyWordNm, kwCONST

  DO

	'\\ Parse parameter info
	P.ConstAssign
  LOOP WHILE P.Match(KeyWordNm, kwComma)

  P.Need -1, 0

END SUB

' P.ConstAssign: Parses the instruction from the current token
' Parsing examples: <constant> ::= <constant expression>
'                   pi = 3.14159
'                   AscM = asc("M")
' Used by P.Const only!
'
SUB P.ConstAssign
  DIM id AS INTEGER
  DIM n AS INTEGER
  DIM P AS INTEGER
  DIM constExprEnd AS INTEGER
  DIM IdentTok AS INTEGER

  IF NoNextToken THEN FatalErr "Unexpected end of instruction."

  IdentTok = CurTok
  P.NextToken
  P.Need OperatorNm, Eq

  IF NoNextToken OR P.Match(KeyWordNm, kwComma) THEN FatalErr "constant expression expected"

  '** Determine end of constant expression: signalled by crlf or by
  '   a comma outside of a function call (recognisable by the lack of open
  '   parentheses)
  FOR n = CurTok TO TotInstrTokens
	  IF InstrParts(n).class = KeyWordNm THEN
		 SELECT CASE InstrParts(n).id
		   CASE LP: P = P + 1
		   CASE RP: P = P - 1
		   CASE kwComma:
				IF P = 0 THEN
				   constExprEnd = n
				   EXIT FOR
				END IF
		 END SELECT
	  END IF
  NEXT

  IF constExprEnd THEN constExprEnd = constExprEnd - 1 ELSE constExprEnd = TotInstrTokens

  Equation JustDoItEq, FromInstr, CurTok, constExprEnd, 0, 0
  n = EqParts(EqResult).class
  IF (n = LiteralNm OR n = ConstNm) = 0 THEN
	 FatalErr "Cannot solve constant expression due to illegal element."
  END IF

  InstrParts(IdentTok).id = AddConst2List(GetTokenName(IdentTok), EqParts(EqResult).vartype, EqParts(EqResult).intval)
  InstrParts(IdentTok).vartype = EqParts(EqResult).vartype
  InstrParts(IdentTok).class = ConstNm  'identifier was of class UnknownNm

  CurTok = constExprEnd
  P.NextToken
  
END SUB

SUB P.Dim
  DIM n AS INTEGER

  P.Need KeyWordNm, kwDIM
  
  DO

	'\\ Parse parameter info
	P.VarTyping

  LOOP WHILE P.Match(KeyWordNm, kwComma)
	
  IF NOT NoNextToken THEN FatalErr "end of DIM statement expected"

END SUB

' P.FuncParameter:  Parses a parameter in the function head
'                   and sets the parameter description elements.
'                   Also takes care of proper setting of variable info
'                   linked to, to represent a parameter variable
'                   It expects a specific syntax, and gives an error if
'                   it doesn't match.
' Parsing examples: "byval x as integer" **byval and byref not yet implemented**
'                   "b_ptr as byte ptr"  **pointers neither**
' Called by: Do.Function
'
SUB P.FuncParameter
  DIM ParamType AS INTEGER
  DIM ParamTok AS INTEGER
  DIM PassMode AS INTEGER
  DIM n AS INTEGER

  ParamTok = CurTok  'save index of token containing parameter identifier

  IF NoNextToken THEN FatalErr "Expected: parameter list."

  P.NextToken
  ParamType = P.TypeOfIdent

  PassMode = ByValParam
  ParamInfoTop = ParamInfoTop + 1
  IF ParamInfoTop > UBOUND(FuncArgInfo) THEN FatalErr "Cannot store any more function argument information."

  n = AddVar2List(GetTokenName(ParamTok), ParamType)
  InstrParts(ParamTok).class = VarName  'identifier was of class UnknownNm
  InstrParts(ParamTok).id = n

  FuncArgInfo(ParamInfoTop).PassMode = PassMode  ' **not yet implemented**
  VarInfo(n).storage = PassMode      '  \ standard for now  /

  FuncArgInfo(ParamInfoTop).vartype = VarInfo(n).vartype
  FuncArgInfo(ParamInfoTop).VarInfoPtr = n

  IF PassMode = ByRefParam THEN
	 FuncArgInfo(ParamInfoTop).Bytes2Pass = 4
  ELSEIF PassMode = ByValParam THEN
	 FuncArgInfo(ParamInfoTop).Bytes2Pass = TypeInfo(VarInfo(n).vartype).size
  END IF
	 
  n = FuncDescript(CurFunc).Bytes2Pass
  FuncDescript(CurFunc).Bytes2Pass = n + FuncArgInfo(ParamInfoTop).Bytes2Pass

END SUB

SUB P.Init

	CurTok = 1
	NoNextToken = False     'reset flag which is set during parsing when
							'the end of the instruction is encountered.
END SUB

' P.Match returns True if the current token, given by index CurTok into
' InstrParts(), is equal to a type specified by TokClass and TokIdx,
' else it returns False.
' If the two "tokens" are equal then CurTok is increased
'
FUNCTION P.Match% (TokClass AS INTEGER, TokIdx AS INTEGER)

	IF InstrParts(CurTok).class = TokClass AND InstrParts(CurTok).id = TokIdx THEN
	   P.Match = True
	   P.NextToken
	END IF

END FUNCTION

' P.Need expects the current token, given by index CurTok into InstrParts(),
' to be equal to a type specified by TokClass and TokIdx.
' If this is not the case it returns an error.
' P.Need checks for the end of an instruction if TokClass=-1 and TokIdx=-1
' P.Need checks if instruction continues if TokClass=0 and TokIdx=-1
'
SUB P.Need (TokClass AS INTEGER, TokIdx AS INTEGER)

	IF (TokClass = -1 AND TokIdx = 0) THEN
	   IF NoNextToken = False THEN FatalErr "Expected: end of statement"
	   EXIT SUB
	ELSEIF (TokClass = 0 AND TokIdx = -1) THEN
	   IF NoNextToken THEN FatalErr "Unexpected end of statement"
	   EXIT SUB
	ELSEIF NoNextToken THEN
	   FatalErr "Expected: " + GetSymName(InstrParts(CurTok).symptr) + " of class" + STR$(TokClass) + " and id" + STR$(TokIdx)
	END IF
	
	IF InstrParts(CurTok).class = TokClass AND InstrParts(CurTok).id = TokIdx THEN
	   P.NextToken
	ELSE
	   FatalErr "Expected: " + GetSymName(InstrParts(CurTok).symptr) + " of class" + STR$(TokClass) + " and id" + STR$(TokIdx)
	END IF
	
END SUB

SUB P.NextToken

	CurTok = CurTok + 1
	IF CurTok > TotInstrTokens THEN NoNextToken = True

END SUB

' P.TypeOfIdent: Parses the instruction and returns the ID of the type found;
'               it expects a specific syntax, and gives an error if
'               there isn't a match.
' Parsing examples: "as integer"
'                   "as byte"
'
FUNCTION P.TypeOfIdent%
	
	P.Need KeyWordNm, kwAS
	IF InstrParts(CurTok).class = TypeNm THEN
	   P.TypeOfIdent = InstrParts(CurTok).id
	   P.NextToken
	ELSE
	   FatalErr "Expected: variable type identifier."
	END IF
	
END FUNCTION

' P.VarTyping:  Parses the instruction from the current token
'               it expects a specific syntax, and gives an error if
'               it doesn't match.
'
' Parsing examples: "x as integer"
'                   "b_ptr as byte ptr"  **pointers are not yet implemented**
'                   "text(1 to 10) as integer"
'
' Generates assembly code for global variables and for locals adjusts the
' variable space allocated.
'
' Used by:      P.Dim   only!
'
SUB P.VarTyping
  DIM id AS INTEGER
  DIM l AS INTEGER
  DIM m AS INTEGER
  DIM n AS INTEGER
  DIM bStart AS INTEGER
  DIM bEnd AS INTEGER
  DIM AnotherDim AS INTEGER
  DIM IdentTok AS INTEGER
  DIM OpenParen AS INTEGER
  DIM CurDim AS INTEGER
  
  P.Need 0, -1   'check if there's no end of instruction
  IdentTok = CurTok
  P.NextToken

  IF P.Match(KeyWordNm, LP) THEN    'array declaration!

	 n = AddArray2List(GetTokenName(IdentTok))
	 InstrParts(IdentTok).class = ArrayNm
	 InstrParts(IdentTok).id = n
	 ArrayInfo(n).dimptr = DimInfoTop + 1
	 CurDim = 0
	 DO
		DimInfoTop = DimInfoTop + 1
		IF DimInfoTop > UBOUND(DimInfo) THEN FatalErr "Cannot store any more array dimension information."
		DimInfo(DimInfoTop).aryptr = totArrays
		CurDim = CurDim + 1
		AnotherDim = 0
		bStart = CurTok

		'** find "TO" to determine lower bound
		FOR n = bStart TO TotInstrTokens
		  IF InstrParts(n).class = KeyWordNm AND InstrParts(n).id = kwTO THEN
			IF bStart = n THEN FatalErr "Unspecified lower bound of array"
			CurTok = n    'CurTok now points to "TO"
			bEnd = n - 1
			EXIT FOR
		  END IF
		NEXT
		IF bStart > TotInstrTokens THEN FatalErr "Expected: TO"
	 
		'calculate and store lower array bound
		Equation JustDoItEq, FromInstr, bStart, bEnd, 0, 0
		n = EqParts(EqResult).class: IF n <> LiteralNm THEN FatalErr "Cannot solve constant expression due to illegal element."
		DimInfo(DimInfoTop).lb = EqParts(EqResult).intval

		'find "," or ")" to determine UPPER BOUND
		OpenParen = 0
		bStart = CurTok + 1
		FOR n = bStart TO TotInstrTokens
		  IF InstrParts(n).class = KeyWordNm THEN
			 m = InstrParts(n).id
			 IF m = LP THEN OpenParen = OpenParen + 1
			 IF OpenParen = 0 THEN
				IF m = RP OR m = kwComma THEN
				   IF bStart = n THEN FatalErr "Unspecified upper bound of array"
				   CurTok = n
				   P.NextToken
				   bEnd = n - 1
				   IF m = kwComma THEN AnotherDim = True
				   EXIT FOR
				END IF
			 ELSEIF m = RP THEN OpenParen = OpenParen - 1
			 END IF
		  END IF
		NEXT
		IF bStart > TotInstrTokens THEN FatalErr "Expected: , or )"

		'calculate and store upper array bound
		'IF Debugging THEN PRINT "ubound starts at"; bStart; " and ends at"; bEnd
		Equation JustDoItEq, FromInstr, bStart, bEnd, 0, 0
		n = EqParts(EqResult).class: IF n <> LiteralNm THEN FatalErr "Cannot solve constant expression due to illegal element."
		DimInfo(DimInfoTop).ub = EqParts(EqResult).intval
		IF Debugging THEN
		   'PRINT "Dimension"; CurDim; "of "; GetSymName(ArrayInfo(DimInfo(DimInfoTop).aryptr).symptr)
		   'PRINT "Upper bound of array="; DimInfo(DimInfoTop).UB
		   'PRINT "Lower bound of array="; DimInfo(DimInfoTop).lb
		END IF
	 LOOP WHILE AnotherDim

	 ArrayInfo(totArrays).vartype = P.TypeOfIdent
	 ArrayInfo(totArrays).dims = CurDim
	 IF CurScope = 0 THEN
		ArrayInfo(totArrays).storage = StaticVar
	 ELSE
		ArrayInfo(totArrays).storage = LocalVar
	 END IF

	 '** Calculate value to multiply with the offset of each dimension to
	 '   get dimension base offset
	 '   by default: store arrays in row-major order (column-major order option
	 '   not yet implemented)
	 l = TypeInfo(ArrayInfo(totArrays).vartype).size
	 FOR n = CurDim TO 1 STEP -1
		 m = ArrayInfo(totArrays).dimptr + n - 1   'm = index of current dim
		 DimInfo(m).mul = l
		 l = l * (DimInfo(m).ub - DimInfo(m).lb + 1)
		 IF Debugging THEN PRINT "dim"; n; DimInfo(m).lb; "to"; DimInfo(m).ub; "multiply"; DimInfo(m).mul
	 NEXT
	 
	 IF Debugging THEN
		'PRINT "Type of array="; GetSymName(TypeInfo(ArrayInfo(totArrays).vartype).symptr)
		'PRINT "Dimensions ="; ArrayInfo(totArrays).dims
		'PRINT
		'SLEEP
	 END IF

	 AllocData ArrayNm, InstrParts(IdentTok).id

  'no array, just a variable
  ELSE

	 m = P.TypeOfIdent
	 InstrParts(IdentTok).id = AddVar2List(GetTokenName(IdentTok), m)
	 id = InstrParts(IdentTok).id
	 InstrParts(IdentTok).class = VarName  'identifier was of class UnknownNm
	 AllocData VarName, InstrParts(IdentTok).id

  END IF

END SUB

'  Reg.AssignEq assigns an equation token to a register, thereby changing
'  it into an token of the register type.
'
'  Input   :* ReqReg : the register that should be filled with a value
'           * EqElem : the index in the equation elem list that references to
'                      the eq token to be assigned to a register specified
'                      by ReqReg
'
'  Returns : In case of more then one possible register, it returns an
'            integer equal to number of the register filled with that value.
'
'  Uses    : function Reg.IsFree
'            sub Reg.MakeFree
'            function GetAsmValNm.Eq
'            sub Reg.Push
'
'  Changes: - EqParts() at index given by EqElem
'           - RegInfo() (.InUse and .UsedBy)
'
FUNCTION Reg.AssignEq% (ReqReg AS INTEGER, EqElem AS INTEGER)

  DIM n AS INTEGER

   '* If equation token already filled with the reg: exit proc
   IF EqParts(EqElem).class = RegNm THEN
	  IF EqParts(EqElem).id = ReqReg THEN EXIT FUNCTION
   END IF
   
   '* Check if requested register is free for use & determine register to be
   '  used if more then one possible register is possible.

   n = Reg.IsFree(ReqReg)

   '* No free register was found: free the register wanted
   IF n = 0 THEN ReqReg = Reg.MakeFree(ReqReg) ELSE ReqReg = n
   
   '** Check if the equation token to be put in a register has
   '** a compatible type.
   n = False
   IF TypeInfo(EqParts(EqElem).vartype).size <> RegSize(ReqReg) THEN
	  ReportErr 23587
   END IF
   
   ' Assign the contents of an equation token to the register.
   '/
   n = EqParts(EqElem).class
   IF n = LiteralNm AND EqParts(EqElem).intval = 0 THEN
	  OutCode "xor " + RegNames(ReqReg) + Comma + RegNames(ReqReg)
   ELSE
	  IF n = RegNm THEN
		 ' If eq token was already a register token :
		 ' set the former register to unused
		 Reg.SetFree EqParts(EqElem).id
	  END IF
	  IF n <> OperatorNm THEN
		 OutCode "mov " + RegNames(ReqReg) + Comma + GetAsmValNm.Eq(EqElem)
	  END IF
   END IF

   '** Register use of requested register ReqReg by EqElem.
   Reg.SetUsed ReqReg, EqElem
   
   '** Return register to which the equation token was assigned.
   Reg.AssignEq = ReqReg

END FUNCTION

SUB Reg.Debug.Print
  IF Debugging = 0 THEN EXIT SUB
  DIM x AS INTEGER
  DIM Y AS INTEGER
  DIM n AS INTEGER

	x = POS(0)
	Y = CSRLIN
	VIEW PRINT 24 TO 25
	LOCATE 24, 1

	FOR n = AX TO DX
	  FOR m = 0 TO 12 STEP 4
		IF RegInfo(n + m).InUse THEN
		   COLOR 14, 0
		ELSE
		   COLOR 7, 0
		END IF
		PRINT UCASE$(RegNames(n + m)); " ";
	  NEXT
	  PRINT "      ";
	NEXT

	VIEW PRINT 1 TO 23
	LOCATE Y, x
	COLOR 7, 0

END SUB

' Reg.IsFree returns TRUE if the register is not in use and FALSE if it is
' in use.
' If more then one possible register is possible, determines register to be
' used, and returns its number.
'
FUNCTION Reg.IsFree% (WhichReg AS INTEGER)
   DIM n AS INTEGER

   SELECT CASE WhichReg
	 CASE GenWordReg:
			  FOR n = AX TO DX
				  IF RegInfo(n).InUse = 0 THEN Reg.IsFree = n: EXIT FUNCTION
			  NEXT
	 CASE GenByteReg:
			  FOR n = AL TO DH
				  IF RegInfo(n).InUse = 0 THEN Reg.IsFree = n: EXIT FUNCTION
			  NEXT
	 CASE GenDWordReg:
			  FOR n = EAX TO EDX
				  IF RegInfo(n).InUse = 0 THEN Reg.IsFree = n: EXIT FUNCTION
			  NEXT
	 CASE ELSE:
			  IF RegInfo(WhichReg).InUse = 0 THEN Reg.IsFree = WhichReg
			  EXIT FUNCTION
   END SELECT

END FUNCTION

' Reg.MakeFree :  Free a specific register (used by an equation token)
'                 for future use while saving its contents. If a group of
'                 of registers is given, only one of them will be freed.
'
' Returns: * integer containing ID of register freed
'
' Input:  * integer ReqReg : register to be made free
'
' Changes: * EqParts()
'          * RegInfo()
'
'
FUNCTION Reg.MakeFree% (ReqReg AS INTEGER)
   DIM m AS INTEGER
   DIM n AS INTEGER

   ' Check if requested register is free and if ReqReg is a group
   ' of registers get free reg returned.
   m = Reg.IsFree(ReqReg)
   
   IF m THEN
	  Reg.MakeFree = m      ' Return register that was found to be free.
	  EXIT FUNCTION

   ELSE    ' No free register found

	  ' Free a specific register if there were no free registers found in
	  ' the group of registers.
	  SELECT CASE ReqReg
	  CASE GenWordReg:
		   Reg.MakeFree = Reg.MakeFree(AX)  ' Free AX and return it.

	  CASE GenByteReg
		   Reg.MakeFree = Reg.MakeFree(AL)

	  CASE GenDWordReg
		   Reg.MakeFree = Reg.MakeFree(EAX)

	  CASE ELSE

		   ' Check if there is a free register to store the register given
		   ' by ReqReg in. If so : put the register ID in the integer m.
		   SELECT CASE ReqReg
			 CASE AL TO DH:   n = GenByteReg
			 CASE AX TO DX:   n = GenWordReg
			 CASE EAX TO EDX: n = GenDWordReg
		   END SELECT
		   m = Reg.IsFree(n)
		   IF m THEN
			  ' If another free register can be found : store it in there
			  OutCode "mov " + RegNames(m) + Comma + RegNames(ReqReg)
			  Reg.SetUsed m, RegInfo(ReqReg).UsedBy
			  Reg.SetFree ReqReg
			  
		   ELSE

			  ' No free all purpose registers left: use temporary variables
			  ' Save specified register in temporary variable to free this register.
			  Eq.SaveAsTempVar RegInfo(ReqReg).UsedBy
			  
		   END IF

		   Reg.MakeFree = ReqReg
		   
	  END SELECT

   END IF


END FUNCTION

SUB Reg.SetFree (RegNum AS INTEGER)

   IF RegInfo(RegNum).UsedBy = 0 THEN
	  PRINT "RegNum="; RegNum
	  PRINT "InUse="; RegInfo(RegNum).InUse
	  ReportErr 10335
   END IF

   SELECT CASE RegNum
	 CASE AL TO DL:
		  RegInfo(RegNum).InUse = False
		  IF RegInfo(RegNum + 4).InUse = False THEN
			 RegInfo(RegNum - 4).InUse = False     'free word and dword too
			 RegInfo(RegNum + 8).InUse = False     'if high byte is also free
		  END IF

	 CASE AH TO DH:
		  RegInfo(RegNum).InUse = False
		  IF RegInfo(RegNum - 4).InUse = False THEN
			 RegInfo(RegNum - 8).InUse = False     'free word and dword too
			 RegInfo(RegNum + 4).InUse = False     'if low byte is also free
		  END IF

	 CASE AX TO DX:
		  RegInfo(RegNum).InUse = False
		  RegInfo(RegNum + 4).InUse = False   'also free high and low byte
		  RegInfo(RegNum + 8).InUse = False   'and dword
		  RegInfo(RegNum + 12).InUse = False
		  
	 CASE EAX TO EDX:
		  RegInfo(RegNum).InUse = False
		  RegInfo(RegNum - 4).InUse = False   'also free high and low byte
		  RegInfo(RegNum - 8).InUse = False   'and word
		  RegInfo(RegNum - 12).InUse = False

	 CASE ELSE
		  ReportErr 1902

   END SELECT
END SUB

' Reg.SetUsed is used to centrally administrate register usage.
' It marks a given cpu reg to signal it's being used by a given equation token.
' Since the byte, word, and dword types of general registers overlap,
' the reservation of a byte reg also reserves the higher regs and vice versa.
' This overlap is also the reason why reg usage is centrally administrated.
' The reg info part that tells which equation token uses the specified
' register (.UsedBy) is set to 0 if the reg is only reserved because of
' occurring overlap.
' Registers that are not to be registered as used and must be preserved are
' SS, BP, DS, SI, ES and DI
'
SUB Reg.SetUsed (RegNum AS INTEGER, EqUser AS INTEGER)

   EqParts(EqUser).class = RegNm
   EqParts(EqUser).id = RegNum

   SELECT CASE RegNum
	 CASE AL TO DL:
		  RegInfo(RegNum).InUse = True: RegInfo(RegNum).UsedBy = EqUser
		  
		  'using a byte reg: set higher magnitudes of that reg also to used
		  RegInfo(RegNum - 4).InUse = True: RegInfo(RegNum - 4).UsedBy = 0
		  RegInfo(RegNum + 8).InUse = True: RegInfo(RegNum + 8).UsedBy = 0

	 CASE AH TO DH:
		  RegInfo(RegNum).InUse = True: RegInfo(RegNum).UsedBy = EqUser
		  
		  'using a byte reg: set higher magnitudes of that reg also to used
		  RegInfo(RegNum - 8).InUse = True: RegInfo(RegNum - 8).UsedBy = 0
		  RegInfo(RegNum + 4).InUse = True: RegInfo(RegNum + 4).UsedBy = 0

	 CASE AX TO DX:
		  RegInfo(RegNum).InUse = True: RegInfo(RegNum).UsedBy = EqUser
		  
		  ' Set byte and dword values also to used
		  RegInfo(RegNum + 4).InUse = True: RegInfo(RegNum + 4).UsedBy = 0
		  RegInfo(RegNum + 8).InUse = True: RegInfo(RegNum + 8).UsedBy = 0
		  RegInfo(RegNum + 12).InUse = True: RegInfo(RegNum + 12).UsedBy = 0

	 CASE EAX TO EDX:
		  RegInfo(RegNum).InUse = True: RegInfo(RegNum).UsedBy = EqUser
		  
		  ' Set byte and word values also to used
		  RegInfo(RegNum - 12).InUse = True: RegInfo(RegNum - 12).UsedBy = 0
		  RegInfo(RegNum - 8).InUse = True: RegInfo(RegNum - 8).UsedBy = 0
		  RegInfo(RegNum - 4).InUse = True: RegInfo(RegNum - 4).UsedBy = 0
		  
	 CASE ELSE
		  IF RegNum >= LBOUND(RegInfo) AND RegNum <= UBOUND(RegInfo) THEN
			 RegInfo(RegNum).InUse = True
			 RegInfo(RegNum).UsedBy = EqUser
		  ELSE
			 ReportErr 3851
		  END IF
   END SELECT

END SUB

SUB ReScanUnknownTok
	DIM n AS INTEGER

	FOR n = 1 TO TotInstrTokens
		IF InstrParts(n).class = UnknownNm THEN
		   IdentifyToken GetTokenName(n), CurScope, InstrParts(n)
		END IF
	NEXT

END SUB

SUB Scan.Instruction
 CONST Separators = "+-*/()=><,. "  ' constant list of operators/separators

 DIM tmpStr AS STRING
 DIM Arg AS STRING
 DIM char AS STRING * 1
 DIM k AS INTEGER        ' \
 DIM l AS INTEGER        '  temporary variables
 DIM m AS INTEGER        ' /
 DIM n AS INTEGER        ' counter: may not be changed otherwise then by loop
 DIM ECnt AS INTEGER
 
 ERASE InstrParts
 
 tmpStr = SrcLine
 TotInstrTokens = 0

 '** divide equation in tokens and save these in array InstrParts
 DO

	'** loop through equation until end or separator character encountered
	FOR n = 1 TO LEN(tmpStr)
		char = MID$(tmpStr, n, 1)
		IF INSTR(Separators, char) THEN EXIT FOR
	NEXT

	'** isolate an token.
	IF n = 1 THEN     'encountered a separator which is also an operator
	   Arg = LEFT$(tmpStr, 1)
	   tmpStr = LTRIM$(MID$(tmpStr, 2))
	ELSE
	   Arg = LEFT$(tmpStr, n - 1)      ' store found token in arg
	   tmpStr = LTRIM$(MID$(tmpStr, n))     ' store part of string yet to analyse
	END IF

	'** Identify found token and put it into token array.
	ECnt = ECnt + 1
	IdentifyToken Arg, CurScope, InstrParts(ECnt)
	InstrParts(ECnt).PosInStr = INSTR(SrcLine, Arg)
	InstrParts(ECnt).TokenStrLen = LEN(Arg)
	'PRINT Arg; " is identified as a token of class"; InstrParts(ECnt).class;'PRINT " and id"; InstrParts(ECnt).id'SLEEP

 LOOP WHILE LEN(tmpStr)  ' keep on stripping names and operators
						 ' from equation until end of it

 TotInstrTokens = ECnt
 
 'DIM TokStart AS INTEGERDIM ILen AS INTEGERDIM ECnt AS INTEGER
 'ERASE InstrParts'NoNextToken = False     'reset flag which is set during parsing when
 '                        'the end of the instruction is encountered.
 'TmpStr = SrcLine'ILen = LEN(SrcLine)'TotInstrtokens = 0'TokStart = 1
 '// divide equation in tokens and save these in array InstrParts
 'DO WHILE n <= ILen
   'n = n + 1'k = INSTR(Separators, MID$(TmpStr, n, 1))
   'IF k THEN     'new token
	  'TokStart = n'Arg = MID$(TmpStr, TokStart, n - TokStart)'ECnt = ECnt + 1 'InstrParts(ECnt).PosInstr = TokStart'InstrParts(ECnt).TokenStrLen = n - TokStart'GOSUB IdNextToken
   'END IF
 'LOOP
 '/ keep on stripping names and operators from equation until end of it
 'TotInstrtokens = ECnt
 'END'EXIT SUB

'SkipSpaces:
'  l = ASC(MID$(TmpStr, n, 1))'  DO WHILE l = 32 OR l = 9'     n = n + 1'  LOOP
'  RETURN

'IdNextToken:
'      PRINT Arg'      SLEEP
'      '// Identify found token and put it into token array.
'      ArgInfo Arg, k, l, m   'identify argument
'      SELECT CASE k   '// Check if we've got a legal argument
'      see above

 ' Wat nu te doen om de formule te ontleden :
 '      kijken waar het eerst illegale karakter voorkomt    of
 '        naar waar het eerste van gedefinieerde scheidingstekens voorkomt ?
 '
 ' 1) scheidingstekens in formules :  " .+-*/()@" + tab
 '    hieronder vallen dus niet alleen controlekarakters maar ook enkele
 '    1 letterige operatoren,prefixes en postfixes !
 '
 '    - functie maken die plaats en type van separator teruggeeft
 '    - speciale separatoren zoals : ".", "@", "(" en "-" (indien als eerste
 '      element na formule) vereisen een speciale nabehandeling !
 '
 '    voordeel ten opzichte van opzoeken illegaal teken: minder problemen
 '    met literals met een prefix zoals &Ha000 en &b10010101 aangezien
 '    "&" een illegaal teken is in een naam.
 '
 '    procedure: - pak token, controleer of deze een geldige parameter
 '                 is ( een bestaande naam , legale literal )
 '
 '

END SUB

SUB ToDO
'
' temporary variables:
'   now implemented as stacklike thing -> cannot determine which bytes in
'   $_temp.. are free, and (de)allocate these centrally and decently.
'
'
'
'
'
'
'
'
END SUB

