{
@abstract(The compiler part of the script engine)
@author(Carlo Kok <ck@carlo-kok.com>)

ifpscomp is the compiler part of the script engine. It implements a
pascal to byte code compiler that can be loaded with executer part of
the script engine.<br>
<br>
Innerfuse Pascal Script III<br>
Copyright (C) 2000-2003 by Carlo Kok <ck@carlo-kok.com><br>
<br>
Standard functions registered by the script engine.<br>
<tt>
function floattostr(e: extended): string;<br>
function inttostr(i: Longint): string;   <br>
function strtoint(s: string): Longint;<br>
function strtointdef(s: string; def: Longint): Longint;<br>
function copy(s: string; ifrom, icount: Longint): string;<br>
function pos(substr, s: string): Longint;<br>
procedure delete(var s: string; ifrom, icount: Longint);<br>
procedure insert(s: string; var s2: string; ipos: Longint);<br>
function getarraylength(var v: array): Integer;<br>
procedure setarraylength(var v: array; i: Integer);<br>

Function StrGet(var S : String; I : Integer) : Char;<br>
procedure StrSet(c : Char; I : Integer; var s : String);<br>
Function Uppercase(s : string) : string;<br>
Function Lowercase(s : string) : string;<br>
Function AnsiUppercase(s : string) : string;<br>
Function AnsiLowercase(s : string) : string;<br>
Function Trim(s : string) : string;<br>
Function Length(s : String) : Longint;<br>
procedure SetLength(var S: String; L: Longint);<br>
Function Sin(e : Extended) : Extended;<br>
Function Cos(e : Extended) : Extended;<br>
Function Sqrt(e : Extended) : Extended;<br>
Function Round(e : Extended) : Longint;<br>
Function Trunc(e : Extended) : Longint;<br>
Function Int(e : Extended) : Extended;<br>
Function Pi : Extended;<br>
Function Abs(e : Extended) : Extended;<br>
function StrToFloat(s: string): Extended;<br>
Function FloatToStr(e : Extended) : String;<br>
Function Padl(s : string;I : longInt) : string;<br>
Function Padr(s : string;I : longInt) : string;<br>
Function Padz(s : string;I : longInt) : string;<br>
Function Replicate(c : char;I : longInt) : string;<br>
Function StringOfChar(c : char;I : longInt) : string;<br>
function StrToInt64(s: string): int64; // only when int64 is available<br>
function Int64ToStr(i: Int64): string; // only when int64 is available<br>
type<br>
  TVarType = (vtNull, vtString, vtU64, vtS32, vtU32, vtS16, vtU16, vtS8, vtU8, vtSingle, vtDouble, vtExtended, vtResourcePointer, vtArray, vtRecord, vtChar, vtWideString, vtWideChar);<br>
<br>
function VarGetType(x: Variant): TVarType;<br>
function Null: Variant;<br>
<br>
type<br>
  TIFException = (ErNoError, erCannotImport, erInvalidType, ErInternalError,<br>
    erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,<br>
    erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,<br>
    ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,<br>
    erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,<br>
    erNullPointerException, erNullVariantError, erCustomError);<br>
<br>
<br>
procedure RaiseLastException;<br>
procedure RaiseException(Ex: TIFException; Param: string);<br>
function ExceptionType: TIFException;<br>
function ExceptionParam: string;<br>
function ExceptionProc: Cardinal;<br>
function ExceptionPos: Cardinal;<br>
function ExceptionToString(er: TIFException; Param: string): string;<br>
</tt>
}
unit ifpscomp;
{$I ifps3_def.inc}
interface
uses
  SysUtils, ifps3utl;


type
  TIFPSPascalCompiler = class;
  {Internal type used to store the current block type}
  TIFPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd);

  {TIFPSExternalClass is used when external classes need to be called}
  TIFPSExternalClass = class;
  TIFPSCompileTimeClass = class;
  {@abstract(Compiler exception)}
  EIFPSCompilerException = class(Exception) end;
  {@abstract(TIFPSRegProc contains all information needed for external function registered to the script engine.)}
  TIFPSRegProc = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
	FDecl: string;
    FExportName: Boolean;
    FImportDecl: string;
    procedure SetName(const Value: string);
  public
	{The actual name of this function}
    property Name: string read FName write SetName;
    {A hash of the name of this function}
    property NameHash: Longint read FNameHash;
	{The header of this function the procedure header format, see @link(TIFPSInternalProcedure)	}
    property Decl: string read FDecl write FDecl;
	{When set to true, the script engine stores the name of this function if ImportDecl is not '' and it's used }
    property ExportName: Boolean read FExportName write FExportName;
	{information that is needed for this function to import it, used for the classes library and dll library.}
    property ImportDecl: string read FImportDecl write FImportDecl;
  end;
  {Pointer to a @link(TIFPSRegProc)}
  PIFPSRegProc = TIFPSRegProc;
  {Pointer to a @link(TIfRVariant) variant}
  PIfRVariant = ^TIfRVariant;
  {A compile time variant. 
  FType is the type number of this variant. Basetype is the basetype of the variant (see @link(TIFPSBaseType)).}
  TIfRVariant = record
    FType: Cardinal;
    BaseType: TIFPSBaseType;
    case Byte of
      1: (tu8: TbtU8);
      2: (tS8: TbtS8);
      3: (tu16: TbtU16);
      4: (ts16: TbtS16);
      5: (tu32: TbtU32);
      6: (ts32: TbtS32);
      7: (tsingle: TbtSingle);
      8: (tdouble: TbtDouble);
      9: (textended: TbtExtended);
      10: (tstring: Pointer);
      {$IFNDEF IFPS3_NOINT64}
      17: (ts64: Tbts64);
      {$ENDIF}
      19: (tchar: tbtChar);
      {$IFNDEF IFPS3_NOWIDESTRING}
      18: (twidestring: Pointer);
      20: (twidechar: tbtwidechar);
      {$ENDIF}
  end;
  {@abstract(TIFPSRecordFieldTypeDef is used to store record field information, see @link(TIFPSRecordType))}
  TIFPSRecordFieldTypeDef = class(TObject)
  private
    FFieldNameHash: Longint;
    FFieldName: string;
    FType: Cardinal;
    procedure SetFieldName(const Value: string);
  public
    {A hash of the name of this field}
    property FieldNameHash: Longint read FFieldNameHash;
    {The name of this field}
    property FieldName: string read FFieldName write SetFieldName;
    {The type of this field}
    property aType: Cardinal read FType write FType;
  end;
  {PIFPSRecordFieldTypeDef is an alias to @Link(TIFPSRecordFieldTypeDef)}
  PIFPSRecordFieldTypeDef = TIFPSRecordFieldTypeDef;
  {@abstract(TIFPSType is the base class for all types)}
  TIFPSType = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
    FBaseType: TIFPSBaseType;
    FDeclarePos: Cardinal;
    FUsed: Boolean;
    FExportName: Boolean;
    FDeclareRow: Cardinal;
    FDeclareCol: Cardinal;
    FOriginalName: string;
    procedure SetName(const Value: string);
  public
    {The name of this type}
    property OriginalName: string read FOriginalName write FOriginalName;
    {The name of this type, in uppercase}
    property Name: string read FName write SetName;
    {a hash of the name for this type}
    property NameHash: Longint read FNameHash;
    {The base type for this type}
    property BaseType: TIFPSBaseType read FBaseType write FBaseType;
    {The position this type was declared, or 0, when declared outside the script engine}
    property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
    {The row part of the position for this type}
    property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
    {The col part of the position for this type}
    property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
    {This field is true when the type is used by the script engine, only used
    types will be written to bytecode}
    property Used: Boolean read FUsed;
    {Is this is true, the script engine will write the name of this type in the bytecode}
    property ExportName: Boolean read FExportName write FExportName;
    {Set the used field to true}
    procedure Use;
  end;

  {PIFPSType is a alias to a @link(TIFPSType)}
  PIFPSType = TIFPSType;

  {@abstract(TIFPSRecordType is used to store information about record types)}
  TIFPSRecordType = class(TIFPSType)
  private
    FRecordSubVals: TIfList;
  public
    constructor Create;
    destructor Destroy; override;
    {The number of field in this record}
    function RecValCount: Longint;
    {Returns the field of this record}
    function RecVal(I: Longint): PIFPSRecordFieldTypeDef;
    {Add a field}
    function AddRecVal: PIFPSRecordFieldTypeDef;
  end;
  {@abstract(TIFPSClassType is used to store class type information for the script engine)}
  TIFPSClassType = class(TIFPSType)
  private
    FClassHelper: TIFPSExternalClass;
  public
    {The helper class, see @link(TIFPSExternalClass) for more info}
    property ClassHelper: TIFPSExternalClass read FClassHelper write FClassHelper;
    destructor Destroy; override;
  end;
  {@abstract(A procedural pointer type)}
  TIFPSProceduralType = class(TIFPSType)
  private
    FProcDef: string;
  public
    {The definition all procs of this type should use}
    property ProcDef: string read FProcDef write FProcDef;
  end;
  {@abstract(Array type information)}
  TIFPSArrayType = class(TIFPSType)
  private
    FArrayTypeNo: Cardinal;
  public
    {The type of this array}
    property ArrayTypeNo: Cardinal read FArrayTypeNo write FArrayTypeNo;
  end;
  {@abstract(TIFPSStaticArrayType holds information to store static arrays)} 
  TIFPSStaticArrayType = class(TIFPSArrayType)
  private
    FStartOffset: Longint;
    FLength: Cardinal;
  public
    {The start range of this array}
    property StartOffset: Longint read FStartOffset write FStartOffset;
    {The number of fields for this array}
    property Length: Cardinal read FLength write FLength;
  end;
  {@abstract(TIFPSSetType stores set type info)}
  TIFPSSetType = class(TIFPSType)
  private
    FSetType: TIFPSType;
    function GetByteSize: Longint;
    function GetBitSize: Longint;
  public
    {The type this set is about}
    property SetType: TIFPSType read FSetType write FSetType;
    {The number of bytes to store this set}
    property ByteSize: Longint read GetByteSize;
    {The number of bits to store this set}
    property BitSize: Longint read GetBitSize;
  end;
  {@abstract(a type link is an alias for another type)}
  TIFPSTypeLink = class(TIFPSType)
  private
    FLinkTypeNo: Cardinal;
  public
    property LinkTypeNo: Cardinal read FLinkTypeNo write FLinkTypeNo;
  end;
  {@abstract(an TIFPSEnumType holds information for enumerated types)}
  TIFPSEnumType = class(TIFPSType)
  private
    FHighValue: Cardinal;
  public
    {The highest possible value for this enum}
    property HighValue: Cardinal read FHighValue write FHighValue;
  end;
  {A special resource type}
  TIFPSResourcePtrType = class(TIFPSType)
  private
    FResourceType: string;
  public
    property ResourceType: string read FResourceType write FResourceType;
  end;

  {@abstract(TIFPSProcVar is used to store local variables)}
  TIFPSProcVar = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
    FType: Cardinal; // only for calculation types
    FUsed: Boolean;
    FDeclarePos, FDeclareRow, FDeclareCol: Cardinal;
    procedure SetName(const Value: string);
  public
    {The hash of the name of this local variable}
    property NameHash: Longint read FNameHash;
    {The name of this variable}
    property Name: string read FName write SetName;
    {The type}
    property AType: Cardinal read FType write FType;
    {used is true when it's used}
    property Used: Boolean read FUsed;
    {The position this is declared}
    property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
    {The row part of the position}
    property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
    {The col part of the position}
    property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
    {set the used field to true}
    procedure Use;
  end;
  {PIFPSProcVar is an alias for  @link(TIFPSProcVar)}
  PIFPSProcVar = TIFPSProcVar;
  {@abstract(TIFPSProcedure is the base type for all procedures)}
  TIFPSProcedure = class(TObject)
  end;
   {@abstract(An external procedure)}
  TIFPSExternalProcedure = class(TIFPSProcedure)
  private
    FRegProc: TIFPSRegProc;
  public
    {the regproc for this external procedure. see @link(TIFPSRegProc)}
    property RegProc: TIFPSRegProc read FRegProc write FRegProc;
  end;
  {The export type for this internal procedure. etExportName will only export it's name, and etExportDecl will also export it's declaration, this is required for event functions to work}
  TIFPSExportType = (etExportNone, etExportName, etExportDecl);
  {@abstract(TIFPSInternalProcedure stores information for scripted procedures)}
  TIFPSInternalProcedure = class(TIFPSProcedure)
  private
    FForwarded: Boolean;
    FData: string;
    FNameHash: Longint;
    FDecl, FName: string;
    {Decl: [RESULTTYPE] [PARAM1NAME] [PARAM1TYPE] [PARAM2NAME] ... }
    { @ = Normal Parameter  ! = Var parameter}
    FProcVars: TIfList;
    FUsed: Boolean;
    FOutputDeclPosition: Cardinal;
    FResultUsed: Boolean;
    FExport: TIFPSExportType;
    FLabels: TIfStringList; // IFPS3_mi2s(position)+IFPS3_mi2s(namehash)+name   [position=$FFFFFFFF means position unknown]
    FGotos: TIfStringList;
    FDeclareRow: Cardinal;
    FDeclarePos: Cardinal;
    FDeclareCol: Cardinal;
    FOriginalName: string;
    procedure SetName(const Value: string);  // IFPS3_mi2s(position)+IFPS3_mi2s(destinationnamehash)+destinationname
  public
    constructor Create;
    destructor Destroy; override;
    {This field is true when the last declaration of this procedure was forwarded}
    property Forwarded: Boolean read FForwarded write FForwarded;
    {The compiled code for this procedure}
    property Data: string read FData write FData;
    {The declaration for this procedure:
    [RESULTTYPE] [PARAM1MODIFIER][PARAM1NAME] [PARAM1TYPE] [PARAM2MODIFIER] [PARAM2NAME] ...
    Modifiers: @ = Normal Parameter  ! = Var parameter}
    property Decl: string read FDecl write FDecl;
    {The original name}
    property OriginalName: string read FOriginalName write FOriginalName;
    {The name for this procedure (in uppercase)}
    property Name: string read FName write SetName;
    {The hash for the name of this procedure}
    property NameHash: Longint read FNameHash;
    {A list with all local variables}
    property ProcVars: TIFList read FProcVars;
    {True when this procedure is called from somewhere}
    property Used: Boolean read FUsed;
    {The position this procedure is declared}
    property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
    {The row part of the position}
    property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
    {The col part of the position}
    property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
    {This field is used when writing the byte code. Do not set or change this}
    property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
    {This field is true when the result of this function is assigned somewhere}
    property ResultUsed: Boolean read FResultUsed;

    {The export mode}
    property aExport: TIFPSExportType read FExport write FExport;
    {All labels within this procedure}
    property Labels: TIfStringList read FLabels;
    {All goto's within this procedure}
    property Gotos: TIfStringList read FGotos;
    {Use this procedure}
    procedure Use;
    {Use the result variable}
    procedure ResultUse;
  end;
  {@abstract(TIFPSVar is used to store global variables)}
  TIFPSVar = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
    FType: Cardinal;
    FUsed: Boolean;
    FExportName: string;
    FDeclareRow: Cardinal;
    FDeclarePos: Cardinal;
    FDeclareCol: Cardinal;
    procedure SetName(const Value: string);
  public
    {The name this field should be exported under}
    property ExportName: string read FExportName write FExportName;
    {This field is true when the variable is used}
    property Used: Boolean read FUsed;
    {The type of this variable}
    property aType: Cardinal read FType write FType;
    {The name of this variable}
    property Name: string read FName write SetName;
    {The hash of the name of this variable}
    property NameHash: Longint read FNameHash;
    {The position this variable was declared}
    property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
    {The row part of the position}
    property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
    {The col part of the position}
    property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
    {Set used to true}
    procedure Use;
  end;
  {TIFPSVar is an alias for a TIFPSVar}
  PIFPSVar = TIFPSVar;
  {@abstract(TIFPSContant contains information about constants)}
  TIFPSConstant = class(TObject)
    FNameHash: Longint;
    FName: string;
    FValue: PIfRVariant;
  private
    procedure SetName(const Value: string);
  public
    {The name (of the constant}
    property Name: string read FName write SetName;
    {The hash of the name of this constant}
    property NameHash: Longint read FNameHash;
    {The value for this constant}
    property Value: PIfRVariant read FValue write FValue;
    {Change the value of this constant to the val integer}
    procedure SetInt(const Val: Longint);
    {Change the value of this constant to the val Cardinal}
    procedure SetUInt(const Val: Cardinal);
    {$IFNDEF IFPS3_NOINT64}
    {Change the value of this constant to the val int64}
    procedure SetInt64(const Val: Int64);
    {$ENDIF}
    {Change the value of this constant to the val string}
    procedure SetString(const Val: string);
    {Change the value of this constant to the val char}
    procedure SetChar(c: Char);
    {$IFNDEF IFPS3_NOINT64}
    {Change the value of this constant to the val WideChar}
    procedure SetWideChar(const val: WideChar);
    {Change the value of this constant to the val WideString}
    procedure SetWideString(const val: WideString);
    {$ENDIF}
    {Change the value of this constant to the val extended}
    procedure SetExtended(const Val: Extended);

    destructor Destroy; override;
  end;
  {PIFPSContant is an alias to a TIFPSConstant}
  PIFPSConstant = TIFPSConstant;
  {Is used to store the type of a compiler error}
  TIFPSPascalCompilerErrorType = (
    ecUnknownIdentifier,
    ecIdentifierExpected,
    ecCommentError,
    ecStringError,
    ecCharError,
    ecSyntaxError,
    ecUnexpectedEndOfFile,
    ecSemicolonExpected,
    ecBeginExpected,
    ecPeriodExpected,
    ecDuplicateIdentifier,
    ecColonExpected,
    ecUnknownType,
    ecCloseRoundExpected,
    ecTypeMismatch,
    ecInternalError,
    ecAssignmentExpected,
    ecThenExpected,
    ecDoExpected,
    ecNoResult,
    ecOpenRoundExpected,
    ecCommaExpected,
    ecToExpected,
    ecIsExpected,
    ecOfExpected,
    ecCloseBlockExpected,
    ecVariableExpected,
    ecStringExpected,
    ecEndExpected,
    ecUnSetLabel,
    ecNotInLoop,
    ecInvalidJump,
    ecOpenBlockExpected,
    ecWriteOnlyProperty,
    ecReadOnlyProperty,
    ecClassTypeExpected,
    ecCustomError,
    ecDivideByZero,
    ecMathError,
    ecUnsatisfiedForward,
    ecForwardParameterMismatch

    );
  {Used to store the type of a hint}
  TIFPSPascalCompilerHintType = (
    ehVariableNotUsed, {param = variable name}
    ehFunctionNotUsed, {param = function name}
    ehCustomHint
    );
  {Is used to store the type of a warning}
  TIFPSPascalCompilerWarningType = (
    ewCalculationAlwaysEvaluatesTo,
    ewIsNotNeeded,
    ewCustomWarning
  );
  {@abstract(TIFPSPascalCompilerMessage is the base class for compiler messages)}
  TIFPSPascalCompilerMessage = class(TObject)
  protected
    FRow: Cardinal;
    FCol: Cardinal;
    FModuleName: string;
    FParam: string;
    FPosition: Cardinal;
    function ErrorType: string; virtual; abstract;
    procedure SetParserPos(Parser: TIfPascalParser);
  public
    property ModuleName: string read FModuleName;
    property Param: string read FParam;
    property Pos: Cardinal read FPosition;
    property Row: Cardinal read FRow;
    property Col: Cardinal read FCol;
    procedure SetCustomPos(Pos, Row, Col: Cardinal);

    function MessageToString: string; virtual;

    function ShortMessageToString: string; virtual; abstract;
  end;
  {@abstract(error message class)}
  TIFPSPascalCompilerError = class(TIFPSPascalCompilerMessage)
  protected
    FError: TIFPSPascalCompilerErrorType;
    function ErrorType: string; override;
  public
    property Error: TIFPSPascalCompilerErrorType read FError;

    function ShortMessageToString: string; override;
  end;
  {@abstract(Hint message class)}
  TIFPSPascalCompilerHint = class(TIFPSPascalCompilerMessage)
  protected
    FHint: TIFPSPascalCompilerHintType;
    function ErrorType: string; override;
  public
    property Hint: TIFPSPascalCompilerHintType read FHint;

    function ShortMessageToString: string; override;
  end;
  {@abstract(Warning message class)}
  TIFPSPascalCompilerWarning = class(TIFPSPascalCompilerMessage)
  protected
    FWarning: TIFPSPascalCompilerWarningType;
    function ErrorType: string; override;
  public
    property Warning: TIFPSPascalCompilerWarningType read FWarning;

    function ShortMessageToString: string; override;
  end;
  TIFPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts);
  {@abstract(BlockInfo is used to store the current scope the script engine is current in. There is no need to use or create this object)}
  TIFPSBlockInfo = class(TObject)
  private
    FOwner: TIFPSBlockInfo;
    FWithList: TIfList;
    FProcNo: Cardinal;
    FProc: TIFPSInternalProcedure;
    FSubType: TIFPSSubOptType;
  public
    {The current with list of @link(TIFPSValue) types}
    property WithList: TIfList read FWithList;
    {The current proc number}
    property ProcNo: Cardinal read FProcNo write FProcNo;
    {The current proc}
    property Proc: TIFPSInternalProcedure read FProc write FProc;
    {The scope type}
    property SubType: TIFPSSubOptType read FSubType write FSubType;
    {Clear the with list}
    procedure Clear;
    constructor Create(Owner: TIFPSBlockInfo);
    destructor Destroy; override;
  end;


  {The kind of binairy operand}
  TIFPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor,
                          otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
                          otNotEqual, otIs, otAs, otIn);
  {The kind of unair operand}
  TIFPSUnOperatorType = (otNot, otMinus, otCast);
  {See TIFPSPascalCompiler.OnUseVariable}
  TIFPSOnUseVariable = procedure (Sender: TIFPSPascalCompiler; VarType: TIFPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: string);
  {See TIFPSPascalCompiler.OnUses}
  TIFPSOnUses = function(Sender: TIFPSPascalCompiler; const Name: string): Boolean;
  {See TIFPSPascalCompiler.OnExportCheck}
  TIFPSOnExportCheck = function(Sender: TIFPSPascalCompiler; Proc: TIFPSInternalProcedure; const ProcDecl: string): Boolean;
  {See TIFPSPascalCompiler.OnWriteLine}
  TIFPSOnWriteLineEvent = function (Sender: TIFPSPascalCompiler; Position: Cardinal): Boolean;
  {See TIFPSPascalCompiler.OnExternalProc}
  TIFPSOnExternalProc = function (Sender: TIFPSPascalCompiler; const Name, Decl, FExternal: string): TIFPSRegProc;
  {@abstract(The actual compiler)}
  TIFPSPascalCompiler = class
  protected
    FID: Pointer;
    FOnExportCheck: TIFPSOnExportCheck;
    FBooleanType: Cardinal;
    FRegProcs: TIfList;
    FConstants: TIFList;
    FProcs: TIfList;
    FAvailableTypes: TIfList;
    FUsedTypes: TIfList;
    FVars: TIfList;
    FOutput: string;
    FParser: TIfPascalParser;
    FMessages: TIfList;
    FOnUses: TIFPSOnUses;
    FIsUnit: Boolean;
    FAllowNoBegin: Boolean;
    FAllowNoEnd: Boolean;
    FAllowUnit: Boolean;
    FDebugOutput: string;
    FOnExternalProc: TIFPSOnExternalProc;
    FOnUseVariable: TIFPSOnUseVariable;
    FOnWriteLine: TIFPSOnWriteLineEvent;
    FContinueOffsets, FBreakOffsets: TIfList;
    FAutoFreeList: TIfList;
    FClasses: TIFList;
    FGlobalBlock: TIFPSBlockInfo;
    {$IFNDEF IFPS3_NOWIDESTRING}
    function GetWideString(Src: PIfRVariant; var s: Boolean): WideString;
    {$ENDIF}
    function GetType(FUseUsedTypes: Boolean; BaseType: TIFPSBaseType): Cardinal;
    function GetMsgCount: Longint;
    function MakeDecl(decl: string): string;
    function MakeExportDecl(decl: string): string;
    function GetMsg(l: Longint): TIFPSPascalCompilerMessage;
    procedure DefineStandardTypes;
    procedure DefineStandardProcedures;
    procedure UpdateRecordFields(r: TIFPSType);
    function GetTypeCopyLink(p: TIFPSType): TIFPSType;
    function GetTypeCopyLinkInt(L: Cardinal): Cardinal;
    function IsIntBoolType(FTypeNo: Cardinal): Boolean;
    function GetTypeFromList(FUseUsedTypes: Boolean; Num: Cardinal): TIFPSType;
    function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
      Var2: PIfRVariant; Cmd: TIFPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
    function ReadConstant(FParser: TIfPascalParser; StopOn: TIfPasToken): PIfRVariant;
    procedure WriteDebugData(const s: string);
    function ProcessFunction(AlwaysForward: Boolean): Boolean;
    function IsDuplicate(const s: string; const check: TIFPSDuplicCheck): Boolean;
    function DoVarBlock(proc: TIFPSInternalProcedure): Boolean;
    function DoTypeBlock(FParser: TIfPascalParser): Boolean;
    function ReadType(const Name: string; FParser: TIfPascalParser): Cardinal;
    function NewProc(const OriginalName, Name: string): TIFPSInternalProcedure;
    function ProcessLabel(Proc: TIFPSInternalProcedure): Boolean;
    procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
    procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
    function ProcessSub(BlockInfo: TIFPSBlockInfo): Boolean;
    function ProcessLabelForwards(Proc: TIFPSInternalProcedure): Boolean;

    procedure ReplaceTypes(var s: string);
    function AT2UT(L: Cardinal): Cardinal;
    function GetUsedType(No: Cardinal): TIFPSType;
    function GetAvailableType(No: Cardinal): TIFPSType;
    function GetUsedTypeCount: Cardinal;
    function GetAvailableTypeCount: Cardinal;
    function UseAvailableType(No: Cardinal): Cardinal;
    function AddUsedFunction(var Proc: TIFPSInternalProcedure): Cardinal;
    function AddUsedFunction2(var Proc: TIFPSExternalProcedure): Cardinal;
    function CheckCompatProc(P: TIFPSType; ProcNo: Cardinal): Boolean;
    procedure ParserError(Parser: TObject; Kind: TIFParserErrorKind);
    function FindProc(const Name: string): Cardinal;
    function ReadTypeAddProcedure(const Name: string; FParser: TIfPascalParser): Cardinal;
    function ATNUT(C: Cardinal): Cardinal;
    function VarIsDuplicate(Proc: TIFPSInternalProcedure; const VarNames, s: string): Boolean;
    function IsProcDuplicLabel(Proc: TIFPSInternalProcedure; const s: string): Boolean;
    procedure CheckForUnusedVars(Func: TIFPSInternalProcedure);
    function ProcIsDuplic(const FunctionName, FunctionDecl, FunctionParamNames: string; const s: string; Func: TIFPSInternalProcedure): Boolean;
    procedure Debug_WriteLine(BlockInfo: TIFPSBlockInfo);
   public
    {Add an object to the auto-free list}
    procedure AddToFreeList(Obj: TObject);
    {Tag for this object, use as you like}
    property ID: Pointer read FID write FID;
    {Add an error the messages}
    function MakeError(const Module: string; E: TIFPSPascalCompilerErrorType; const
      Param: string): TIFPSPascalCompilerMessage;
    {Add a warning to the messages}
    function MakeWarning(const Module: string; E: TIFPSPascalCompilerWarningType;
      const Param: string): TIFPSPascalCompilerMessage;
    {Add a hint to the messages}
    function MakeHint(const Module: string; E: TIFPSPascalCompilerHintType;
      const Param: string): TIFPSPascalCompilerMessage;
    {Add a class}
    function AddClass(InheritsFrom: TIFPSCompileTimeClass; aClass: TClass): TIFPSCompileTimeClass;
    {Add a class without using the actual class}
    function AddClassN(InheritsFrom: TIFPSCompileTimeClass; const aClass: string): TIFPSCompileTimeClass;
    {Find a class}
    function FindClass(const aClass: string): TIFPSCompileTimeClass;
    {Add a function}
    function AddFunction(const Header: string): TIFPSRegProc;
    {Add a function and make it possible to directly call this function}
    function AddDelphiFunction(const Decl: string): TIFPSRegProc;
    {add a type}
    function AddType(const Name: string; const BaseType: TIFPSBaseType): TIFPSType;
    {Add a type declared in a string}
    function AddTypeS(const Name, Decl: string): TIFPSType;
    {Add a type copy type}
    function AddTypeCopy(const Name: string; TypeNo: Cardinal): TIFPSType;
    {Add a type copy type}
    function AddTypeCopyN(const Name, FType: string): TIFPSType;
    {Add a constant}
    function AddConstant(const Name: string; FType: Cardinal): TIFPSConstant;
    {Add a constant}
    function AddConstantN(const Name, FType: string): TIFPSConstant;
    {Add a variable, and export it}
    function AddVariable(const Name: string; FType: Cardinal): TIFPSVar;
    {Add a variable, and export it}
    function AddVariableN(const Name, FType: string): TIFPSVar;
    {Add an used variable, and export it}
    function AddUsedVariable(const Name: string; FType: Cardinal): TIFPSVar;
    {add an used variable , and export it}
    function AddUsedVariableN(const Name, FType: string): TIFPSVar;
    {Search for a type}
    function FindType(const Name: string): Cardinal;
    {Compile a script (s)}
    function Compile(const s: string): Boolean;
    {Return the output}
    function GetOutput(var s: string): Boolean;
	{Return the debugger output}
    function GetDebugOutput(var s: string): Boolean;
    {Clear the current data}
    procedure Clear;
    {Create}
    constructor Create;
	{Destroy the current instance of the script compiler}
    destructor Destroy; override;
    {contains the number of messages}
    property MsgCount: Longint read GetMsgCount;
	{The messages/warnings/errors}
    property Msg[l: Longint]: TIFPSPascalCompilerMessage read GetMsg;
    {OnUses i scalled for each Uses and always first with 'SYSTEM' parameters}
    property OnUses: TIFPSOnUses read FOnUses write FOnUses;
	{OnExportCheck is called for each function to check if it needs to be exported and has the correct parameters}
    property OnExportCheck: TIFPSOnExportCheck read FOnExportCheck write FOnExportCheck;
	{OnWriteLine is called after each line}
    property OnWriteLine: TIFPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
	{OnExternalProc is called when an external token is found after a procedure header}
    property OnExternalProc: TIFPSOnExternalProc read FOnExternalProc write FOnExternalProc;
	{The OnUseVariant event is called when a variable is used by the script engine}
    property OnUseVariable: TIFPSOnUseVariable read FOnUseVariable write FOnUseVariable;
	{contains true if the current file is a unit}
    property IsUnit: Boolean read FIsUnit;
	{Allow no main begin/end}
    property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
	{Allow a unit instead of program}
    property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
	{Allow it to have no END on the script (only works when AllowNoBegin is true)}
    property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
  end;
  {@abstract(Base class for all values)}
  TIFPSValue = class(TObject)
  private
    FPos, FRow, FCol: Cardinal;
  public
    {position this value was declared}
    property Pos: Cardinal read FPos write FPos;
    {Row part of the position}
    property Row: Cardinal read FRow write FRow;
    {Col part of the position}
    property Col: Cardinal read FCol write FCol;
    {Read position info from the parser}
    procedure SetParserPos(P: TIfPascalParser);
  end;
  {The mode this parameter was passed}
  TIFPSParameterMode = (pmIn, pmOut, pmInOut);
  {@abstract(TIFPSParameter is used to store parameter info)}
  TIFPSParameter = class(TObject)
  private
    FValue: TIFPSValue;
    FTempVar: TIFPSValue;
    FParamMode: TIFPSParameterMode;
    FExpectedType: Cardinal;
  public
    {The actual value of this parameter}
    property Val: TIFPSValue read FValue write FValue;
    {The expected type}
    property ExpectedType: Cardinal read FExpectedType write FExpectedType;
    {The temporary field used when writing the byte code}
    property TempVar: TIFPSValue read FTempVar write FTempVar;
    {Parameter mode}
    property ParamMode: TIFPSParameterMode read FParamMode write FParamMode;
    destructor Destroy; override;
  end;
  {@abstract(TIFPSParameters is a list of @link(TIFPSParameter))}
  TIFPSParameters = class(TObject)
  private
    FItems: TIfList;
    function GetCount: Cardinal;
    function GetItem(I: Longint): TIFPSParameter;
  public
    constructor Create;
    destructor Destroy; override;
    {Number of elements}
    property Count: Cardinal read GetCount;
    {Item no [i]}
    property Item[I: Longint]: TIFPSParameter read GetItem; default;
    {Delete item number I}
    procedure Delete(I: Cardinal);
    {Add a new parameter}
    function Add: TIFPSParameter;
  end;
  {@abstract(TIFPSSubItem is a base case used when storing record or array field number information)}
  TIFPSSubItem = class(TObject)
  private
    FType: Cardinal;
  public
    {The type this variable will be after this subfield}
    property aType: Cardinal read FType write FType;
  end;
  {@abstract(Field no constant number)}
  TIFPSSubNumber = class(TIFPSSubItem)
  private
    FSubNo: Cardinal;
  public
    {The field number}
    property SubNo: Cardinal read FSubNo write FSubNo;
  end;
  {@abstract(Field no by value)}
  TIFPSSubValue = class(TIFPSSubItem)
  private
    FSubNo: TIFPSValue;
  public
    {The field number}
    property SubNo: TIFPSValue read FSubNo write FSubNo;
    destructor Destroy; override;
  end;
  {@abstract(The base class for all variables)}
  TIFPSValueVar = class(TIFPSValue)
  private
    FRecItems: TIfList;
    function GetRecCount: Cardinal;
    function GetRecItem(I: Cardinal): TIFPSSubItem;
  public
    constructor Create;
    destructor Destroy; override;
    {Record/Array sub fields: Add a new one}
    function RecAdd(Val: TIFPSSubItem): Cardinal;
    {Record/Array sub fields: Delete }
    procedure RecDelete(I: Cardinal);
    {Record/Array sub fields: Returns the item at I}
    property RecItem[I: Cardinal]: TIFPSSubItem read GetRecItem;
    {Record/Array sub fields: Returns the count}
    property RecCount: Cardinal read GetRecCount;
  end;
  {@abstract(A global variable)}
  TIFPSValueGlobalVar = class(TIFPSValueVar)
  private
    FAddress: Cardinal;
  public
    {The global variable no}
    property GlobalVarNo: Cardinal read FAddress write FAddress;
  end;

  {@abstract(A local variable)}
  TIFPSValueLocalVar = class(TIFPSValueVar)
  private
    FLocalVarNo: Longint;
  public
    {The local variable no}
    property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo;
  end;
  {@abstract(A parameter variable)}
  TIFPSValueParamVar = class(TIFPSValueVar)
  private
    FParamNo: Longint;
  public
    {The parameter within the current procedure}
    property ParamNo: Longint read FParamNo write FParamNo;
  end;
  {@abstract(A temporary value used by the script engine)}
  TIFPSValueAllocatedStackVar = class(TIFPSValueLocalVar)
  private
    FProc: TIFPSInternalProcedure;
  public
    {The current procedure, used for freeing}
    property Proc: TIFPSInternalProcedure read FProc write FProc;
    destructor Destroy; override;
  end;
  {@abstract(A Data value)}
  TIFPSValueData = class(TIFPSValue)
  private
    FData: PIfRVariant;
  public
    {The actual data}
    property Data: PIfRVariant read FData write FData;
    destructor Destroy; override;
  end;
  {@abstract(TIFPSValueReplace is used internally by the script engine when
  it needs to replace a value with something else, usually when writing
  the byte code)}
  TIFPSValueReplace = class(TIFPSValue)
  private
    FPreWriteAllocated: Boolean;
    FFreeOldValue: Boolean;
    FFreeNewValue: Boolean;
    FOldValue: TIFPSValue;
    FNewValue: TIFPSValue;
    FReplaceTimes: Longint;
  public
    {The old value}
    property OldValue: TIFPSValue read FOldValue write FOldValue;
    {The new value}
    property NewValue: TIFPSValue read FNewValue write FNewValue;
    {Should it free the old value when destroyed?}
    property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue; {default false}
    {Should it free the new value when destroyed?}
    property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue; {default true}
    {This is true when this value is allocated in the PreWriteOutput function}
    property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated;
    {The number of times this variable should have been replaced}
    property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes;

    constructor Create;
    destructor Destroy; override;
  end;

  {@abstract(TIFPSUnValueOp stores information about unairy calculations)}
  TIFPSUnValueOp = class(TIFPSValue)
  private
    FVal1: TIFPSValue;
    FOperator: TIFPSUnOperatorType;
    FType: Cardinal;
  public
    {The value on which the operation should be executed}
    property Val1: TIFPSValue read FVal1 write FVal1;
    {The operator}
    property Operator: TIFPSUnOperatorType read FOperator write FOperator;
    {The final type}
    property aType: Cardinal read FType write FType;
    destructor Destroy; override;
  end;
  {@abstract(TIFPSBinValueOp stores information about binairy calculations)}
  TIFPSBinValueOp = class(TIFPSValue)
  private
    FVal1,
    FVal2: TIFPSValue;
    FOperator: TIFPSBinOperatorType;
    FType: Cardinal;
  public
    {The first value}
    property Val1: TIFPSValue read FVal1 write FVal1;
    {The second value}
    property Val2: TIFPSValue read FVal2 write FVal2;
    {The operator for this value}
    property Operator: TIFPSBinOperatorType read FOperator write FOperator;
    {The resulting type}
    property aType: Cardinal read FType write FType;
    destructor Destroy; override;
  end;
  {@abstract(TIFPSValueNil is used to hold NIL values, that have no actual value until it's assigned
  to another type)}
  TIFPSValueNil = class(TIFPSValue)
  end;
  {@abstract(A procedural pointer)}
  TIFPSValueProcPtr = class(TIFPSValue)
  private
    FProcNo: Cardinal;
  public
    {The proc number it points to}
    property ProcPtr: Cardinal read FProcNo write FProcNo;
  end;
  {@abstract(The base class for all procedure calls)}
  TIFPSValueProc = class(TIFPSValue)
  private
    FSelfPtr: TIFPSValue;
    FParameters: TIFPSParameters;
    FResultType: Cardinal;
  public
    property ResultType: Cardinal read FResultType write FResultType;
    {The self pointer value or nil}
    property SelfPtr: TIFPSValue read FSelfPtr write FSelfPtr;
    {The parameters}
    property Parameters: TIFPSParameters read FParameters write FParameters;
    destructor Destroy; override;
  end;
  {@abstract(A procedure by number call)}
  TIFPSValueProcNo = class(TIFPSValueProc)
  private
    FProcNo: Cardinal;
  public
   { The procedure number}
    property ProcNo: Cardinal read FProcNo write FProcNo;
  end;
  {@abstract(A procedure by value call)}
  TIFPSValueProcVal = class(TIFPSValueProc)
  private
    FProcNo: TIFPSValue;
  public
    {The procedure number}
    property ProcNo: TIFPSValue read FProcNo write FProcNo;
  end;
  {@abstract(An array constant) (A := [1,23,4])} 
  TIFPSValueArray = class(TIFPSValue)
  private
    FItems: TIfList;
    function GetCount: Cardinal;
    function GetItem(I: Cardinal): TIFPSValue;
  public
    function Add(Item: TIFPSValue): Cardinal;
    procedure Delete(I: Cardinal);
    property Item[I: Cardinal]: TIFPSValue read GetItem;
    property Count: Cardinal read GetCount;

    constructor Create;
    destructor Destroy; override;
  end;

  {@abstract(TIFPSExternalClass is used when external classes need to be called, External classes are virtual objects that could be anything when compiled, from integers to actual delphi classes)}
  TIFPSExternalClass = class(TObject)
  protected
    SE: TIFPSPascalCompiler;
    FTypeNo: Cardinal;
  public
    {The type used as a class}
    function SelfType: Cardinal; virtual;
	{Create}
    constructor Create(Se: TIFPSPascalCompiler; TypeNo: Cardinal);
    {Find a class function}
    function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
	{Call a class function}
    function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Find a function}
    function Func_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
	{Call a function}
    function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Find a property; Name = '' means the Default property}
    function Property_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
	{Return the header of an variant}
    function Property_GetHeader(Index: Cardinal; var s: string): Boolean; virtual;
	{Get a variant value}
    function Property_Get(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
	{Set a variant value}
    function Property_Set(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Check if the class is compatible}
    function IsCompatibleWith(Cl: TIFPSExternalClass): Boolean; virtual;
    {Returns the ProcNo for setting a class variable to nil}
    function SetNil(var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for casting}
    function CastToType(IntoType: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for comparing two classes}
    function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for AS casting}
    function CastToTypeAS(IntoType: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for is casting}
    function CastToTypeIS(IntoType: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  end;

  {Property type: iptRW = Read/Write; iptR= readonly; iptW= writeonly}
  TIFPSPropType = (iptRW, iptR, iptW);
  {@abstract(Compiletime class)}
  TIFPSCompileTimeClass = class
  private
    FInheritsFrom: TIFPSCompileTimeClass;
    FClass: TClass;
    FClassName: string;
    FClassNameHash: Longint;
    FClassItems: TIFList;
    FDefaultProperty: Cardinal;

    FOwner: TIFPSPascalCompiler;
  public
    property ClassInheritsFrom: TIFPSCompileTimeClass read FInheritsFrom write FInheritsFrom;
    {Register a method/constructor}
    function RegisterMethod(const Decl: string): Boolean;
	{Register a property}
    procedure RegisterProperty(const PropertyName, PropertyType: string; PropAC: TIFPSPropType);
    {Register all published properties}
    procedure RegisterPublishedProperties;
    {Register a published property}
    function RegisterPublishedProperty(const Name: string): Boolean;
    {Set the default (array) property, this function will raise an exception if
    the property doesn't exists or if it's not an array property}
    procedure SetDefaultPropery(const Name: string);
    {create an instance of this class without using the actual class}
    constructor Create2(ClassName: string; aOwner: TIFPSPascalCompiler);
    {create an instance of this class and use the actual class information}
    constructor Create(FClass: TClass; aOwner: TIFPSPascalCompiler);
    destructor Destroy; override;
  end;

{Set the export name of a global variable}
procedure SetVarExportName(P: TIFPSVar; const ExpName: string);
{Add an imported class variable, this should be assigned at runtime before executing}
function AddImportedClassVariable(Sender: TIFPSPascalCompiler; const VarName, VarType: string): Boolean;

const
  {Invalid value, this is returned by most functions of IFPS3 that return a cardinal, when they fail}
  InvalidVal = Cardinal(-1);

type
  {The parsed function type}
  TPMFuncType = (mftProc, mftConstructor);

{This function returns}
function IFPS3_mi2s(i: Cardinal): string;
{Parse a method header}
function ParseMethod(Owner: TIFPSPascalCompiler; const FClassName: string; const Decl: string; var DName, DStr: string; var Func: TPMFuncType): Boolean;


implementation

uses Classes, typInfo;

type
  TIFPSDelphiClass = class(TIFPSExternalClass)
  private
    Ce: TIFPSCompileTimeClass;
    CompareProcNo, CastProcNo, NilProcNo: Cardinal;
  public
    function SelfType: Cardinal; override;

    constructor Create(CE: TIFPSCompileTimeClass; TypeNo: Cardinal);
    destructor Destroy; override;

    function Property_Find(const Name: string; var Index: Cardinal): Boolean; override;
    function Property_Get(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
    function Property_Set(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
    function Property_GetHeader(Index: Cardinal; var s: string): Boolean; override;

    function Func_Find(const Name: string; var Index: Cardinal): Boolean; override;
    function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;

    function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; override;
    function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;

    function IsCompatibleWith(Cl: TIFPSExternalClass): Boolean; override;
    function SetNil(var ProcNo: Cardinal): Boolean; override;
    function CastToType(IntoType: Cardinal; var ProcNo: Cardinal): Boolean; override;
    function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; override;
  end;

procedure SetVarExportName(P: TIFPSVar; const ExpName: string);
begin
  if p <> nil then
    p.exportname := ExpName;
end;

function FindAndAddType(Owner: TIFPSPascalCompiler; const Name, Decl: string): Cardinal;
var
  tt: TIFPSType;
begin
  Result := Owner.FindType(Name);
  if Result = InvalidVal then
  begin
    tt := Owner.AddTypeS(Name, Decl);
    tt.ExportName := True;
    Result := Owner.FAvailableTypes.Count -1;
  end;
end;


function ParseMethod(Owner: TIFPSPascalCompiler; const FClassName: string; const Decl: string; var DName, DStr: string; var Func: TPMFuncType): Boolean;
var
  Parser: TIfPascalParser;
  FuncType: Byte;
  VNames, Name, NDecl: string;
  modifier: Char;
  VCType: Cardinal;

begin
  Parser := TIfPascalParser.Create;
  Parser.SetText(Decl);
  if Parser.CurrTokenId = CSTII_Function then
    FuncType:= 0
  else if Parser.CurrTokenId = CSTII_Procedure then
    FuncType := 1
  else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then
    FuncType := 2
  else
  begin
    Parser.Free;
    Result := False;
    exit;
  end;
  NDecl := '';
  Parser.Next;
  if Parser.CurrTokenId <> CSTI_Identifier then
  begin
    Parser.Free;
    Result := False;
    exit;
  end; {if}
  Name := Parser.GetToken;
  Parser.Next;
  if Parser.CurrTokenId = CSTI_OpenRound then
  begin
    Parser.Next;
    if Parser.CurrTokenId <> CSTI_CloseRound then
    begin
      while True do
      begin
        if Parser.CurrTokenId = CSTII_Const then
        begin
          modifier := '@';
          Parser.Next;
        end
        else
        if Parser.CurrTokenId = CSTII_Var then
        begin
          modifier := '!';
          Parser.Next;
        end
        else
          modifier := '@';
        if Parser.CurrTokenId <> CSTI_Identifier then
        begin
          Parser.Free;
          Result := False;
          exit;
        end;
        VNames := Parser.GetToken + '|';
        Parser.Next;
        while Parser.CurrTokenId = CSTI_Comma do
        begin
          Parser.Next;
          if Parser.CurrTokenId <> CSTI_Identifier then
          begin
            Parser.Free;
            Result := False;
            exit;
          end;
          VNames := VNames + Parser.GetToken + '|';
          Parser.Next;
        end;
        if Parser.CurrTokenId <> CSTI_Colon then
        begin
          Parser.Free;
          Result := False;
          exit;
        end;
        Parser.Next;
        if Parser.CurrTokenID = CSTII_Array then
        begin
          Parser.nExt;
          if Parser.CurrTokenId <> CSTII_Of then
          begin
            Parser.Free;
            Result := False;
            exit;
          end;
          Parser.Next;
          if Parser.CurrTokenId = CSTII_Const then
            VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of variant')
          else begin
            VCType := Owner.GetTypeCopyLinkInt(Owner.FindType(Parser.GetToken));
            if VCType = InvalidVal then
            begin
              Parser.Free;
              Result := False;
              exit;
            end;
            case Owner.GetAvailableType(VCType).BaseType of
              btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of byte');
              btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
              btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
              btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
              btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
              btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of Longint');
              btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
              btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double');
              btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended');
              btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of String');
              btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', 'array of PChar');
              btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of variant');
            {$IFNDEF IFPS3_NOINT64}btS64:  VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF}
              btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char');
            {$IFNDEF IFPS3_NOWIDESTRING}
              btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString');
              btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar');
            {$ENDIF}
              btClass:
                begin
                  if TIFPSClassType(Owner.GetAvailableType(VCType)).ClassHelper is TIFPSDelphiClass then
                  begin
                    VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject');
                  end else begin
                    Parser.Free;
                    Result := False;
                    exit;
                  end;
                end;
            else
              begin
                Parser.Free;
                Result := False;
                exit;
              end;
            end;
          end;
        end else begin
          VCType := Owner.FindType(Parser.GetToken);
          if VCType = InvalidVal then
          begin
            Parser.Free;
            Result := False;
            exit;
          end;
        end;
        while Pos('|', VNames) > 0 do
        begin
          NDecl := NDecl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1)
            +
            ' ' + inttostr(VCType);
          Delete(VNames, 1, Pos('|', VNames));
        end;
        Parser.Next;
        if Parser.CurrTokenId = CSTI_CloseRound then
          break;
        if Parser.CurrTokenId <> CSTI_Semicolon then
        begin
          Parser.Free;
          Result := False;
          exit;
        end;
        Parser.Next;
      end; {while}
    end; {if}
    Parser.Next;
  end; {if}
  if FuncType = 0 then
  begin
    if Parser.CurrTokenId <> CSTI_Colon then
    begin
      Parser.Free;
      Result := False;
      exit;
    end;

    Parser.Next;
    VCType := Owner.FindType(Parser.GetToken);
    if VCType = InvalidVal then
    begin
      Parser.Free;
      Result := False;
      exit;
    end;
  end
  else if FuncType = 2 then {constructor}
  begin
    VCType := Owner.FindType(FClassName)
  end else
    VCType := InvalidVal;
  NDecl := inttostr(VCType) + NDecl;
  Parser.Free;
  DName := Name;
  DStr := NDecl;
  if FuncType = 2 then
    Func := mftConstructor
  else
    Func := mftProc;
  Result := True;
end;

function TIFPSPascalCompiler.FindProc(const Name: string): Cardinal;
var
  l, h: Longint;
  x: TIFPSProcedure;
  xr: TIFPSRegProc;
  temp: string;

begin
  h := MakeHash(Name);
  for l := FProcs.Count - 1 downto 0 do
  begin
    x := FProcs.Data^[l];
    if x.ClassType = TIFPSInternalProcedure then
    begin
      if (TIFPSInternalProcedure(x).NameHash = h) and
        (TIFPSInternalProcedure(x).Name = Name) then
      begin
        Result := l;
        exit;
      end;
    end
    else
    begin
      if (TIFPSExternalProcedure(x).RegProc.NameHash = h) and
        (TIFPSExternalProcedure(x).RegProc.Name = Name) then
      begin
        Result := l;
        exit;
      end;
    end;
  end;
  for l := 0 to FRegProcs.Count - 1 do
  begin
    xr := FRegProcs[l];
    if (xr.NameHash = h) and (xr.Name = Name) then
    begin
      x := TIFPSExternalProcedure.Create;
      TIFPSExternalProcedure(x).RegProc := xr;
      temp := xr.Decl;
      ReplaceTypes(temp);
      xr.Decl := temp;
      FProcs.Add(x);
      Result := FProcs.Count - 1;
      exit;
    end;
  end;
  Result := InvalidVal;
end; {findfunc}


function TIFPSPascalCompiler.GetType(FUseUsedTypes: Boolean; BaseType: TIFPSBaseType): Cardinal;
var
  l: Longint;
  x: TIFPSType;
begin
  if FUseUsedTypes then
  begin
    for l := 0 to FUsedTypes.Count - 1 do
    begin
      x := FUsedTypes[l];
      if (x.BaseType = BaseType) and (x.ClassType = TIFPSType) then
      begin
        Result := l;
        exit;
      end;
    end;
  end;
  for l := 0 to FAvailableTypes.Count - 1 do
  begin
    x := FAvailableTypes[l];
    if (x.BaseType = BaseType) and (x.ClassType = TIFPSType) then
    begin
      if FUseUsedTypes then
      begin
        FUsedTypes.Add(x);
        Result := FUsedTypes.Count - 1;
      end else begin
        Result := l;
      end;
      exit;
    end;
  end;
  X := TIFPSType.Create;
  x.Name := '';
  x.BaseType := BaseType;
  x.DeclarePos := InvalidVal;
  x.DeclareCol := 0;
  x.DeclareRow := 0;
  x.Use;
  Result := FAvailableTypes.Add(x);
  if FUseUsedTypes then
  begin
    Result := FUsedTypes.Add(x);
  end;
end;

function TIFPSPascalCompiler.MakeDecl(decl: string): string;
var
  s: string;
  c: char;
begin
  s := grfw(decl);
  if s = '-1' then result := '0' else
  result := TIFPSType(FUsedTypes[StrToInt(s)]).Name;

  while length(decl) > 0 do
  begin
    s := grfw(decl);
    c := s[1];
    s := TIFPSType(FUsedTypes[StrToInt(grfw(decl))]).Name;
    result := result +' '+c+s;
  end;
end;


{ TIFPSPascalCompiler }

const
  BtTypeCopy = 255;


type
  TFuncType = (ftProc, ftFunc);

function IFPS3_mi2s(i: Cardinal): string;
begin
  Result := #0#0#0#0;
  Cardinal((@Result[1])^) := i;
end;




function TIFPSPascalCompiler.AddType(const Name: string; const BaseType: TIFPSBaseType): TIFPSType;
begin
  if FProcs = nil then
  begin
    raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  end;

  case BaseType of
    btProcPtr: Result := TIFPSProceduralType.Create;
    BtTypeCopy: Result := TIFPSTypeLink.Create;
    btRecord: Result := TIFPSRecordType.Create;
    btArray: Result := TIFPSArrayType.Create;
    btStaticArray: Result := TIFPSStaticArrayType.Create;
    btClass: Result := TIFPSClassType.Create;
    btResourcePointer: Result := TIFPSResourcePtrType.Create; 
  else
    Result := TIFPSType.Create;
  end;
  Result.Name := FastUppercase(Name);
  Result.OriginalName := Name;
  Result.BaseType := BaseType;
  Result.DeclarePos := InvalidVal;
  Result.DeclareCol := 0;
  Result.DeclareRow := 0;
  FAvailableTypes.Add(Result);
end;


function TIFPSPascalCompiler.AddFunction(const Header: string): TIFPSRegProc;
var
  Parser: TIfPascalParser;
  IsFunction: Boolean;
  VNames, Name, Decl: string;
  modifier: Char;
  VCType: Cardinal;
  x: TIFPSRegProc;
begin
  if FProcs = nil then
    raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');

  Parser := TIfPascalParser.Create;
  Parser.SetText(Header);
  if Parser.CurrTokenId = CSTII_Function then
    IsFunction := True
  else if Parser.CurrTokenId = CSTII_Procedure then
    IsFunction := False
  else
  begin
    Parser.Free;
    Raise EIFPSCompilerException.Create('Unable to register function '+Name);
  end;
  Decl := '';
  Parser.Next;
  if Parser.CurrTokenId <> CSTI_Identifier then
  begin
    Parser.Free;
    Raise EIFPSCompilerException.Create('Unable to register function '+Name);
  end; {if}
  Name := Parser.GetToken;
  Parser.Next;
  if Parser.CurrTokenId = CSTI_OpenRound then
  begin
    Parser.Next;
    if Parser.CurrTokenId <> CSTI_CloseRound then
    begin
      while True do
      begin
        if Parser.CurrTokenId = CSTII_Const then
        begin
          Modifier := '@';
          Parser.Next;
        end else
        if Parser.CurrTokenId = CSTII_Var then
        begin
          modifier := '!';
          Parser.Next;
        end
        else
          modifier := '@';
        if Parser.CurrTokenId <> CSTI_Identifier then
        begin
          Parser.Free;
          Raise EIFPSCompilerException.Create('Unable to register function '+Name);
        end;
        VNames := Parser.GetToken + '|';
        Parser.Next;
        while Parser.CurrTokenId = CSTI_Comma do
        begin
          Parser.Next;
          if Parser.CurrTokenId <> CSTI_Identifier then
          begin
            Parser.Free;
            Raise EIFPSCompilerException.Create('Unable to register function '+Name);
          end;
          VNames := VNames + Parser.GetToken + '|';
          Parser.Next;
        end;
        if Parser.CurrTokenId <> CSTI_Colon then
        begin
          Parser.Free;
          Raise EIFPSCompilerException.Create('Unable to register function '+Name);
        end;
        Parser.Next;
        VCType := FindType(Parser.GetToken);
        if VCType = InvalidVal then
        begin
          Parser.Free;
          Raise EIFPSCompilerException.Create('Unable to register function '+Name);
        end;
        while Pos('|', VNames) > 0 do
        begin
          Decl := Decl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1)
            +
            ' ' + inttostr(VCType);
          Delete(VNames, 1, Pos('|', VNames));
        end;
        Parser.Next;
        if Parser.CurrTokenId = CSTI_CloseRound then
          break;
        if Parser.CurrTokenId <> CSTI_Semicolon then
        begin
          Parser.Free;
          Raise EIFPSCompilerException.Create('Unable to register function '+Name);
        end;
        Parser.Next;
      end; {while}
    end; {if}
    Parser.Next;
  end; {if}
  if IsFunction then
  begin
    if Parser.CurrTokenId <> CSTI_Colon then
    begin
      Parser.Free;
      Raise EIFPSCompilerException.Create('Unable to register function '+Name);
    end;

    Parser.Next;
    VCType := FindType(Parser.GetToken);
    if VCType = InvalidVal then
    begin
      Parser.Free;
      Raise EIFPSCompilerException.Create('Unable to register function '+Name);
    end;
  end
  else
    VCType := InvalidVal;
  Decl := inttostr(VCType) + Decl;
  Parser.Free;
  X := TIFPSRegProc.Create;
  x.Name := Name;
  x.ExportName := True;
  x.Decl := Decl;
  Result := x;
  FRegProcs.Add(x);
end;

function TIFPSPascalCompiler.MakeHint(const Module: string; E: TIFPSPascalCompilerHintType; const Param: string): TIFPSPascalCompilerMessage;
var
  n: TIFPSPascalCompilerHint;
begin
  N := TIFPSPascalCompilerHint.Create;
  n.FHint := e;
  n.SetParserPos(FParser);
  n.FModuleName := Module;
  n.FParam := Param;
  FMessages.Add(n);
  Result := n;
end;
function TIFPSPascalCompiler.MakeError(const Module: string; E:
  TIFPSPascalCompilerErrorType; const Param: string): TIFPSPascalCompilerMessage;
var
  n: TIFPSPascalCompilerError;
begin
  N := TIFPSPascalCompilerError.Create;
  n.FError := e;
  n.SetParserPos(FParser);
  n.FModuleName := Module;
  n.FParam := Param;
  FMessages.Add(n);
  Result := n;
end;

function TIFPSPascalCompiler.MakeWarning(const Module: string; E:
  TIFPSPascalCompilerWarningType; const Param: string): TIFPSPascalCompilerMessage;
var
  n: TIFPSPascalCompilerWarning;
begin
  N := TIFPSPascalCompilerWarning.Create;
  n.FWarning := e;
  n.SetParserPos(FParser);
  n.FModuleName := Module;
  n.FParam := Param;
  FMessages.Add(n);
  Result := n;
end;

procedure TIFPSPascalCompiler.Clear;
var
  l: Longint;
begin
  FDebugOutput := '';
  FOutput := '';
  for l := 0 to FMessages.Count - 1 do
    TIFPSPascalCompilerMessage(FMessages[l]).Free;
  FMessages.Clear;
  for L := FAutoFreeList.Count -1 downto 0 do
  begin
    TObject(FAutoFreeList[l]).Free;
  end;
  FAutoFreeList.Clear;
end;

procedure CopyVariantContents(Src, Dest: PIfRVariant);
begin
  Dest.BaseType := src.BaseType;
  case src.BaseType of
    btu8, bts8: dest^.tu8 := src^.tu8;
    btu16, bts16: dest^.tu16 := src^.tu16;
    btenum, btu32, bts32: dest^.tu32 := src^.tu32;
    btsingle: Dest^.tsingle := src^.tsingle;
    btdouble: Dest^.tdouble := src^.tdouble;
    btextended: Dest^.textended := src^.textended;
    btchar: Dest^.tchar := src^.tchar;
    {$IFNDEF IFPS3_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
    btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
    btwidechar: Dest^.tchar := src^.tchar;
    {$ENDIF}
  end;
end;

procedure InitializeVariant(FUseTypes: TIfList; Vari: PIfRVariant; FType: Cardinal; BaseType: TIFPSBaseType);
begin
  FillChar(vari^, SizeOf(TIfRVariant), 0);
  if BaseType = btSet then
  begin
    SetLength(tbtstring(vari^.tstring), TIFPSSetType(FUseTypes[fType]).ByteSize);
    fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0);
  end;
  vari^.FType := FType;
  vari.BaseType := BaseType;
end;
function NewVariant(FUseTypes: TIfList; FType: Cardinal; BaseType: TIFPSBaseType): PIfRVariant;
begin
  New(Result);
  InitializeVariant(FUseTypes, Result, FType, BaseType);
end;

procedure FinalizeVariant(var p: TIfRVariant);
begin
  if (p.BaseType = btString) or (p.basetype = btSet) then
    finalize(tbtstring(p.tstring))
  {$IFNDEF IFPS3_NOWIDESTRING}
  else if p.BaseType = btWideString then
    finalize(tbtWideString(p.twidestring)); // widestring
  {$ENDIF}
end;

procedure DisposeVariant(p: PIfRVariant);
begin
  if p <> nil then
  begin
    FinalizeVariant(p^);
    Dispose(p);
  end;
end;



function TIFPSPascalCompiler.GetTypeCopyLink(p: TIFPSType): TIFPSType;
begin
  if p.BaseType = BtTypeCopy then
  begin
    Result := FAvailableTypes[TIFPSTypeLink(p).LinkTypeNo];
  end else Result := p;
end;

function IsIntType(b: TIFPSBaseType): Boolean;
begin
  case b of
    btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF IFPS3_NOINT64}, btS64{$ENDIF}: Result := True;
  else
    Result := False;
  end;
end;

function IsRealType(b: TIFPSBaseType): Boolean;
begin
  case b of
    btSingle, btDouble, btExtended: Result := True;
  else
    Result := False;
  end;
end;

function IsIntRealType(b: TIFPSBaseType): Boolean;
begin
  case b of
    btSingle, btDouble, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF IFPS3_NOINT64}, btS64{$ENDIF}:
      Result := True;
  else
    Result := False;
  end;

end;

function DiffRec(p1, p2: TIFPSSubItem): Boolean;
begin
  if p1.ClassType = p2.ClassType then
  begin
    if P1.ClassType = TIFPSSubNumber then
      Result := TIFPSSubNumber(p1).SubNo <> TIFPSSubNumber(p2).SubNo
    else if P1.ClassType = TIFPSSubValue then
      Result := TIFPSSubValue(p1).SubNo <> TIFPSSubValue(p2).SubNo
    else
      Result := False;
  end else Result := True;
end;

function SameReg(x1, x2: TIFPSValue): Boolean;
var
  I: Longint;
begin
  if (x1.ClassType = x2.ClassType) and (X1 is TIFPSValueVar) then
  begin
    if
    ((x1.ClassType = TIFPSValueGlobalVar) and (TIFPSValueGlobalVar(x1).GlobalVarNo = TIFPSValueGlobalVar(x2).GlobalVarNo)) or
    ((x1.ClassType = TIFPSValueLocalVar) and (TIFPSValueLocalVar(x1).LocalVarNo = TIFPSValueLocalVar(x2).LocalVarNo)) or
    ((x1.ClassType = TIFPSValueParamVar) and (TIFPSValueParamVar(x1).ParamNo = TIFPSValueParamVar(x2).ParamNo)) or
    ((x1.ClassType = TIFPSValueAllocatedStackVar) and (TIFPSValueAllocatedStackVar(x1).LocalVarNo = TIFPSValueAllocatedStackVar(x2).LocalVarNo)) then
    begin
      if TIFPSValueVar(x1).GetRecCount <> TIFPSValueVar(x2).GetRecCount then
      begin
        Result := False;
        exit;
      end;
      for i := 0 to TIFPSValueVar(x1).GetRecCount -1 do
      begin
        if DiffRec(TIFPSValueVar(x1).RecItem[i], TIFPSValueVar(x2).RecItem[i]) then
        begin
          Result := False;
          exit;
        end;
      end;
      Result := True;
    end else Result := False;
  end
  else
    Result := False;
end;

function D1(const s: string): string;
begin
  Result := copy(s, 2, Length(s) - 1);
end;

function TIFPSPascalCompiler.AT2UT(L: Cardinal): Cardinal;
var
  i: Longint;
  p: TIFPSType;
begin
  if L = InvalidVal then begin Result := InvalidVal; exit; end;
  p := FAvailableTypes[L];
  p := GetTypeCopyLink(p);
  if p.Used then
  begin
    for i := 0 to FUsedTypes.Count - 1 do
    begin
      if FUSedTypes[I] = P then
      begin
        Result := i;
        exit;
      end;
    end;
  end;
  UpdateRecordFields(p);
  p.Use;
  FUsedTypes.Add(p);
  Result := FUsedTypes.Count - 1;
end;


procedure TIFPSPascalCompiler.ReplaceTypes(var s: string);
var
  NewS: string;
  ts: string;
begin
  ts := GRFW(s);
  if ts <> '-1' then
  begin
    NewS := IntToStr(AT2UT(StrToInt(ts)));
  end
  else
    NewS := '-1';
  while length(s) > 0 do
  begin
    NewS := NewS + ' ' + grfw(s);
    ts := grfw(s);
    NewS := NewS + ' ' + IntToStr(AT2UT(StrToInt(ts)));
  end;
  s := NewS;
end;

function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal;
begin
  case Src.BaseType of
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.ts8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;

function GetInt(Src: PIfRVariant; var s: Boolean): Longint;
begin
  case Src.BaseType of
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.ts8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;
{$IFNDEF IFPS3_NOINT64}
function GetInt64(Src: PIfRVariant; var s: Boolean): Int64;
begin
  case Src.BaseType of
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.ts8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    bts64: Result := src^.ts64;
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;
{$ENDIF}

function GetReal(Src: PIfRVariant; var s: Boolean): Extended;
begin
  case Src.BaseType of
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.ts8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btSingle: Result := Src^.tsingle;
    btDouble: Result := Src^.tdouble;
    btExtended: Result := Src^.textended;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;

function GetString(Src: PIfRVariant; var s: Boolean): string;
begin
  case Src.BaseType of
    btChar: Result := Src^.tchar;
    btString: Result := tbtstring(src^.tstring);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: Result := src^.twidechar;
    btWideString: Result := tbtWideString(src^.twidestring);
    {$ENDIF}
  else
    begin
      s := False;
      Result := '';
    end;
  end;
end;

{$IFNDEF IFPS3_NOWIDESTRING}
function TIFPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): WideString;
begin
  case Src.BaseType of
    btChar: Result := Src^.tchar;
    btString: Result := tbtstring(src^.tstring);
    btWideChar: Result := src^.twidechar;
    btWideString: Result := tbtWideString(src^.twidestring);
  else
    begin
      s := False;
      Result := '';
    end;
  end;
end;
{$ENDIF}

function ab(b: Longint): Longint;
begin
  ab := Longint(b = 0);
end;

procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] or Src^[i];
end;

procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] and not Src^[i];
end;

procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] and Src^[i];
end;

procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
var
  i: Integer;
begin
  for i := ByteSize -1 downto 0 do
  begin
    if not (Src^[i] and Dest^[i] = Dest^[i]) then
    begin
      Val := False;
      exit;
    end;
  end;
  Val := True;
end;

procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
  begin
    if Dest^[i] <> Src^[i] then
    begin
      Val := False;
      exit;
    end;
  end;
  val := True;
end;

procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
begin
  Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
end;

procedure Set_MakeMember(Item: Longint; Src: PByteArray);
begin
  Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7));
end;

procedure ConvertToBoolean(SE: TIFPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean);
begin
  FinalizeVariant(var1^);
  if FUseUsedTypes then
    Var1^.FType := se.at2ut(se.FBooleanType)
  else
    Var1^.FType := Se.FBooleanType;
  var1.BaseType := btEnum;
  var1^.tu32 := Ord(b);
end;

procedure ConvertToString(SE: TIFPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: string);
begin
  FinalizeVariant(var1^);
  if FUseUsedTypes then
    InitializeVariant(SE.FUsedTypes, var1, se.GetType(FUseUsedTypes, btString), btString)
  else
    InitializeVariant(Se.FAvailableTypes, var1, se.GetType(FUseUsedTypes, btString), btString);
  tbtstring(var1^.tstring) := s;
end;
{$IFNDEF IFPS3_NOWIDESTRING}
procedure ConvertToWideString(SE: TIFPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: WideString);
begin
  FinalizeVariant(var1^);
  if FUseUsedTypes then
    InitializeVariant(SE.FUsedTypes, var1, se.GetType(FUseUsedTypes, btWideString), btWideString)
  else
    InitializeVariant(Se.FAvailableTypes, var1, se.GetType(FUseUsedTypes, btWideString), btWideString);
  tbtwidestring(var1^.tstring) := s;
end;
{$ENDIF}
procedure ConvertToFloat(SE: TIFPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: Cardinal);
var
  vartemp: PIfRVariant;
  b: Boolean;
begin
  New(vartemp);
  if FUseUsedTypes then
    InitializeVariant(SE.FUsedTypes, vartemp, var1.FType, Var1.BaseType)
  else
    InitializeVariant(Se.FAvailableTypes, vartemp, var1.FType, Var1.BaseType);
  CopyVariantContents(var1, vartemp);
  FinalizeVariant(var1^);
  if FUseUsedTypes then
    InitializeVariant(SE.FUsedTypes, var1, newtype, TIFPSType(se.FUsedTypes[NewType]).BaseType)
  else
    InitializeVariant(Se.FAvailableTypes, var1, newtype, TIFPSType(Se.FAvailableTypes[NewType]).BaseType);
  case var1.basetype of
    btSingle:
      begin
        if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
          var1^.tsingle := GetUInt(vartemp, b)
        else
          var1^.tsingle := GetInt(vartemp, b)
      end;
    btDouble:
      begin
        if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
          var1^.tdouble := GetUInt(vartemp, b)
        else
          var1^.tdouble := GetInt(vartemp, b)
      end;
    btExtended:
      begin
        if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
          var1^.textended:= GetUInt(vartemp, b)
        else
          var1^.textended:= GetInt(vartemp, b)
      end;
  end;
  DisposeVariant(vartemp);
end;

function TIFPSPascalCompiler.GetTypeFromList(FUseUsedTypes: Boolean; Num: Cardinal): TIFPSType;
begin
  if FUseUsedTypes then
    Result := TIFPSType(FUsedTypes[Num])
  else
    Result := TIFPSType(FAvailableTypes[Num])
end;

function TIFPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TIFPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
  { var1=dest, var2=src }
var
  b: Boolean;



begin
  Result := True;
  try
    if (IsRealType(var2.BaseType) and IsIntType(var1.BaseType)) then
      ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType);
    case Cmd of
      otAdd:
        begin { + }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result);
            btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Union(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize);
                end else Result := False;
              end;
            btChar:
              begin
                ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b));
              end;
            btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result);
            {$IFNDEF IFPS3_NOWIDESTRING}
            btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
            btWidechar:
              begin
                if (var2.BaseType = btchar) or (var2.BaseType = btwidechar) then
                  var1^.tu16 := var1^.tu16 + GetUint(Var2, Result)
                else
                begin
                  ConvertToWideString(Self, FUseUsedTypes, var1, GetWideString(Var1, b)+GetWideString(Var2, b));
                end;
              end;
            {$ENDIF}
            else Result := False;
          end;
        end;
      otSub:
        begin { - }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Diff(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize);
                end else Result := False;
              end;
            else Result := False;
          end;
        end;
      otMul:
        begin { * }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Intersect(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize);
                end else Result := False;
              end;
            else Result := False;
          end;
        end;
      otDiv:
        begin { / }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
            btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
            else Result := False;
          end;
        end;
      otMod:
        begin { MOD }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF}
            else Result := False;
          end;
        end;
      otshl:
        begin { SHL }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF}
            else Result := False;
          end;
        end;
      otshr:
        begin { SHR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF}
            else Result := False;
          end;
        end;
      otAnd:
        begin { AND }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
            btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF}
            else Result := False;
          end;
        end;
      otor:
        begin { OR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF}
            btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
            else Result := False;
          end;
        end;
      otxor:
        begin { XOR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF}
            btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
            else Result := False;
          end;
        end;
      otGreaterEqual:
        begin { >= }
          case var1.BaseType of
            btU8: b := var1^.tu8 >= GetUint(Var2, Result);
            btS8: b := var1^.ts8 >= Getint(Var2, Result);
            btU16: b := var1^.tu16 >= GetUint(Var2, Result);
            btS16: b := var1^.ts16 >= Getint(Var2, Result);
            btU32: b := var1^.tu32 >= GetUint(Var2, Result);
            btS32: b := var1^.ts32 >= Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle >= GetReal( Var2, Result);
            btDouble: b := var1^.tdouble >= GetReal( Var2, Result);
            btExtended: b := var1^.textended >= GetReal( Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Subset(var2.tstring, var1.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize, b);
                end else Result := False;
              end;
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otLessEqual:
        begin { <= }
          case var1.BaseType of
            btU8: b := var1^.tu8 <= GetUint(Var2, Result);
            btS8: b := var1^.ts8 <= Getint(Var2, Result);
            btU16: b := var1^.tu16 <= GetUint(Var2, Result);
            btS16: b := var1^.ts16 <= Getint(Var2, Result);
            btU32: b := var1^.tu32 <= GetUint(Var2, Result);
            btS32: b := var1^.ts32 <= Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle <= GetReal( Var2, Result);
            btDouble: b := var1^.tdouble <= GetReal( Var2, Result);
            btExtended: b := var1^.textended <= GetReal( Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Subset(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize, b);
                end else Result := False;
              end;
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otGreater:
        begin { > }
          case var1.BaseType of
            btU8: b := var1^.tu8 > GetUint(Var2, Result);
            btS8: b := var1^.ts8 > Getint(Var2, Result);
            btU16: b := var1^.tu16 > GetUint(Var2, Result);
            btS16: b := var1^.ts16 > Getint(Var2, Result);
            btU32: b := var1^.tu32 > GetUint(Var2, Result);
            btS32: b := var1^.ts32 > Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle > GetReal( Var2, Result);
            btDouble: b := var1^.tdouble > GetReal( Var2, Result);
            btExtended: b := var1^.textended > GetReal( Var2, Result);
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otLess:
        begin { < }
          case var1.BaseType of
            btU8: b := var1^.tu8 < GetUint(Var2, Result);
            btS8: b := var1^.ts8 < Getint(Var2, Result);
            btU16: b := var1^.tu16 < GetUint(Var2, Result);
            btS16: b := var1^.ts16 < Getint(Var2, Result);
            btU32: b := var1^.tu32 < GetUint(Var2, Result);
            btS32: b := var1^.ts32 < Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle < GetReal( Var2, Result);
            btDouble: b := var1^.tdouble < GetReal( Var2, Result);
            btExtended: b := var1^.textended < GetReal( Var2, Result);
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otNotEqual:
        begin { <> }
          case var1.BaseType of
            btU8: b := var1^.tu8 <> GetUint(Var2, Result);
            btS8: b := var1^.ts8 <> Getint(Var2, Result);
            btU16: b := var1^.tu16 <> GetUint(Var2, Result);
            btS16: b := var1^.ts16 <> Getint(Var2, Result);
            btU32: b := var1^.tu32 <> GetUint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF}
            btS32: b := var1^.ts32 <> Getint(Var2, Result);
            btSingle: b := var1^.tsingle <> GetReal( Var2, Result);
            btDouble: b := var1^.tdouble <> GetReal( Var2, Result);
            btExtended: b := var1^.textended <> GetReal( Var2, Result);
            btEnum: b := var1^.ts32 <> Getint(Var2, Result);
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Equal(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).GetByteSize, b);
                  b := not b;
                end else Result := False;
              end;
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otEqual:
        begin { = }
          case var1.BaseType of
            btU8: b := var1^.tu8 = GetUint(Var2, Result);
            btS8: b := var1^.ts8 = Getint(Var2, Result);
            btU16: b := var1^.tu16 = GetUint(Var2, Result);
            btS16: b := var1^.ts16 = Getint(Var2, Result);
            btU32: b := var1^.tu32 = GetUint(Var2, Result);
            btS32: b := var1^.ts32 = Getint(Var2, Result);
            {$IFNDEF IFPS3_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle = GetReal( Var2, Result);
            btDouble: b := var1^.tdouble = GetReal( Var2, Result);
            btExtended: b := var1^.textended = GetReal( Var2, Result);
            btEnum: b := var1^.ts32 = Getint(Var2, Result);
            btString: b := tbtstring(var1^.tstring) = GetString(var2, Result);
            btChar: b := var1^.tchar = GetString(var2, Result);
            {$IFNDEF IFPS3_NOWIDESTRING}
            btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result);
            btWideChar: b := var1^.twidechar = GetWideString(var2, Result);
            {$ENDIF}
            btSet:
              begin
                if (var1.FType = var2.FType) then
                begin
                  Set_Equal(var1.tstring, var2.tstring, TIFPSSetType(GetTypeFromList(FUseUsedTypes, var1.FType)).ByteSize, b);
                end else Result := False;
              end;
          else
            Result := False;
          end;
          ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
        end;
      otIn:
        begin
          if (var2.BaseType = btset) and (TIFPSSetType(var2).SetType = GetTypeFromList(FUseUsedTypes, Var1.FType)) then
          begin
            Set_membership(GetUint(var1, result), var2.tstring, b);
          end else Result := False;
        end;
      else
        Result := False;
    end;
  except
    on E: EDivByZero do
    begin
      Result := False;
      MakeError('', ecDivideByZero, '');
      Exit;
    end;
    on E: EZeroDivide do
    begin
      Result := False;
      MakeError('', ecDivideByZero, '');
      Exit;
    end;
    on E: EMathError do
    begin
      Result := False;
      MakeError('', ecMathError, e.Message);
      Exit;
    end;
    on E: Exception do
    begin
      Result := False;
      MakeError('', ecInternalError, E.Message);
      Exit;
    end;
  end;
  if not Result then
  begin
    with MakeError('', ecTypeMismatch, '') do
    begin
      FPosition := Pos;
      FRow := Row;
      FCol := Col;
    end;
  end;
end;

function TIFPSPascalCompiler.IsDuplicate(const s: string; const check: TIFPSDuplicCheck): Boolean;
var
  h, l: Longint;
  x: TIFPSProcedure;
begin
  h := MakeHash(s);
  if (s = 'RESULT') then
  begin
    Result := True;
    exit;
  end;
  if dcTypes in Check then
  for l := 0 to FAvailableTypes.Count - 1 do
  begin
    if (TIFPSType(FAvailableTypes[l]).NameHash = h) and
      (TIFPSType(FAvailableTypes[l]).Name = s) then
    begin
      Result := True;
      exit;
    end;
  end;

  if dcProcs in Check then
  for l := 0 to FProcs.Count - 1 do
  begin
    x := FProcs[l];
    if x.ClassType = TIFPSInternalProcedure then
    begin
      if (h = TIFPSInternalProcedure(x).NameHash) and (s = TIFPSInternalProcedure(x).Name) then
      begin
        Result := True;
        exit;
      end;
    end
    else
    begin
      if (TIFPSExternalProcedure(x).RegProc.NameHash = h) and
        (TIFPSExternalProcedure(x).RegProc.Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;
  end;
  if dcVars in Check then
  for l := 0 to FVars.Count - 1 do
  begin
    if (TIFPSVar(FVars[l]).NameHash = h) and
      (TIFPSVar(FVars[l]).Name = s) then
    begin
      Result := True;
      exit;
    end;
  end;
  if dcConsts in Check then
  for l := 0 to FConstants.Count -1 do
  begin
    if (TIFPSConstant(FConstants[l]).NameHash = h) and
      (TIFPSConstant(FConstants[l]).Name = s) then
    begin
      Result := TRue;
      exit;
    end;
  end;
  Result := False;
end;

function TIFPSPascalCompiler.ATNUT(C: Cardinal): Cardinal;
var
  i: Longint;
  P: TIFPSType;
begin
  p := FAvailableTypes[C];
  for i := 0 to FUsedTypes.Count -1 do
  begin
    if FUsedTypes[I] = P then
    begin
      Result := I;
      exit;
    end;
  end;
  result := InvalidVal;
end;


procedure ClearRecSubVals(RecSubVals: TIfList);
var
  I: Longint;
begin
  for I := 0 to RecSubVals.Count - 1 do
    TIFPSRecordFieldTypeDef(RecSubVals[I]).Free;
  RecSubVals.Free;
end;

function TIFPSPascalCompiler.ReadTypeAddProcedure(const Name: string; FParser: TIfPascalParser): Cardinal;
var
  IsFunction: Boolean;
  VNames, Decl: string;
  modifier: Char;
  VCType: Cardinal;
  x: TIFPSType;
  begin
  if FParser.CurrTokenId = CSTII_Function then
    IsFunction := True
  else
    IsFunction := False;
  Decl := '';
  FParser.Next;
  if FParser.CurrTokenId = CSTI_OpenRound then
  begin
    FParser.Next;
    if FParser.CurrTokenId <> CSTI_CloseRound then
    begin
      while True do
      begin
        if FParser.CurrTokenId = CSTII_Const then
        begin
          Modifier := '@';
          FParser.Next;
        end else
        if FParser.CurrTokenId = CSTII_Var then
        begin
          modifier := '!';
          FParser.Next;
        end
        else
          modifier := '@';
        if FParser.CurrTokenId <> CSTI_Identifier then
        begin
          Result := InvalidVal;
          if FParser = Self.FParser then
          MakeError('', ecIdentifierExpected, '');
          exit;
        end;
        VNames := FParser.GetToken + '|';
        FParser.Next;
        while FParser.CurrTokenId = CSTI_Comma do
        begin
          FParser.Next;
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            Result := InvalidVal;
            if FParser = Self.FParser then
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
          VNames := VNames + FParser.GetToken + '|';
          FParser.Next;
        end;
        if FParser.CurrTokenId <> CSTI_Colon then
        begin
          Result := InvalidVal;
          if FParser = Self.FParser then
            MakeError('', ecColonExpected, '');
          exit;
        end;
        FParser.Next;
        if FParser.CurrTokenId <> CSTI_Identifier then
        begin
          Result := InvalidVal;
          if FParser = self.FParser then
          MakeError('', ecIdentifierExpected, '');
          exit;
        end;
        VCType := FindType(FParser.GetToken);
        if VCType = InvalidVal then
        begin
          if FParser = self.FParser then
          MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
          Result := InvalidVal;
          exit;
        end;
        while Pos('|', VNames) > 0 do
        begin
          Decl := Decl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1) +
            ' ' + inttostr(VCType);
          Delete(VNames, 1, Pos('|', VNames));
        end;
        FParser.Next;
        if FParser.CurrTokenId = CSTI_CloseRound then
          break;
        if FParser.CurrTokenId <> CSTI_Semicolon then
        begin
          if FParser = Self.FParser then
          MakeError('', ecSemicolonExpected, '');
          Result := InvalidVal;
          exit;
        end;
        FParser.Next;
      end; {while}
    end; {if}
    FParser.Next;
    end; {if}
    if IsFunction then
    begin
      if FParser.CurrTokenId <> CSTI_Colon then
      begin
        if FParser = Self.FParser then
        MakeError('', ecColonExpected, '');
        Result := InvalidVal;
        exit;
      end;
    FParser.Next;
    if FParser.CurrTokenId <> CSTI_Identifier then
    begin
      Result := InvalidVal;
      if FParser = Self.FParser then
      MakeError('', ecIdentifierExpected, '');
      exit;
    end;
    VCType := self.FindType(FParser.GetToken);
    if VCType = InvalidVal then
    begin
      if FParser = self.FParser then
      MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
      Result := InvalidVal;
      exit;
    end;
    FParser.Next;
  end
  else
    VCType := InvalidVal;
  Decl := inttostr(VCType) + Decl;
  X := TIFPSProceduralType.Create;
  x.Name := FastUppercase(Name);
  x.OriginalName := Name;
  x.BaseType := btProcPtr;
  x.DeclarePos := FParser.CurrTokenPos;
  x.DeclareRow := FParser.Row;
  x.DeclareCol := FParser.Col;
  TIFPSProceduralType(x).ProcDef := Decl;
  FAvailableTypes.Add(X);
  Result := FAvailableTypes.Count -1;
end; {ReadTypeAddProcedure}


function TIFPSPascalCompiler.ReadType(const Name: string; FParser: TIfPascalParser): Cardinal; // InvalidVal = Invalid
var
  TypeNo: Cardinal;
  h, l: Longint;
  fieldname,s: string;
  RecSubVals: TIfList;
  FArrayStart, FArrayLength: Longint;
  rvv: PIFPSRecordFieldTypeDef;
  p, p2: TIFPSType;
  tempf: PIfRVariant;

begin
  if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
  begin
     Result := ReadTypeAddProcedure(Name, FParser);
     Exit;
  end else if FParser.CurrTokenId = CSTII_Set then
  begin
    FParser.Next;
    if FParser.CurrTokenId <> CSTII_Of then
    begin
      MakeError('', ecOfExpected, '');
      Result := InvalidVal;
      Exit;
    end;
    FParser.Next;
    if FParser.CurrTokenID <> CSTI_Identifier then
    begin
      MakeError('', ecIdentifierExpected, '');
      Result := InvalidVal;
      exit;
    end;
    TypeNo := FindType(FParser.GetToken);
    if TypeNo = Invalidval then
    begin
      MakeError('', ecUnknownIdentifier, '');
      Result := InvalidVal;
      exit;
    end;
    p := FAvailableTypes[TypeNo];
    if (p.BaseType = btEnum) or (p.BaseType = btChar) or (p.BaseType = btU8) then
    begin
      FParser.Next;
      p2 := TIFPSSetType.Create;
      p2.Name := FastUppercase(Name);
      p2.OriginalName := Name;
      p2.BaseType := btSet;
      p2.DeclarePos := FParser.CurrTokenPos;
      p2.DeclareRow := FParser.Row;
      p2.DeclareCol := FParser.Col;
      TIFPSSetType(p2).SetType := p;
      Result := FAvailableTypes.Add(p2);
    end else
    begin
      MakeError('', ecTypeMismatch, '');
      Result := InvalidVal;
    end;
    exit;
  end else if FParser.CurrTokenId = CSTI_OpenRound then
  begin
    FParser.Next;
    L := 0;
    P := TIFPSEnumType.Create;
    P.Name := FastUppercase(Name);
    p.OriginalName := Name;
    p.BaseType := btEnum;
    p.DeclarePos := FParser.CurrTokenPos;
    p.DeclareRow := FParser.Row;
    p.DeclareCol := FParser.Col;
    FAvailableTypes.Add(p);

    TypeNo := FAvailableTypes.Count -1;
    repeat
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        if FParser = Self.FParser then
        MakeError('', ecIdentifierExpected, '');
        Result := InvalidVal;
        exit;
      end;
      s := FParser.GetToken;
      if IsDuplicate(s, [dcTypes]) then
      begin
        if FParser = Self.FParser then
        MakeError('', ecDuplicateIdentifier, s);
        Result := InvalidVal;
        Exit;
      end;
      AddConstant(s, TypeNo).FValue.tu32 := L;
      Inc(L);
      FParser.Next;
      if FParser.CurrTokenId = CSTI_CloseRound then
        Break
      else if FParser.CurrTokenId <> CSTI_Comma then
      begin
        if FParser = Self.FParser then
        MakeError('', ecCloseRoundExpected, '');
        Result := InvalidVal;
        Exit;
      end;
      FParser.Next;
    until False;
    FParser.Next;
    TIFPSEnumType(p).HighValue := L-1;
    Result := TypeNo;
    exit;
  end else
  if FParser.CurrTokenId = CSTII_Array then
  begin
    FParser.Next;
    if FParser.CurrTokenID = CSTI_OpenBlock then
    begin
      FParser.Next;
      tempf := ReadConstant(FParser, CSTI_TwoDots);
      if tempf = nil then
      begin
        Result := InvalidVal;
        exit;
      end;
      case tempf.BaseType of
        btU8: FArrayStart := tempf.tu8;
        btS8: FArrayStart := tempf.ts8;
        btU16: FArrayStart := tempf.tu16;
        btS16: FArrayStart := tempf.ts16;
        btU32: FArrayStart := tempf.tu32;
        btS32: FArrayStart := tempf.ts32;
        {$IFNDEF IFPS3_NOINT64}
        bts64: FArrayStart := tempf.ts64;
        {$ENDIF}
      else
        begin
          MakeError('', ecTypeMismatch, '');
          Result := InvalidVal;
          exit;
        end;
      end;
      if FParser.CurrTokenID <> CSTI_TwoDots then
      begin
        MakeError('', ecPeriodExpected, '');
        Result := InvalidVal;
        exit;
      end;
      FParser.Next;
      tempf := ReadConstant(FParser, CSTI_CloseBlock);
      if tempf = nil then
      begin
        Result := InvalidVal;
        exit;
      end;
      case tempf.BaseType of
        btU8: FArrayLength := tempf.tu8;
        btS8: FArrayLength := tempf.ts8;
        btU16: FArrayLength := tempf.tu16;
        btS16: FArrayLength := tempf.ts16;
        btU32: FArrayLength := tempf.tu32;
        btS32: FArrayLength := tempf.ts32;
        {$IFNDEF IFPS3_NOINT64}
        bts64: FArrayLength := tempf.ts64;
        {$ENDIF}
      else
        MakeError('', ecTypeMismatch, '');
        Result := InvalidVal;
        exit;
      end;
      FArrayLength := FArrayLength - FArrayStart + 1;
      if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := InvalidVal;
        exit;
      end;
      if FParser.CurrTokenID <> CSTI_CloseBlock then
      begin
        MakeError('', ecCloseBlockExpected, '');
        Result := InvalidVal;
        exit;
      end;
      FParser.Next;
    end else
    begin
      FArrayStart := 0;
      FArrayLength := -1;
    end;
    if FParser.CurrTokenId <> CSTII_Of then
    begin
      if FParser = Self.FParser then
      MakeError('', ecOfExpected, '');
      Result := InvalidVal;
      exit;
    end;
    FParser.Next;
    L := ReadType('', FParser);
    if L = -1 then
    begin
      if FParser = Self.FParser then
      MakeError('', ecUnknownIdentifier, '');
      Result := InvalidVal;
      exit;
    end;
    if (Name = '') and (FArrayLength = -1) then
    begin
      TypeNo := ATNUT(l);
      if TypeNo <> InvalidVal then
      begin
        for h := 0 to FUsedTypes.Count -1 do
        begin
          p := FUsedTypes[H];
          if (p.BaseType = btArray) and (TIFPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then
          begin
            for l := 0 to FAvailableTypes.Count -1 do
            begin
              if FAvailableTypes[l] = P then
              begin
                Result := l;
                exit;
              end;
            end;
            if FParser = Self.FParser then
            MakeError('', ecInternalError, '0001C');
            Result := InvalidVal;
            Exit;
          end;
        end;
      end;
      for h := 0 to FAvailableTypes.Count -1 do
      begin
        p := FAvailableTypes[H];
        if (p.BaseType = btArray) and (TIFPSArrayType(p).ArrayTypeNo = Cardinal(L)) and (not p.Used) and (Copy(p.Name, 1, 1) <> '!') then
        begin
          Result := H;
          Exit;
        end;
      end;
    end;
    if FArrayLength <> -1 then
    begin
      p := TIFPSStaticArrayType.Create;
      TIFPSStaticArrayType(p).StartOffset := FArrayStart;
      TIFPSStaticArrayType(p).Length := FArrayLength;
      p.BaseType := btStaticArray;
    end else
    begin
      p := TIFPSArrayType.Create;
      p.BaseType := btArray;
    end;
    p.Name := FastUppercase(Name);
    p.OriginalName := Name;
    p.DeclarePos := FParser.CurrTokenPos;
    p.DeclareRow := FParser.Row;
    p.DeclareCol := FParser.Col;
    TIFPSArrayType(p).ArrayTypeNo := L;
    FAvailableTypes.Add(p);
    Result := Cardinal(FAvailableTypes.Count -1);
    Exit;
  end
  else if FParser.CurrTokenId = CSTII_Record then
  begin
    FParser.Next;
    RecSubVals := TIfList.Create;
    repeat
      repeat
        if FParser.CurrTokenId <> CSTI_Identifier then
        begin
          ClearRecSubVals(RecSubVals);
          if FParser = Self.FParser then
          MakeError('', ecIdentifierExpected, '');
          Result := InvalidVal;
          exit;
        end;
        FieldName := FParser.GetToken;
        s := S+FieldName+'|';
        FParser.Next;
        TypeNo := MakeHash(S);
        for l := 0 to RecSubVals.Count - 1 do
        begin
          if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = Longint(TypeNo)) and
            (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = s) then
          begin
            if FParser = Self.FParser then
              MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
            ClearRecSubVals(RecSubVals);
            Result := InvalidVal;
            exit;
          end;
        end;
        if FParser.CurrTokenID = CSTI_Colon then Break else
        if FParser.CurrTokenID <> CSTI_Comma then
        begin
          if FParser = Self.FParser then
            MakeError('', ecColonExpected, '');
          ClearRecSubVals(RecSubVals);
          Result := InvalidVal;
          exit;
        end;
        FParser.Next;
      until False;
      FParser.Next;
      l := ReadType('', FParser);
      if L = -1 then
      begin
        ClearRecSubVals(RecSubVals);
        Result := InvalidVal;
        exit;
      end;
      P := FAvailableTypes[l];
      if p.BaseType = BtTypeCopy then
        L := TIFPSTypeLink(p).LinkTypeNo;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        ClearRecSubVals(RecSubVals);
        if FParser = Self.FParser then
        MakeError('', ecSemicolonExpected, '');
        Result := InvalidVal;
        exit;
      end; {if}
      FParser.Next;
      while Pos('|', s) > 0 do
      begin
        fieldname := copy(s, 1, pos('|', s)-1);
        Delete(s, 1, length(FieldName)+1);
        rvv := TIFPSRecordFieldTypeDef.Create;
        rvv.FieldName := fieldname;
        rvv.FType := l;
        RecSubVals.Add(rvv);
      end;
    until FParser.CurrTokenId = CSTII_End;
    FParser.Next; // skip CSTII_End
    P := TIFPSRecordType.Create;
    p.Name := FastUppercase(Name);
    p.OriginalName := Name;
    p.BaseType := btRecord;
    p.DeclarePos := FParser.CurrTokenPos;
    p.DeclareRow := FParser.Row;
    p.DeclareCol := FParser.Col;
    for l := 0 to RecSubVals.Count -1 do
    begin
      rvv := RecSubVals[l];
      with TIFPSRecordType(p).AddRecVal do
      begin
        FieldName := rvv.FieldName;
        FType := rvv.FType;
      end;
      rvv.Free;
    end;
    RecSubVals.Free;
    FAvailableTypes.Add(p);
    Result := FAvailableTypes.Count -1;
    Exit;
  end else if FParser.CurrTokenId = CSTI_Identifier then
  begin
    s := FParser.GetToken;
    h := MakeHash(s);
    TypeNo := InvalidVal;
    for l := 0 to FAvailableTypes.Count - 1 do
    begin
      p2 := FAvailableTypes[l];
      if (p2.NameHash = h) and (p2.Name = s) then
      begin
        FParser.Next;
        TypeNo := l;
        if p2.BaseType = BtTypeCopy then
          TypeNo := TIFPSTypeLink(p2).LinkTypeNo;
        Break;
      end;
    end;
    if TypeNo = InvalidVal then
    begin
      Result := InvalidVal;
      if FParser = Self.FParser then
      MakeError('', ecUnknownType, FParser.OriginalToken);
      exit;
    end;
    if Name <> '' then
    begin
      p := TIFPSTypeLink.Create;
      p.Name := FastUppercase(Name);
      p.OriginalName := Name;
      p.BaseType := BtTypeCopy;
      p.DeclarePos := FParser.CurrTokenPos;
      p.DeclareRow := FParser.Row;
      p.DeclareCol := FParser.Col;
      TIFPSTypeLink(p).LinkTypeNo := TypeNo;
      FAvailableTypes.Add(p);
      Result := FAvailableTypes.Count -1;
      Exit;
    end else
    begin
      Result := TypeNo;
      exit;
    end;
  end;
  Result := InvalidVal;
  if FParser = Self.FParser then
  MakeError('', ecIdentifierExpected, '');
  Exit;
end;

function TIFPSPascalCompiler.VarIsDuplicate(Proc: TIFPSInternalProcedure; const Varnames, s: string): Boolean;
var
  h, l: Longint;
  x: TIFPSProcedure;
  v: string;
begin
  h := MakeHash(s);
  if (s = 'RESULT') then
  begin
    Result := True;
    exit;
  end;

  for l := 0 to FProcs.Count - 1 do
  begin
    x := FProcs[l];
    if x.ClassType = TIFPSInternalProcedure then
    begin
      if (h = TIFPSInternalProcedure(x).NameHash) and (s = TIFPSInternalProcedure(x).Name) then
      begin
        Result := True;
        exit;
      end;
    end
    else
    begin
      if (TIFPSExternalProcedure(x).RegProc.NameHash = h) and (TIFPSExternalProcedure(x).RegProc.Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;
  end;
  if proc <> nil then
  begin
    for l := 0 to proc.ProcVars.Count - 1 do
    begin
      if (PIFPSProcVar(proc.ProcVars[l]).NameHash = h) and
        (TIFPSVar(proc.ProcVars[l]).Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;
  end
  else
  begin
    for l := 0 to FVars.Count - 1 do
    begin
      if (TIFPSVar(FVars[l]).NameHash = h) and
        (TIFPSVar(FVars[l]).Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;
  end;
  v := VarNames;
  while Pos('|', v) > 0 do
  begin
    if copy(v, 1, Pos('|', v) - 1) = s then
    begin
      Result := True;
      exit;
    end;
    Delete(v, 1, Pos('|', v));
  end;
  for l := 0 to FConstants.Count -1 do
  begin
    if (TIFPSConstant(FConstants[l]).NameHash = h) and
      (TIFPSConstant(FConstants[l]).Name = s) then
    begin
      Result := TRue;
      exit;
    end;
  end;
  Result := False;
end;


function TIFPSPascalCompiler.DoVarBlock(proc: TIFPSInternalProcedure): Boolean;
var
  VarName, s: string;
  VarType: Cardinal;
  VarNo: Cardinal;
  v: TIFPSVar;
  vp: PIFPSProcVar;

begin
  Result := False;
  FParser.Next; // skip CSTII_Var
  if FParser.CurrTokenId <> CSTI_Identifier then
  begin
    MakeError('', ecIdentifierExpected, '');
    exit;
  end;
  repeat
    if VarIsDuplicate(proc, VarName, FParser.GetToken) then
    begin
      MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
      exit;
    end;
    VarName := FParser.GetToken + '|';
    Varno := 0;
    if @FOnUseVariable <> nil then
    begin
      if Proc <> nil then
        FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
      else
        FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
    end;
    FParser.Next;
    while FParser.CurrTokenId = CSTI_Comma do
    begin
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
      end;
      if VarIsDuplicate(proc, VarName, FParser.GetToken) then
      begin
        MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
        exit;
      end;
      VarName := VarName + FParser.GetToken + '|';
      Inc(varno);
      if @FOnUseVariable <> nil then
      begin
        if Proc <> nil then
          FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
        else
          FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
      end;
      FParser.Next;
    end;
    if FParser.CurrTokenId <> CSTI_Colon then
    begin
      MakeError('', ecColonExpected, '');
      exit;
    end;
    FParser.Next;
    VarType := at2ut(ReadType('', FParser));
    if VarType = InvalidVal then
    begin
      exit;
    end;
    while Pos('|', VarName) > 0 do
    begin
      s := copy(VarName, 1, Pos('|', VarName) - 1);
      Delete(VarName, 1, Pos('|', VarName));
      if proc = nil then
      begin
        v := TIFPSVar.Create;
        v.Name := s;
        v.DeclarePos := FParser.CurrTokenPos;
        v.DeclareRow := FParser.Row;
        v.DeclareCol := FParser.Col;
        v.FType := VarType;
        FVars.Add(v);
      end
      else
      begin
        vp := TIFPSProcVar.Create;
        vp.Name := s;
        vp.aType := VarType;
        vp.DeclarePos := FParser.CurrTokenPos;
        vp.DeclareRow := FParser.Row;
        vp.DeclareCol := FParser.Col;
        proc.ProcVars.Add(vp);
      end;
    end;
    if FParser.CurrTokenId <> CSTI_Semicolon then
    begin
      MakeError('', ecSemicolonExpected, '');
      exit;
    end;
    FParser.Next;
  until FParser.CurrTokenId <> CSTI_Identifier;
  Result := True;
end;

function TIFPSPascalCompiler.NewProc(const OriginalName, Name: string): TIFPSInternalProcedure;
begin
  Result := TIFPSInternalProcedure.Create;
  Result.Decl := '-1';
  Result.OriginalName := OriginalName;
  Result.Name := Name;
  Result.DeclarePos := FParser.CurrTokenPos;
  Result.DeclareRow := FParser.Row;
  Result.DeclareCol := FParser.Col;
  FProcs.Add(Result);
end;

function TIFPSPascalCompiler.IsProcDuplicLabel(Proc: TIFPSInternalProcedure; const s: string): Boolean;
var
  i: Longint;
  h: Longint;
  u: string;
begin
  h := MakeHash(s);
  if s = 'RESULT' then
    Result := True
  else if Proc.Name = s then
    Result := True
  else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then
    Result := True
  else
  begin
    u := Proc.Decl;
    while Length(u) > 0 do
    begin
      if D1(GRFW(u)) = s then
      begin
        Result := True;
        exit;
      end;
      GRFW(u);
    end;
    for i := 0 to Proc.ProcVars.Count -1 do
    begin
      if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;
    for i := 0 to Proc.FLabels.Count -1 do
    begin
      u := Proc.FLabels[I];
      delete(u, 1, 4);
      if Longint((@u[1])^) = h then
      begin
        delete(u, 1, 4);
        if u = s then
        begin
          Result := True;
          exit;
        end;
      end;
    end;
    Result := False;
  end;
end;


function TIFPSPascalCompiler.ProcessLabel(Proc: TIFPSInternalProcedure): Boolean;
var
  CurrLabel: string;
begin
  FParser.Next;
  while true do
  begin
    if FParser.CurrTokenId <> CSTI_Identifier then
    begin
      MakeError('', ecIdentifierExpected, '');
      Result := False;
      exit;
    end;
    CurrLabel := FParser.GetToken;
    if IsProcDuplicLabel(Proc, CurrLabel) then
    begin
      MakeError('', ecDuplicateIdentifier, CurrLabel);
      Result := False;
      exit;
    end;
    FParser.Next;
    Proc.FLabels.Add(#$FF#$FF#$FF#$FF+IFPS3_mi2s(MakeHash(CurrLabel))+CurrLabel);
    if FParser.CurrTokenId = CSTI_Semicolon then
    begin
      FParser.Next;
      Break;
    end;
    if FParser.CurrTokenId <> CSTI_Comma then
    begin
      MakeError('', ecCommaExpected, '');
      Result := False;
      exit;
    end;
    FParser.Next;
  end;
  Result := True;
end;

procedure TIFPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
begin
  WriteDebugData(#4 + IFPS3_mi2s(ProcNo) + IFPS3_mi2s(Length(Proc.Data)) + IFPS3_mi2s(FParser.CurrTokenPos) + IFPS3_mi2s(FParser.Row)+ IFPS3_mi2s(FParser.Col));
end;
procedure TIFPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
var
  I: Longint;
  s, d: string;
begin
  s := #2 + IFPS3_mi2s(ProcNo);
  d := Proc.Decl;
  if GRFW(d) <> '-1' then
  begin
    s := s + 'RESULT'+#1;
  end;
  while Length(d) > 0 do
  begin
    s := s + D1(GRFW(d)) + #1;
    GRFW(d);
  end;
  s := s + #0#3 + IFPS3_mi2s(ProcNo);
  for I := 0 to Proc.ProcVars.Count - 1 do
  begin
    s := s + PIFPSProcVar(Proc.ProcVars[I]).Name + #1;
  end;
  s := s + #0;
  WriteDebugData(s);
end;

procedure TIFPSPascalCompiler.CheckForUnusedVars(Func: TIFPSInternalProcedure);
var
  i: Integer;
  p: PIFPSProcVar;
begin
  for i := 0 to Func.ProcVars.Count -1 do
  begin
    p := Func.ProcVars[I];
    if not p.Used then
    begin
      with MakeHint('', ehVariableNotUsed, p.Name) do
      begin
        FRow := p.DeclareRow;
        FCol := p.DeclareCol;
        FPosition := p.DeclarePos;
      end;
    end;
  end;
  if (not Func.ResultUsed) and (Fw(Func.Decl) <> '-1') then
  begin
      with MakeHint('', ehVariableNotUsed, 'Result') do
      begin
        FRow := Func.DeclareRow;
        FCol := Func.DeclareCol;
        FPosition := Func.DeclarePos;
      end;
  end;
end;

function TIFPSPascalCompiler.ProcIsDuplic(const FunctionName, FunctionDecl, FunctionParamNames: string; const s: string; Func: TIFPSInternalProcedure): Boolean;
var
  i: Longint;
  u: string;
begin
  if s = 'RESULT' then
    Result := True
  else if FunctionName = s then
    Result := True
  else if IsDuplicate(s, [dcVars, dcProcs, dcConsts]) then
    Result := True
  else
  begin
    u := FunctionDecl;
    while Length(u) > 0 do
    begin
      if D1(GRFW(u)) = s then
      begin
        Result := True;
        exit;
      end;
      GRFW(u);
    end;
    u := FunctionParamNames;
    while Pos('|', u) > 0 do
    begin
      if copy(u, 1, Pos('|', u) - 1) = s then
      begin
        Result := True;
        exit;
      end;
      Delete(u, 1, Pos('|', u));
    end;
    if Func = nil then
    begin
      result := False;
      exit;
    end;
    for i := 0 to Func.ProcVars.Count -1 do
    begin
      if s = PIFPSProcVar(Func.ProcVars[I]).Name then
      begin
        Result := True;
        exit;
      end;
    end;
    for i := 0 to Func.FLabels.Count -1 do
    begin
      u := Func.FLabels[I];
      delete(u, 1, 4);
      if u = s then
      begin
        Result := True;
        exit;
      end;
    end;
    Result := False;
  end;
end;
procedure WriteProcVars(Func:TIFPSInternalProcedure; t: TIfList);
var
  l: Longint;
  v: PIFPSProcVar;
begin
  for l := 0 to t.Count - 1 do
  begin
    v := t[l];
    Func.Data := Func.Data  + chr(cm_pt)+ IFPS3_mi2s(v.AType);
  end;
end;



function TIFPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean): Boolean;
var
  FunctionType: TFuncType;
  OriginalName, FunctionName: string;
  FunctionParamNames: string;
  FunctionTempType: Cardinal;
  ParamNo: Cardinal;
  FunctionDecl: string;
  modifier: Char;
  Func: TIFPSInternalProcedure;
  F2: TIFPSProcedure;
  EPos, ECol, ERow: Cardinal;
  pp: TIFPSRegProc;
  pp2: TIFPSExternalProcedure;
  FuncNo, I: Longint;
  Block: TIFPSBlockInfo;

begin
  if FParser.CurrTokenId = CSTII_Procedure then
    FunctionType := ftProc
  else
    FunctionType := ftFunc;
  Func := nil;
  FParser.Next;
  Result := False;
  if FParser.CurrTokenId <> CSTI_Identifier then
  begin
    MakeError('', ecIdentifierExpected, '');
    exit;
  end;
  EPos := FParser.CurrTokenPos;
  ERow := FParser.Row;
  ECol := FParser.Row;
  OriginalName := FParser.OriginalToken;
  FunctionName := FParser.GetToken;
  FuncNo := -1;
  for i := 0 to FProcs.Count -1 do
  begin
    f2 := FProcs[I];
    if (f2.ClassType = TIFPSInternalProcedure) and (TIFPSInternalProcedure(f2).Name = FunctionName) and (TIFPSInternalProcedure(f2).Forwarded) then
    begin
      Func := FProcs[I];
      FuncNo := i;
      Break;
    end;
  end;
  if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then
  begin
    MakeError('', ecDuplicateIdentifier, FunctionName);
    exit;
  end;
  FParser.Next;
  FunctionDecl := '';
  if FParser.CurrTokenId = CSTI_OpenRound then
  begin
    FParser.Next;
    if FParser.CurrTokenId = CSTI_CloseRound then
    begin
      FParser.Next;
    end
    else
    begin
      if FunctionType = ftFunc then
        ParamNo := 1
      else
        ParamNo := 0;
      while True do
      begin
        if FParser.CurrTokenId = CSTII_Var then
        begin
          modifier := '!';
          FParser.Next;
        end
        else
          modifier := '@';
        if FParser.CurrTokenId <> CSTI_Identifier then
        begin
          MakeError('', ecIdentifierExpected, '');
          exit;
        end;
        if ProcIsDuplic(FunctionName, FunctionDecl, FunctionParamNames, FParser.GetToken, Func) then
        begin
          MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
          exit;
        end;
        FunctionParamNames := FParser.GetToken + '|';
        if @FOnUseVariable <> nil then
        begin
          FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
        end;
        inc(ParamNo);
        FParser.Next;
        while FParser.CurrTokenId = CSTI_Comma do
        begin
          FParser.Next;
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
        if ProcIsDuplic(FunctionName, FunctionDecl, FunctionParamNames, FParser.GetToken, Func) then
          begin
            MakeError('', ecDuplicateIdentifier, '');
            exit;
          end;
          if @FOnUseVariable <> nil then
          begin
            FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
          end;
          inc(ParamNo);
          FunctionParamNames := FunctionParamNames + FParser.GetToken +
            '|';
          FParser.Next;
        end;
        if FParser.CurrTokenId <> CSTI_Colon then
        begin
          MakeError('', ecColonExpected, '');
          exit;
        end;
        FParser.Next;
        FunctionTempType := at2ut(ReadType('', FParser));
        if FunctionTempType = InvalidVal then
        begin
          exit;
        end;
        while Pos('|', FunctionParamNames) > 0 do
        begin
          FunctionDecl := FunctionDecl + ' ' + modifier +
            copy(FunctionParamNames, 1, Pos('|', FunctionParamNames) - 1)
            + ' '
            + inttostr(Longint(FunctionTempType));
          Delete(FunctionParamNames, 1, Pos('|', FunctionParamNames));
        end;
        if FParser.CurrTokenId = CSTI_CloseRound then
          break;
        if FParser.CurrTokenId <> CSTI_Semicolon then
        begin
          MakeError('', ecSemicolonExpected, '');
          exit;
        end;
        FParser.Next;
      end;
      FParser.Next;
    end;
  end;
  if FunctionType = ftFunc then
  begin
    if FParser.CurrTokenId <> CSTI_Colon then
    begin
      MakeError('', ecColonExpected, '');
      exit;
    end;
    FParser.Next;
    FunctionTempType := at2ut(ReadType('', FParser));
    if FunctionTempType = InvalidVal then
      exit;
    FunctionDecl := inttostr(Longint(FunctionTempType)) + FunctionDecl;
  end
  else
    FunctionDecl := '-1' + FunctionDecl;
  if FParser.CurrTokenId <> CSTI_Semicolon then
  begin
    MakeError('', ecSemicolonExpected, '');
    exit;
  end;
  FParser.Next;
  if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
  begin
    FParser.Next;
    if FParser.CurrTokenID <> CSTI_String then
    begin
      MakeError('', ecStringExpected, '');
      exit;
    end;
    FunctionParamNames := FParser.GetToken;
    FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
    FParser.Next;
    if FParser.CurrTokenID <> CSTI_Semicolon then
    begin
      MakeError('', ecSemicolonExpected, '');
      exit;
    end;
    FParser.Next;
    if @FOnExternalProc = nil then
    begin
      MakeError('', ecSemicolonExpected, '');
      exit;
    end;
    pp := FOnExternalProc(Self, FunctionName, FunctionDecl, FunctionParamNames);
    if pp = nil then
    begin
      MakeError('', ecCustomError, '');
      exit;
    end;
    pp2 := TIFPSExternalProcedure.Create;
    pp2.RegProc := pp;
    FProcs.Add(pp2);
    FRegProcs.Add(pp);
    Result := True;
    Exit;
  end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then
  begin
    if Func <> nil then
    begin
      MakeError('', ecBeginExpected, '');
      exit;
    end;
    if not AlwaysForward then
    begin
      FParser.Next;
      if FParser.CurrTokenID  <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        Exit;
      end;
      FParser.Next;
    end;
    Func := NewProc(OriginalName, FunctionName);
    Func.Forwarded := True;
    Func.FDeclarePos := EPos;
    Func.FDeclareRow := ERow;
    Func.FDeclarePos := ECol;
    Func.Decl := FunctionDecl;
    Result := True;
    exit;
  end;
  if (Func = nil) then
  begin
    Func := NewProc(OriginalName, FunctionName);
    Func.Decl := FunctionDecl;
    Func.FDeclarePos := EPos;
    Func.FDeclareRow := ERow;
    Func.FDeclarePos := ECol;
    FuncNo := FProcs.Count -1;
  end else begin
    if FunctionDecl <> Func.Decl then
    begin
      MakeError('', ecForwardParameterMismatch, '');
      Result := false;
      exit;
    end;
    Func.Forwarded := False;
  end;
  if FParser.CurrTokenID = CSTII_Export then
  begin
    FParser.Next;
    if FParser.CurrTokenID <> CSTI_Semicolon then
    begin
      MakeError('', ecSemicolonExpected, '');
      exit;
    end;
    FParser.Next;
    Func.FExport := etExportName;
  end;
  while FParser.CurrTokenId <> CSTII_Begin do
  begin
    if FParser.CurrTokenId = CSTII_Var then
    begin
      if not DoVarBlock(Func) then
        exit;
    end else if FParser.CurrTokenId = CSTII_Label then
    begin
      if not ProcessLabel(Func) then
        Exit;
    end else
    begin
      MakeError('', ecBeginExpected, '');
      exit;
    end;
  end;
  Debug_WriteParams(FuncNo, Func);
  WriteProcVars(Func, Func.ProcVars);
  Block := TIFPSBlockInfo.Create(FGlobalBlock);
  Block.SubType := tProcBegin;
  Block.ProcNo := FuncNo;
  Block.Proc := Func;
  if not ProcessSub(Block) then
  begin
    Block.Free;
    exit;
  end;
  Block.Free;
  CheckForUnusedVars(Func);
  ProcessLabelForwards(Func);
  Result := True;
end;

function TIFPSPascalCompiler.DoTypeBlock(FParser: TIfPascalParser): Boolean;
var
  VOrg,VName: string;
begin
  Result := False;
  FParser.Next;
  if FParser.CurrTokenId <> CSTI_Identifier then
  begin
    MakeError('', ecIdentifierExpected, '');
    exit;
  end;
  repeat
    VName := FParser.GetToken;
    VOrg := FParser.OriginalToken;
    if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then
    begin
      MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
      exit;
    end;

    FParser.Next;
    if FParser.CurrTokenId <> CSTI_Equal then
    begin
      MakeError('', ecIsExpected, '');
      exit;
    end;
    FParser.Next;
    if ReadType(VOrg, FParser) = InvalidVal then
    begin
      Exit;
    end;
    if FParser.CurrTokenID <> CSTI_Semicolon then
    begin
      MakeError('', ecSemicolonExpected, '');
      Exit;
    end;
    FParser.Next;
  until FParser.CurrTokenId <> CSTI_Identifier;
  Result := True;
end;

procedure TIFPSPascalCompiler.Debug_WriteLine(BlockInfo: TIFPSBlockInfo);
var
  b: Boolean;
begin
  if @FOnWriteLine <> nil then begin
    b := FOnWriteLine(Self, FParser.CurrTokenPos);
  end else
    b := true;
  if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
end;


function TIFPSPascalCompiler.ProcessSub(BlockInfo: TIFPSBlockInfo): Boolean;

  procedure WriteCommand(b: Byte);
  begin
    BlockInfo.Proc.Data := BlockInfo.Proc.Data + Char(b);
  end;

  procedure WriteByte(b: Byte);
  begin
    BlockInfo.Proc.Data := BlockInfo.Proc.Data + Char(b);
  end;

  procedure WriteData(const Data; Len: Longint);
  begin
    SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len);
    Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len);
  end;

  function ReadReal(const s: string): PIfRVariant;
  var
    C: Integer;
  begin
    New(Result);
    InitializeVariant(FUsedTypes, Result, GetType(True, btExtended), btExtended);
    Val(s, Result^.textended, C);
  end;

  function ReadString: PIfRVariant;
  {$IFNDEF IFPS3_NOWIDESTRING}var wchar: Boolean;{$ENDIF}

    function ParseString: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};
    var
      temp3: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};

      function ChrToStr(s: string): {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF};
      var
        w: Longint;
      begin
        Delete(s, 1, 1); {First char : #}
        w := StrToInt(s);
        Result := {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w);
        {$IFNDEF IFPS3_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
      end;

      function PString(s: string): string;
      begin
        s := copy(s, 2, Length(s) - 2);
        PString := s;
      end;
    begin
      temp3 := '';
      while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
      begin
        if FParser.CurrTokenId = CSTI_String then
        begin
          temp3 := temp3 + PString(FParser.GetToken);
          FParser.Next;
          if FParser.CurrTokenId = CSTI_String then
            temp3 := temp3 + #39;
        end {if}
        else
        begin
          temp3 := temp3 + ChrToStr(FParser.GetToken);
          FParser.Next;
        end; {else if}
      end; {while}
      ParseString := temp3;
    end;
  {$IFNDEF IFPS3_NOWIDESTRING}
  var
    w: widestring;
    s: string;
  begin
    w := ParseString;
    if wchar then
    begin
      New(Result);
      if Length(w) = 1 then
      begin
        InitializeVariant(FUsedTypes, Result, GetType(True, btwidechar), btwidechar);
        Result^.twidechar := w[1];
      end else begin
        InitializeVariant(FUsedTypes, Result, GetType(True, btwidestring), btwidestring);
        tbtwidestring(Result^.twidestring) := w;
       end;
    end else begin
      s := w;
      New(Result);
      if Length(s) = 1 then
      begin
        InitializeVariant(FUsedTypes, Result, GetType(True, btchar), btchar);
        Result^.tchar := s[1];
      end else begin
        InitializeVariant(FUsedTypes, Result, GetType(True, btstring), btstring);
        tbtstring(Result^.tstring) := s;
      end;
    end;
  end;
  {$ELSE}
  var
    s: string;
  begin
    s := ParseString;
    New(Result);
    if Length(s) = 1 then
    begin
      InitializeVariant(FUsedTypes, Result, GetType(true, btchar), btchar);
      Result^.tchar := s[1];
    end else begin
      InitializeVariant(FUsedTypes, Result, GetType(true, btstring), btstring);
      tbtstring(Result^.tstring) := s;
    end;
  end;
  {$ENDIF}


  function ReadInteger(const s: string): PIfRVariant;
  {$IFNDEF IFPS3_NOINT64}
  var
    R: Int64;
  begin
    r := StrToInt64Def(s, 0);
    New(Result);
    if (r >= Low(Integer)) and (r <= High(Integer)) then
    begin
      InitializeVariant(FUsedTypes, Result, GetType(True, bts32), bts32);
      Result^.ts32 := r;
    end else if (r <= $FFFFFFFF) then
    begin
      InitializeVariant(FUsedTypes, Result, GetType(True, btu32), btu32);
      Result^.tu32 := r;
    end else
    begin
      InitializeVariant(FUsedTypes, Result, GetType(True, bts64), bts64);
      Result^.ts64 := r;
    end;
  end;
  {$ELSE}
  var
   r: Longint;
  begin
    r := StrToIntDef(s, 0);
    New(Result);
    InitializeVariant(FUsedTypes, Result, GetType(true, bts32), bts32);
    Result^.ts32 := r;
  end;
  {$ENDIF}

  procedure WriteLong(l: Cardinal);
  begin
    WriteData(l, 4);
  end;

  procedure WriteVariant(p: PIfRVariant);
  var
    px: TIFPSType;
  begin
    WriteLong(p^.FType);
    case p.BaseType of
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString:
      begin
        WriteLong(Length(tbtWideString(p^.twidestring)));
        WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
      end;
    btWideChar: WriteData(p^.twidechar, 2);
    {$ENDIF}
    btSingle: WriteData(p^.tsingle, sizeof(tbtSingle));
    btDouble: WriteData(p^.tsingle, sizeof(tbtDouble));
    btExtended: WriteData(p^.tsingle, sizeof(tbtExtended));
    btChar: WriteData(p^.tchar, 1);
    btSet:
      begin
        WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
      end;
    btString:
      begin
        WriteLong(Length(tbtString(p^.tstring)));
        WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
      end;
    btenum:
      begin
        px := FUsedTypes[p^.FType];
        if TIFPSEnumType(px).HighValue <=256 then
          WriteData(p^.tu32, 1)
        else if TIFPSEnumType(px).HighValue <=65536 then
          WriteData(p^.tu32, 2)
        else
          WriteData(p^.tu32, 4);
      end;
    bts8,btu8: WriteData(p^.tu8, 1);
    bts16,btu16: WriteData(p^.tu16, 2);
    bts32,btu32: WriteData(p^.tu32, 4);
    {$IFNDEF IFPS3_NOINT64}
    bts64: WriteData(p^.ts64, 8);
    {$ENDIF}
    end;
  end;

  function GetParamType(I: Longint): Cardinal;
  var
    u, n: string;
  begin
    u := BlockInfo.Proc.Decl;
    n := GRFW(u);
    if n <> '-1' then
    begin
      if I = 0 then
      begin
        Result := StrToIntDef(n, -1);
        exit;
      end else Dec(I);
    end;
    while I > 0 do
    begin
      GRFW(u);
      GRFW(u);
      Dec(I);
    end;
    GRFW(u);
    Result := StrToIntDef(GRFW(u), -1);
  end;

  function AllocStackReg2(MType: Cardinal): TIFPSValue;
  var
    x: TIFPSProcVar;
  begin
    x := TIFPSProcVar.Create;
    x.DeclarePos := FParser.CurrTokenPos;
    x.DeclareRow := FParser.Row;
    x.DeclareCol := FParser.Col;
    x.Name := '';
    x.AType := MType;
    BlockInfo.Proc.ProcVars.Add(x);
    Result := TIFPSValueAllocatedStackVar.Create;
    Result.SetParserPos(FParser);
    TIFPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc;
    with TIFPSValueAllocatedStackVar(Result) do
    begin
      LocalVarNo := proc.ProcVars.Count -1;
    end;
  end;

  function AllocStackReg(MType: Cardinal): TIFPSValue;
  begin
    Result := AllocStackReg2(MType);
    WriteCommand(Cm_Pt);
    WriteLong(MType);
  end;

  function WriteCalculation(InData, OutReg: TIFPSValue): Boolean; forward;
  function GetTypeNo(p: TIFPSValue): Cardinal; forward;
  function PreWriteOutRec(var X: TIFPSValue; FArrType: Cardinal): Boolean; forward;
  function WriteOutRec(x: TIFPSValue; AllowData: Boolean): Boolean; forward;
  procedure AfterWriteOutRec(var x: TIFPSValue); forward;
  function checkCompatType2(p1, p2: TIFPSType; Cast: Boolean): Boolean;
  begin
    if
      ((p1.BaseType = btProcPtr) and (p2 = p1)) or
      (p1.BaseType = btVariant) or
      (p2.BaseType = btVariant) or
      (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or
      (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or
      (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
      (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or
      ((p1.BaseType = btArray) and (p2.BaseType = btArray) and CheckCompatType2(FUsedTypes[TIFPSArrayType(p1).ArrayTypeNo], FUsedTypes[TIFPSArrayType(p2).ArrayTypeNo], False)) or
      ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
      ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or
      {$IFNDEF IFPS3_NOWIDESTRING}
      ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or
      ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or
      ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or
      ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or
      ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
      ((p1.BaseType = btWidestring) and (p2.BaseType = btWidestring)) or
      (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)) or
      (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or
      (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or
      {$ENDIF}
      ((p1.BaseType = btRecord) and (p2.BaseType = btrecord)) or
      ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or
      (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or
      (Cast and (p2.baseType = btEnum) and IsIntType(P1.BaseType))
      then
      Result := True
    else if ((p1.BaseType = btclass) and (p2.BaseType = btClass)) then
    begin
      Result := TIFPSClassType(p1).ClassHelper.IsCompatibleWith(TIFPSClassType(p2).ClassHelper);
    end else

      Result := False;
  end;

  function CheckCompatType(V1, v2: TIFPSValue): Boolean;
  var
    p1, P2: TIFPSType;
  begin
    p1 := FUsedTypes[GetTypeNo(V1)];
    P2 := FUsedTypes[GetTypeNo(v2)];
    if (p1 = nil) or (p2 = nil) then
    begin
      if ((p1 <> nil) and (p1.ClassType = TIFPSClassType) and (v2.ClassType = TIFPSValueNil)) or
        ((p2 <> nil) and (p2.ClassType = TIFPSClassType) and (v1.ClassType = TIFPSValueNil)) then
      begin
        Result := True;
        exit;
      end else
      if (v1.ClassType = TIFPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then
      begin
        Result := CheckCompatProc(p2, TIFPSValueProcPtr(v1).ProcPtr);
        exit;
      end else if (v2.ClassType = TIFPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then
      begin
        Result := CheckCompatProc(p1, TIFPSValueProcPtr(v2).ProcPtr);
        exit;
      end;
      Result := False;
    end else
    if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TIFPSValueArray) then
    begin
      Result := True;
    end else
      Result := CheckCompatType2(p1, p2, False);
  end;

  function ProcessFunction(ProcCall: TIFPSValueProc; ResultRegister: TIFPSValue): Boolean; forward;
  function ProcessFunction2(ProcNo: Cardinal; Par: TIFPSParameters; ResultReg: TIFPSValue): Boolean;
  var
    Temp: TIFPSValueProcNo;
  begin
    Temp := TIFPSValueProcNo.Create;
    Temp.Parameters := Par;
    Temp.ProcNo := ProcNo;
    if TObject(FProcs[ProcNo]).ClassType = TIFPSInternalProcedure then
      Temp.ResultType := STrToInt(Fw(TIFPSInternalProcedure(FProcs[ProcNo]).Decl))
    else
      Temp.ResultType := STrToInt(Fw(TIFPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl));
    Result := ProcessFunction(Temp, ResultReg);
    Temp.Parameters := nil;
    Temp.Free;
  end;

  function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TIFPSValue): Boolean;
  var
    Procno: Cardinal;
    PF: TIFPSType;
    Par: TIFPSParameters;
  begin
    Pf := FUsedTypes[GetTypeNo(IVar)];
    if not (Ivar is TIFPSValueVar) then
    begin
      with MakeError('', ecTypeMismatch, '') do
      begin
        FPosition := nilPos;
        FRow := NilRow;
        FCol := nilCol;
      end;
      Result := False;
      exit;
    end;
    if (pf.BaseType = btString) or (pf.BaseType = btPChar) then
    begin
      if not PreWriteOutRec(iVar, InvalidVal) then
      begin
        Result := false;
        exit;
      end;
      WriteCommand(CM_A);
      WriteOutRec(ivar, False);
      WriteByte(1);
      WriteLong(GetTypeNo(IVar));
      WriteLong(0); //empty string
      AfterWriteOutRec(ivar);
      Result := True;
    end else if pf.BaseType = btClass then
    begin
      if not TIFPSClassType(pf).ClassHelper.SetNil(ProcNo) then
      begin
        with MakeError('', ecTypeMismatch, '') do
        begin
          FPosition := nilPos;
          FRow := NilRow;
          FCol := nilCol;
        end;
        Result := False;
        exit;
      end;
      Par := TIFPSParameters.Create;
      with par.Add do
      begin
        Val := IVar;
        ExpectedType := GetTypeNo(ivar);
        ParamMode := pmInOut;
      end;
      Result := ProcessFunction2(ProcNo, Par, nil);

      Par[0].Val := nil; // don't free IVAR

      Par.Free;
    end else
    begin
      with MakeError('', ecTypeMismatch, '') do
      begin
        FPosition := nilPos;
        FRow := NilRow;
        FCol := nilCol;
      end;
      Result := False;
    end;
  end;
  function DoBinCalc(BVal: TIFPSBinValueOp; Output: TIFPSValue): Boolean;
  var
    tmpp, tmpc: TIFPSValue;
    proc: Cardinal;

  begin
    if BVal.Operator >= otGreaterEqual then
    begin
      if BVal.FVal1.ClassType = TIFPSValueNil then
      begin
        tmpp := AllocStackReg(GetTypeNo(BVal.FVal2));
        if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then
        begin
          tmpp.Free;
          Result := False;
          exit;
        end;
        tmpc := TIFPSValueReplace.Create;
        with TIFPSValueReplace(tmpc) do
        begin
          OldValue := BVal.FVal1;
          NewValue := tmpp;
        end;
        BVal.FVal1 := tmpc;
      end;
      if BVal.FVal2.ClassType = TIFPSValueNil then
      begin
        tmpp := AllocStackReg(GetTypeNo(BVal.FVal1));
        if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then
        begin
          tmpp.Free;;
          Result := False;
          exit;
        end;
        tmpc := TIFPSValueReplace.Create;
        with TIFPSValueReplace(tmpc) do
        begin
          OldValue := BVal.FVal2;
          NewValue := tmpp;
        end;
        BVal.FVal2 := tmpc;
      end;
      if TIFPSType(FUsedTypes[GetTypeNo(BVal.FVal1)]).BaseType = btClass then
      begin
        if not TIFPSClassType(FUsedTypes[GetTypeNo(BVal.FVal1)]).ClassHelper.CompareClass(GetTypeNo(Bval.FVal2), Proc) then
        begin
          Result := False;
          exit;
        end;
        tmpp := TIFPSValueProcNo.Create;
        with TIFPSValueProcNo(tmpp) do
        begin
          ResultType := at2ut(FBooleanType);
          Parameters := TIFPSParameters.Create;
          ProcNo := proc;
          Pos := BVal.Pos;
          Col := BVal.Col;
          Row := BVal.Row;
          with parameters.Add do
          begin
            Val := BVal.FVal1;
            ExpectedType := GetTypeNo(Val);
          end;
          with parameters.Add do
          begin
            Val := BVal.FVal2;
            ExpectedType := GetTypeNo(Val);
          end;
        end;
        if Bval.Operator = otNotEqual then
        begin
          tmpc := TIFPSUnValueOp.Create;
          TIFPSUnValueOp(tmpc).Operator := otNot;
          TIFPSUnValueOp(tmpc).Val1 := tmpp;
          TIFPSUnValueOp(tmpc).aType := GetTypeNo(tmpp);
        end else tmpc := tmpp;
        Result := WriteCalculation(tmpc, Output);
        with TIFPSValueProcNo(tmpp) do
        begin
          Parameters[0].Val := nil;
          Parameters[1].Val := nil;
        end;
        tmpc.Free;
        if BVal.Val1.ClassType = TIFPSValueReplace then
        begin
          tmpp := TIFPSValueReplace(BVal.Val1).OldValue;
          BVal.Val1.Free;
          BVal.Val1 := tmpp;
        end;
        if BVal.Val2.ClassType = TIFPSValueReplace then
        begin
          tmpp := TIFPSValueReplace(BVal.Val2).OldValue;
          BVal.Val2.Free;
          BVal.Val2 := tmpp;
        end;
        exit;
      end;
      if not (PreWriteOutRec(Output, InvalidVal) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BVal.FVal1))) then
      begin
        Result := False;
        exit;
      end;
      Writecommand(CM_CO);
      case BVal.Operator of
        otGreaterEqual: WriteByte(0);
        otLessEqual: WriteByte(1);
        otGreater: WriteByte(2);
        otLess: WriteByte(3);
        otEqual: WriteByte(5);
        otNotEqual: WriteByte(4);
        otIn: WriteByte(6); 
      end;

      if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then
      begin
        Result := False;
        exit;
      end;
      AfterWriteOutrec(BVal.FVal1);
      AfterWriteOutrec(BVal.FVal2);
      AfterWriteOutrec(Output);
      if BVal.Val1.ClassType = TIFPSValueReplace then
      begin
        tmpp := TIFPSValueReplace(BVal.Val1).OldValue;
        BVal.Val1.Free;
        BVal.Val1 := tmpp;
      end;
      if BVal.Val2.ClassType = TIFPSValueReplace then
      begin
        tmpp := TIFPSValueReplace(BVal.Val2).OldValue;
        BVal.Val2.Free;
        BVal.Val2 := tmpp;
      end;
    end else begin
      if not PreWriteOutRec(Output, InvalidVal) then
      begin
        Result := False;
        exit;
      end;
      if not SameReg(Output, BVal.Val1) then
      begin
        if not WriteCalculation(BVal.FVal1, Output) then
        begin
          Result := False;
          exit;
        end;
      end;
      if not PreWriteOutrec(BVal.FVal2, GetTypeNo(Output)) then
      begin
        Result := False;
        exit;
      end;
      WriteCommand(Cm_CA);
      WriteByte(Ord(BVal.Operator));
      if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
      begin
        Result := False;
        exit;
      end;
      AfterWriteOutRec(BVal.FVal2);
      AfterWriteOutRec(Output);
    end;
    Result := True;
  end;

  function DoUnCalc(Val: TIFPSUnValueOp; Output: TIFPSValue): Boolean;
  begin
    if not PreWriteOutRec(Output, InvalidVal) then
    begin
      Result := False;
      exit;
    end;
    case Val.Operator of
      otNot:
        begin
          if not SameReg(Val.FVal1, Output) then
          begin
            if not WriteCalculation(Val.FVal1, Output) then
            begin
              Result := False;
              exit;
            end;
          end;
          if GetTypeNo(Val) = AT2UT(FBooleanType) then
            WriteCommand(cm_bn)
          else
            WriteCommand(cm_in);
          if not WriteOutRec(Output, True) then
          begin
            Result := False;
            exit;
          end;
        end;
      otMinus:
        begin
          if not SameReg(Val.FVal1, Output) then
          begin
            if not WriteCalculation(Val.FVal1, Output) then
            begin
              Result := False;
              exit;
            end;
          end;
          WriteCommand(cm_vm);
          if not WriteOutRec(Output, True) then
          begin
            Result := False;
            exit;
          end;
        end;
      otCast:
        begin
          if not PreWriteOutRec(Val.FVal1, GetTypeNo(Output)) then
          begin
            Result := False;
            exit;
          end; 
          WriteCommand(CM_A);
          if not (WriteOutRec(Output, False) and WriteOutRec(Val.FVal1, True)) then
          begin
            Result := false;
            exit;
          end;
          AfterWriteOutRec(val.Fval1);
          AfterWriteOutRec(Output);
        end;
      {else donothing}
    end;
    AfterWriteOutRec(Output);
    Result := True;
  end;


  function GetAddress(Val: TIFPSValue): Cardinal;
  begin
    if Val.ClassType = TIFPSValueGlobalVar then
      Result := TIFPSValueGlobalVar(val).GlobalVarNo
    else if Val.ClassType = TIFPSValueLocalVar then
      Result := IFPSAddrStackStart + TIFPSValueLocalVar(val).LocalVarNo + 1
    else if Val.ClassType = TIFPSValueParamVar then
      Result := IFPSAddrStackStart - TIFPSValueParamVar(val).ParamNo -1
    else if Val.ClassType =  TIFPSValueAllocatedStackVar then
      Result := IFPSAddrStackStart + TIFPSValueAllocatedStackVar(val).LocalVarNo + 1
    else
      Result := InvalidVal;
  end;

  function PreWriteOutRec(var X: TIFPSValue; FArrType: Cardinal): Boolean;
  var
    rr: TIFPSSubItem;
    tmpp,
      tmpc: TIFPSValue;
    i: Longint;
    function MakeSet(SetType: TIFPSSetType; arr: TIFPSValueArray): Boolean;
    var
      c, i: Longint;
      dataval: TIFPSValueData;
      mType: TIFPSType;
    begin
      Result := True;
      dataval := TIFPSValueData.Create;
      dataval.Data := NewVariant(FUsedTypes, FarrType, btSet);
      for i := 0 to arr.count -1 do
      begin
        mType := FUsedTypes[GetTypeNo(arr.Item[i])];
        if mType <> SetType.SetType then
        begin
          with MakeError('', ecTypeMismatch, '') do
          begin
            FCol := arr.item[i].Col;
            FRow := arr.item[i].Row;
            FPosition := arr.item[i].Pos;
          end;
          DataVal.Free;
          Result := False;
          exit;
        end;
        if arr.Item[i] is TIFPSValueData then
        begin
          c := GetInt(TIFPSValueData(arr.Item[i]).Data, Result);
          if not Result then
          begin
            dataval.Free;
            exit;
          end;
          Set_MakeMember(c, dataval.Data.tstring);
        end else
        begin
          DataVal.Free;
          MakeError('', ecTypeMismatch, '');
          Result := False;
          exit;
        end;
      end;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        OldValue := x;
        NewValue := dataval;
        PreWriteAllocated := True;
      end;
      x := tmpc;
    end;
  begin
    Result := True;
    if x.ClassType = TIFPSValueReplace then
    begin
      if TIFPSValueReplace(x).PreWriteAllocated then
      begin
        inc(TIFPSValueReplace(x).FReplaceTimes);
      end;
    end else
    if x.ClassType = TIFPSValueProcPtr then
    begin
      if FArrType = InvalidVal then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := False;
        Exit;
      end;
      tmpp := TIFPSValueData.Create;
      TIFPSValueData(tmpp).Data := NewVariant(FUsedTypes, FArrType, btU32);
      TIFPSValueData(tmpp).Data.tu32 := TIFPSValueProcPtr(x).ProcPtr;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else
    if x.ClassType = TIFPSValueNil then
    begin
      if FArrType = InvalidVal then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := False;
        Exit;
      end;
      tmpp := AllocStackReg(FArrType);
      if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then
      begin
        tmpp.Free;
        Result := False;
        exit;
      end;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else
    if x.ClassType = TIFPSValueArray then
    begin
      if FArrType = InvalidVal then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := False;
        Exit;
      end;
      if TIFPSType(FUsedTypes[FArrType]).BaseType = btSet then
      begin
        Result := MakeSet(TIFPSSetType(FUsedTypes[FArrType]), TIFPSValueArray(x));
        exit;
      end;

      tmpp := AllocStackReg(FArrType);
      tmpc := AllocStackReg(GetType(True, bts32));
      WriteCommand(CM_A);
      WriteOutrec(tmpc, False);
      WriteByte(1);
      WriteLong(GetType(True, bts32));
      WriteLong(TIFPSValueArray(x).Count);
      WriteCommand(CM_PV);
      WriteOutrec(tmpp, False);
      WriteCommand(CM_C);
      WriteLong(FindProc('SETARRAYLENGTH'));
      WriteCommand(CM_PO);
      tmpc.Free;
      rr := TIFPSSubNumber.Create;
      rr.aType := TIFPSArrayType(FUsedTypes[FArrType]).ArrayTypeNo;
      TIFPSValueVar(tmpp).RecAdd(rr);
      for i := 0 to TIFPSValueArray(x).Count -1 do
      begin
        TIFPSSubNumber(rr).SubNo := i;
        if not WriteCalculation(TIFPSValueArray(x).Item[i], tmpp) then
        begin
          tmpp.Free;
          Result := False;
          Exit;
        end;
      end;
      TIFPSValueVar(tmpp).RecDelete(0);
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else if (x.ClassType = TIFPSUnValueOp) then
    begin
      tmpp := AllocStackReg(GetTypeNo(x));
      if not DoUnCalc(TIFPSUnValueOp(x), tmpp) then
      begin
        Result := False;
        exit;
      end;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else if (x.ClassType = TIFPSBinValueOp) then
    begin
      tmpp := AllocStackReg(GetTypeNo(x));
      if not DoBinCalc(TIFPSBinValueOp(x), tmpp) then
      begin
        tmpp.Free;
        Result := False;
        exit;
      end;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else if x is TIFPSValueProc then
    begin
      tmpp := AllocStackReg(TIFPSValueProc(x).ResultType);
      if not WriteCalculation(x, tmpp) then
      begin
        tmpp.Free;
        Result := False;
        exit;
      end;
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        PreWriteAllocated := True;
        OldValue := x;
        NewValue := tmpp;
      end;
      x := tmpc;
    end else if (x is TIFPSValueVar) and (TIFPSValueVar(x).RecCount <> 0) then
    begin
      if  TIFPSValueVar(x).RecCount = 1 then
      begin
        rr := TIFPSValueVar(x).RecItem[0];
        if rr.ClassType <> TIFPSSubValue then
          exit; // there is no need pre-calculate anything
        if (TIFPSSubValue(rr).SubNo is TIFPSValueVar) and (TIFPSValueVar(TIFPSSubValue(rr).SubNo).RecCount = 0) then
          exit;
      end; //if
      tmpp := AllocStackReg(GetType(True, btPointer));
      WriteCommand(cm_sp);
      WriteOutRec(tmpp, True);
      WriteByte(0);
      WriteLong(GetAddress(x));
      for i := 0 to TIFPSValueVar(x).RecCount - 1 do
      begin
        rr := TIFPSValueVar(x).RecItem[I];
        if rr.ClassType = TIFPSSubNumber then
        begin
          WriteCommand(cm_sp);
          WriteOutRec(tmpp, false);
          WriteByte(2);
          WriteLong(GetAddress(tmpp));
          WriteLong(TIFPSSubNumber(rr).SubNo);
        end else begin // if rr.classtype = TIFPSSubValue then begin
          tmpc := AllocStackReg(GetType(True, btU32));
          if not WriteCalculation(TIFPSSubValue(rr).SubNo, tmpc) then
          begin
            tmpc.Free;
            tmpp.Free;
            Result := False;
            exit;
          end; //if
          WriteCommand(cm_sp);
          WriteOutRec(tmpp, false);
          WriteByte(3);
          WriteLong(GetAddress(tmpp));
          WriteLong(GetAddress(tmpc));
          tmpc.Free;
        end;
      end; // for
      tmpc := TIFPSValueReplace.Create;
      with TIFPSValueReplace(tmpc) do
      begin
        OldValue := x;
        NewValue := tmpp;
        PreWriteAllocated := True;
      end;
      x := tmpc;
    end;

  end;

  procedure AfterWriteOutRec(var x: TIFPSValue);
  var
    tmp: TIFPSValue;
  begin
    if (x.ClassType = TIFPSValueReplace) and (TIFPSValueReplace(x).PreWriteAllocated) then
    begin
      Dec(TIFPSValueReplace(x).FReplaceTimes);
      if TIFPSValueReplace(x).ReplaceTimes = 0 then
      begin
        tmp := TIFPSValueReplace(x).OldValue;
        x.Free;
        x := tmp;
      end;
    end;
  end; //afterwriteoutrec

  function WriteOutRec(x: TIFPSValue; AllowData: Boolean): Boolean;
  var
    rr: TIFPSSubItem;
  begin
    Result := True;
    if x.ClassType = TIFPSValueReplace then
      Result := WriteOutRec(TIFPSValueReplace(x).NewValue, AllowData)
    else if x is TIFPSValueVar then
    begin
      if TIFPSValueVar(x).RecCount = 0 then
      begin
        WriteByte(0);
        WriteLong(GetAddress(x));
      end
      else
      begin
        rr := TIFPSValueVar(x).RecItem[0];
        if rr.ClassType = TIFPSSubNumber then
        begin
          WriteByte(2);
          WriteLong(GetAddress(x));
          WriteLong(TIFPSSubNumber(rr).SubNo);
        end
        else
        begin
          WriteByte(3);
          WriteLong(GetAddress(x));
          WriteLong(GetAddress(TIFPSSubValue(rr).SubNo));
        end;
      end;
    end else if x.ClassType = TIFPSValueData then
    begin
      if AllowData then
      begin
        WriteByte(1);
        WriteVariant(TIFPSValueData(x).Data)
      end
      else
      begin
        Result := False;
        exit;
      end;
    end else
      Result := False;
  end;

  function GetTypeNo(p: TIFPSValue): Cardinal;
  begin
    if p.ClassType = TIFPSUnValueOp then
      Result := TIFPSUnValueOp(p).aType
    else if p.ClassType = TIFPSBinValueOp then
      Result := TIFPSBinValueOp(p).aType
    else if p.ClassType = TIFPSValueArray then
      Result := at2ut(FindType('TVariantArray'))
    else if p.ClassType = TIFPSValueData then
      Result := TIFPSValueData(p).Data.FType
    else if p is TIFPSValueProc then
      Result := TIFPSValueProc(p).ResultType
    else if (p is TIFPSValueVar) and (TIFPSValueVar(p).RecCount > 0) then
      Result := TIFPSValueVar(p).RecItem[TIFPSValueVar(p).RecCount - 1].aType
    else if p.ClassType = TIFPSValueGlobalVar then
      Result := TIFPSVar(FVars[TIFPSValueGlobalVar(p).GlobalVarNo]).FType
    else if p.ClassType = TIFPSValueParamVar then
      Result := GetParamType(TIFPSValueParamVar(p).ParamNo)
    else if p is TIFPSValueLocalVar then
      Result := TIFPSProcVar(BlockInfo.Proc.ProcVars[TIFPSValueLocalVar(p).LocalVarNo]).AType
    else if p.classtype = TIFPSValueReplace then
      Result := GetTypeNo(TIFPSValueReplace(p).NewValue)
    else
      Result := InvalidVal;
  end;

  function ReadParameters(ProcNo: Cardinal; FSelf: TIFPSValue): TIFPSValue; forward;

  function calc(endOn: TIfPasToken): TIFPSValue; forward;

  function ReadVarParameters(ProcNoVar: TIFPSValue): TIFPSValue; forward;

  function GetIdentifier(const FType: Byte): TIFPSValue;
    {
      FType:
        0 = Anything
        1 = Only variables
        2 = Not constants
    }

    procedure CheckProcCall(var x: TIFPSValue);
    begin
      if FParser.CurrTokenId = CSTI_Dereference then
      begin
        if TIFPSType(FUsedTypes[GetTypeNo(x)]).BaseType <> btProcPtr then
        begin
          MakeError('', ecTypeMismatch, '');
          x.Free;
          x := nil;
          Exit;
        end;
        FParser.Next;
        x := ReadVarParameters(x);
      end;
    end;

    procedure CheckFurther(var x: TIFPSValue; ImplicitPeriod: Boolean);
    var
      t: Cardinal;
      rr: TIFPSSubItem;
      L: Longint;
      u: TIFPSType;
      Param: TIFPSParameter;
      tmp, tmpn: TIFPSValue;
      tmp3: TIFPSValueProcNo;
      tmp2: Boolean;

      function FindSubR(const n: string; FType: TIFPSType): Cardinal;
      var
        h, I: Longint;
        rvv: PIFPSRecordFieldTypeDef;
      begin
        h := MakeHash(n);
        for I := 0 to TIFPSRecordType(FType).RecValCount - 1 do
        begin
          rvv := TIFPSRecordType(FType).RecVal(I);
          if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then
          begin
            Result := I;
            exit;
          end;
        end;
        Result := InvalidVal;
      end;

    begin
      if not (x is TIFPSValueVar) then
        Exit;
      t := GetTypeNo(x);
      u := FUsedTypes[t];
      while True do
      begin
        if u.BaseType = btClass then exit;
        if FParser.CurrTokenId = CSTI_OpenBlock then
        begin
          if u.BaseType = btString then
          begin
             FParser.Next;
            tmp := Calc(CSTI_CloseBlock);
            if tmp = nil then
            begin
              x.Free;
              x := nil;
              exit;
            end;
            if not IsIntType(TIFPSType(FUSedTypes[GetTypeNo(tmp)]).BaseType) then
            begin
              MakeError('', ecTypeMismatch, '');
              tmp.Free;
              x.Free;
              x := nil;
              exit;
            end;
            FParser.Next;
            if FParser.CurrTokenId = CSTI_Assignment then
            begin
              l := FindProc('STRSET');
              if l = -1 then
              begin
                MakeError('', ecUnknownIdentifier, 'StrSet');
                tmp.Free;
                x.Free;
                x := nil;
                exit;
              end;
              tmp3 := TIFPSValueProcNo.Create;
              tmp3.ResultType := Cardinal(-1);
              tmp3.SetParserPos(FParser);
              tmp3.ProcNo := L;
              tmp3.SetParserPos(FParser);
              tmp3.Parameters := TIFPSParameters.Create;
              param := tmp3.Parameters.Add;
              with tmp3.Parameters.Add do
              begin
                Val := tmp;
                ExpectedType := GetTypeNo(tmp);
              end;
              with tmp3.Parameters.Add do
              begin
                Val := x;
                ExpectedType := GetTypeNo(x);
                ParamMode := pmInOut;
              end;
              x := tmp3;
              FParser.Next;
              tmp := Calc(CSTI_SemiColon);
              if tmp = nil then
              begin
                x.Free;
                x := nil;
                exit;
              end;
              if TIFPSType(FUsedTypes[GetTypeNo(Tmp)]).BaseType <> btChar then
              begin
                x.Free;
                x := nil;
                Tmp.Free;
                MakeError('', ecTypeMismatch, '');
                exit;

              end;
              param.Val := tmp;
              Param.ExpectedType := GetTypeNo(tmp);
            end else begin
              l := FindProc('STRGET');
              if l = -1 then
              begin
                MakeError('', ecUnknownIdentifier, 'StrGet');
                tmp.Free;
                x.Free;
                x := nil;
                exit;
              end;
              tmp3 := TIFPSValueProcNo.Create;
              tmp3.ResultType := GetType(True, btChar);
              tmp3.ProcNo := L;
              tmp3.SetParserPos(FParser);
              tmp3.Parameters := TIFPSParameters.Create;
              with tmp3.Parameters.Add do
              begin
                Val := x;
                ExpectedType := GetTypeNo(x);
                ParamMode := pmInOut;
              end;
              with tmp3.Parameters.Add do
              begin
                Val := tmp;
                ExpectedType := GetTypeNo(tmp);
              end;
              x := tmp3;
            end;
            Break;
          end else if (u.BaseType = btArray) or (u.BaseType = btStaticArray) then
          begin
            FParser.Next;
            tmp := calc(CSTI_CloseBlock);
            if tmp = nil then
            begin
              x.Free;
              x := nil;
              exit;
            end;
            if not IsIntType(TIFPSType(FUSedTypes[GetTypeNo(tmp)]).BaseType) then
            begin
              MakeError('', ecTypeMismatch, '');
              tmp.Free;
              x.Free;
              x := nil;
              exit;
            end;
            if tmp.ClassType = TIFPSValueData then
            begin
              rr := TIFPSSubNumber.Create;
              TIFPSValueVar(x).RecAdd(rr);
              if (u.BaseType = btStaticArray) then
                TIFPSSubNumber(rr).SubNo := Cardinal(GetInt(TIFPSValueData(tmp).Data, tmp2) - TIFPSStaticArrayType(u).StartOffset)
              else
                TIFPSSubNumber(rr).SubNo := GetUInt(TIFPSValueData(tmp).Data, tmp2);
              tmp.Free;
              rr.aType := TIFPSArrayType(u).ArrayTypeNo;
              u := FUsedTypes[rr.aType];
            end
            else
            begin
              if (u.BaseType = btStaticArray) then
              begin
                tmpn := TIFPSBinValueOp.Create;
                TIFPSBinValueOp(tmpn).Operator := otSub;
                TIFPSBinValueOp(tmpn).Val1 := tmp;
                tmp := TIFPSValueData.Create;
                TIFPSValueData(tmp).Data := NewVariant(FUsedTypes, GetType(True, btS32), bts32);
                TIFPSValueData(tmp).Data.ts32 := TIFPSStaticArrayType(u).StartOffset;
                TIFPSBinValueOp(tmpn).Val2 := tmp;
                TIFPSBinValueOp(tmpn).aType := GetType(True, btS32);
                tmp := tmpn;
              end;
              rr := TIFPSSubValue.Create;
              TIFPSValueVar(x).recAdd(rr);
              TIFPSSubValue(rr).SubNo := tmp;
              rr.aType := TIFPSArrayType(u).ArrayTypeNo;
              u := FUsedTypes[rr.aType];
            end;
            if FParser.CurrTokenId <> CSTI_CloseBlock then
            begin
              MakeError('', ecCloseBlockExpected, '');
              x.Free;
              x := nil;
              exit;
            end;
            Fparser.Next;
          end else begin
            MakeError('', ecSemicolonExpected, '');
            x.Free;
            x := nil;
            exit;
          end;
        end
        else if (FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod) then
        begin
          if not ImplicitPeriod then
            FParser.Next;
          if u.BaseType = btRecord then
          begin
            t := FindSubR(FParser.GetToken, u);
            if t = InvalidVal then
            begin
              if ImplicitPeriod then exit;
              MakeError('', ecUnknownIdentifier, FParser.GetToken);
              x.Free;
              x := nil;
              exit;
            end;
            ImplicitPeriod := False;
            FParser.Next;
            rr := TIFPSSubNumber.Create;
            TIFPSValueVar(x).RecAdd(rr);
            TIFPSSubNumber(rr).SubNo := t;
            rr.aType := TIFPSRecordType(u).RecVal(t).FType;
            u := FUsedTypes[rr.aType];
          end
          else
          begin
            x.Free;
            MakeError('', ecSemicolonExpected, '');
            x := nil;
            exit;
          end;
        end
        else
          break;
      end;
    end;


    function ReadPropertyParameters(Params: TIFPSParameters; ParamTypes: string): Boolean;
    var
      CurrParamType: Cardinal;
      Temp: TIFPSValue;
    begin
      Delete(ParamTypes, 1, pos(' ', ParamTypes)); // Remove property type
      if FParser.CurrTokenID <> CSTI_OpenBlock then
      begin
        MakeError('', ecOpenBlockExpected, '');
        Result := False;
        exit;
      end;
      FParser.Next;
      while ParamTypes <> '' do
      begin
        CurrParamType := at2ut(StrToIntDef(GRFW(ParamTypes), -1));
        Temp := Calc(CSTI_CloseBlock);
        if temp = nil then
        begin
          Result := False;
          Exit;
        end;
        with Params.Add do
        begin
          Val := Temp;
          ExpectedType := CurrParamType;
        end;
        if ParamTypes = '' then
        begin
          if FParser.CurrTokenID <> CSTI_CloseBlock then
          begin
            MakeError('', ecCloseBlockExpected, '');
            Result := False;
            Exit;
          end;
          FParser.Next;
        end else begin
          if FParser.CurrTokenId <> CSTI_Comma then
          begin
            MakeError('', ecCommaExpected, '');
            Result := False;
            exit;
          end;
          FParser.Next;
        end;
      end;
      Result := True;
    end;
    procedure CheckClassArrayProperty(var P: TIFPSValue; const VarType: TIFPSVariableType; VarNo: Cardinal);
    var
      FType: TIFPSType;
      procno, ppos, Idx: Cardinal;
      s, pinfo: string;
      Tempp: TIFPSValue;

    begin
      if p = nil then
        exit;
      FType := FUsedTypes[GetTypeNo(p)];
      if (FType = nil) or (FType.BaseType <> btClass) then
        exit;
      if FParser.CurrTokenID = CSTI_OpenBlock then
      begin
        if not TIFPSClassType(FType).ClassHelper.Property_Find('', Idx) then
        begin
          MakeError('', ecPeriodExpected, '');
          p.Free;
          p := nil;
          exit;
        end;
        ppos := FParser.CurrTokenPos;
        if VarNo <> InvalidVal then
        begin
          if pinfo = '' then
            pinfo := '[Default]'
          else
            pinfo := pinfo + '.' + '[Default]';
          if @FOnUseVariable <> nil then
           FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
        end;
        TIFPSClassType(FType).ClassHelper.Property_GetHeader(Idx, s);
        TempP := P;
        p := TIFPSValueProcNo.Create;
        with TIFPSValueProcNo(p) do
        begin
          Parameters := TIFPSParameters.Create;
          with Parameters.Add do
          begin
            Val := TempP;
            ExpectedType := GetTypeNo(TempP);
          end;
        end;
        if not ReadPropertyParameters(TIFPSValueProc(P).Parameters, s) then
        begin
          p.Free;
          P := nil;
          exit;
        end;
        if FParser.CurrTokenId = CSTI_Assignment then
        begin
          FParser.Next;
          TempP := Calc(CSTI_SemiColon);
          if TempP = nil then
          begin
            P.Free;
            p := nil;
            exit;
          end;
          with TIFPSValueProc(p).Parameters.Add do
          begin
            Val := Tempp;
            ExpectedType := at2ut(StrToIntDef(fw(s), -1));
          end;

          if not TIFPSClassType(FType).ClassHelper.Property_Set(Idx, procno) then
          begin
            MakeError('', ecReadOnlyProperty, '');
            p.Free;
            p := nil;
            exit;
          end;
          TIFPSValueProcNo(p).ProcNo := procno;
          TIFPSValueProcNo(p).ResultType := Cardinal(-1);
          Exit;
        end else begin
          if not TIFPSClassType(FType).ClassHelper.Property_Get(Idx, procno) then
          begin
            MakeError('', ecWriteOnlyProperty, '');
            p.Free;
            p := nil;
            exit;
          end;
          TIFPSValueProcNo(p).ProcNo := procno;
          TIFPSValueProcNo(p).ResultType := STrToInt(Fw(TIFPSExternalProcedure(FProcs[procno]).RegProc.Decl));
        end; // if FParser.CurrTokenId = CSTI_Assign
      end;
    end;

    procedure CheckClass(var P: TIFPSValue; const VarType: TIFPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
    var
      Idx, FTypeNo: Cardinal;
      FType: TIFPSType;
      TempP: TIFPSValue;
      s: string;

      pinfo: string;
      ppos: Cardinal;

    begin
      FTypeNo := GetTypeNo(p);
      if FTypeNo = InvalidVal then Exit;
      FType := FUsedTypes[FTypeNo];
      if FType.BaseType <> btClass then Exit;
      while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
      begin
        if not ImplicitPeriod then
          FParser.Next;
        if FParser.CurrTokenID <> CSTI_Identifier then
        begin
          if ImplicitPeriod then exit;
          MakeError('', ecIdentifierExpected, '');
          p.Free;
          P := nil;
          Exit;
        end;
        s := FParser.GetToken;
        if TIFPSClassType(FType).ClassHelper.Func_Find(s, Idx) then
        begin
          FParser.Next;
          VarNo := InvalidVal;
          TIFPSClassType(FType).ClassHelper.Func_Call(Idx, FTypeNo);
          P := ReadParameters(FTypeNo, P);
          if p = nil then
          begin
            Exit;
          end;
        end else if TIFPSClassType(FType).ClassHelper.Property_Find(s, Idx) then
        begin
          ppos := FParser.CurrTokenPos;
          FParser.Next;
          if VarNo <> InvalidVal then
          begin
            if pinfo = '' then
              pinfo := s
            else
              pinfo := pinfo + '.' + s;
            if @FOnUseVariable <> nil then
              FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
          end;
          TIFPSClassType(FType).ClassHelper.Property_GetHeader(Idx, s);
          TempP := P;
          p := TIFPSValueProcNo.Create;
          with TIFPSValueProcNo(p) do
          begin
            Parameters := TIFPSParameters.Create;
            with Parameters.Add do
            begin
              Val := TempP;
              ExpectedType := GetTypeNo(TempP);
            end;

          end;
          if pos(' ', s) <> 0 then
          begin
            if not ReadPropertyParameters(TIFPSValueProc(P).Parameters, s) then
            begin
              p.Free;
              P := nil;
              exit;
            end;
          end; // if
          if FParser.CurrTokenId = CSTI_Assignment then
          begin
            FParser.Next;
            TempP := Calc(CSTI_SemiColon);
            if TempP = nil then
            begin
              P.Free;
              p := nil;
              exit;
            end;
            with TIFPSValueProc(p).Parameters.Add do
            begin
              Val := Tempp;
              ExpectedType := at2ut(StrToIntDef(fw(s), -1));
            end;

            if not TIFPSClassType(FType).ClassHelper.Property_Set(Idx, FTypeNo) then
            begin
              MakeError('', ecReadOnlyProperty, '');
              p.Free;
              p := nil;
              exit;
            end;
            TIFPSValueProcNo(p).ProcNo := FTypeNo;
            TIFPSValueProcNo(p).ResultType := Cardinal(-1);
            Exit;
          end else begin
            if not TIFPSClassType(FType).ClassHelper.Property_Get(Idx, FTypeNo) then
            begin
              MakeError('', ecWriteOnlyProperty, '');
              p.Free;
              p := nil;
              exit;
            end;
            TIFPSValueProcNo(p).ProcNo := FTypeNo;
            TIFPSValueProcNo(p).ResultType := STrToInt(Fw(TIFPSExternalProcedure(FProcs[ftypeno]).RegProc.Decl));
          end; // if FParser.CurrTokenId = CSTI_Assign
        end else
        begin
          if ImplicitPeriod then exit;
          MakeError('', ecUnknownIdentifier, s);
          p.Free;
          P := nil;
          Exit;
        end;
        ImplicitPeriod := False;
        FTypeNo := GetTypeNo(p);
        FType := FUsedTypes[FTypeNo];
        if (FType = nil) or (FType.BaseType <> btClass) then Exit;
      end; {while}
    end;
    function CheckClassType(const TypeNo, ParserPos: Cardinal): TIFPSValue;
    var
      FType, FType2: TIFPSType;
      ProcNo, Idx: Cardinal;
      Temp, ResV: TIFPSValue;
    begin
      FType := FAvailableTypes[TypeNo];
      if FParser.CurrTokenID = CSTI_OpenRound then
      begin
        FParser.Next;
        Temp := Calc(CSTI_CloseRound);
        if Temp = nil then
        begin
          Result := nil;
          exit;
        end;
        if FParser.CurrTokenID <> CSTI_CloseRound then
        begin
          temp.Free;
          MakeError('', ecCloseRoundExpected, '');
          Result := nil;
          exit;
        end;
        FType2 := FUsedTypes[GetTypeNo(Temp)];
        if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
        begin
          if not TIFPSClassType(FType2).ClassHelper.CastToType(AT2UT(TypeNo), ProcNo) then
          begin
            temp.Free;
            MakeError('', ecTypeMismatch, '');
            Result := nil;
            exit;
          end;
          Result := TIFPSValueProcNo.Create;
          TIFPSValueProcNo(Result).Parameters := TIFPSParameters.Create;
          TIFPSValueProcNo(Result).ResultType := at2ut(TypeNo);
          TIFPSValueProcNo(Result).ProcNo := ProcNo;
          with TIFPSValueProcNo(Result).Parameters.Add do
          begin
            Val := Temp;
            ExpectedType := GetTypeNo(temp);
          end;
          with TIFPSValueProcNo(Result).Parameters.Add do
          begin
            ExpectedType := GetType(True, btu32);
            Val := TIFPSValueData.Create;
            with TIFPSValueData(val) do
            begin
              SetParserPos(FParser);
              Data := NewVariant(FUsedTypes, ExpectedType, btu32);
              Data.tu32 := at2ut(TypeNo);
            end;
          end;
          FParser.Next;
          Exit;
        end;
        if not checkCompatType2(FType, FType2, True) then
        begin
          temp.Free;
          MakeError('', ecTypeMismatch, '');
          Result := nil;
          exit;
        end;
        FParser.Next;
        Result := TIFPSUnValueOp.Create;
        with TIFPSUnValueOp(Result) do
        begin
          Operator := otCast;
          Val1 := Temp;
          SetParserPos(FParser);
          aType := AT2UT(TypeNo);
        end;
        exit;
      end;
      if FParser.CurrTokenId <> CSTI_Period then
      begin
        Result := nil;
        MakeError('', ecPeriodExpected, '');
        Exit;
      end;
      if FType.BaseType <> btClass then
      begin
        Result := nil;
        MakeError('', ecClassTypeExpected, '');
        Exit;
      end;
      FParser.Next;
      if not TIFPSClassType(FType).ClassHelper.ClassFunc_Find(FParser.GetToken, Idx) then
      begin
        Result := nil;
        MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
        Exit;
      end;
      FParser.Next;
      TIFPSClassType(FType).ClassHelper.ClassFunc_Call(Idx, ProcNo);
      Temp := TIFPSValueData.Create;
      with TIFPSValueData(Temp) do
      begin
        Data := NewVariant(FUsedTypes, GetType(True, btu32), btu32);
        Data.tu32 := at2ut(TypeNo);
      end;
      ResV := ReadParameters(ProcNo, Temp);
      if ResV <> nil then
      begin
        TIFPSValueProc(Resv).ResultType := at2ut(TypeNo);
        Result := Resv;
(*        Result := TIFPSUnValueOp.Create;
        with TIFPSUnValueOp(Result) do
        begin
          Val1 := ResV;
          aType := at2ut(TypeNo);
          SetParserPos(FParser);
          Operator := otCast;
        end;*)
      end else begin
        Result := nil;
      end;
    end;

  var
    vt: TIFPSVariableType;
    vno: Cardinal;
    TWith, Temp: TIFPSValue;
    l, h: Longint;
    s, u: string;
    t: TIFPSConstant;
    Temp1: Cardinal;
    bi: TIFPSBlockInfo;

  begin
    s := FParser.GetToken;
    h := MakeHash(s);

    if FType <> 1 then
    begin
      bi := BlockInfo;
      while bi <> nil do
      begin
        for l := bi.WithList.Count -1 downto 0 do
        begin
          TWith := TIFPSValueAllocatedStackVar.Create;
          TIFPSValueAllocatedStackVar(TWith).LocalVarNo := TIFPSValueAllocatedStackVar(TIFPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo;
          Temp := TWith;
          VNo := TIFPSValueAllocatedStackVar(Temp).LocalVarNo;
          vt := ivtVariable;
          if Temp = TWith then CheckFurther(TWith, True);
          if Temp = TWith then CheckClass(TWith, vt, vno, True);
          if Temp <> TWith then
          begin
            repeat
              Temp := TWith;
              if TWith <> nil then CheckFurther(TWith, False);
              if TWith <> nil then CheckClass(TWith, vt, vno, False);
              if TWith <> nil then CheckProcCall(TWith);
              if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno);
              vno := InvalidVal;
            until (TWith = nil) or (Temp = TWith);
            Result := TWith;
            Exit;
          end;
          TWith.Free;
        end;
        bi := bi.FOwner;
      end;
    end;

    u := BlockInfo.proc.Decl;
    if s = 'RESULT' then
    begin
      if GRFW(u) = '-1' then
      begin
        Result := nil;
        MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
      end
      else
      begin
        BlockInfo.Proc.ResultUse;
        Result := TIFPSValueParamVar.Create;
        with TIFPSValueParamVar(Result) do
        begin
          SetParserPos(FParser);
          ParamNo := 0;
        end;
        vno := 0;
        vt := ivtParam;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result, False);
          if Result <> nil then CheckClass(Result, vt, vno, False);
          if Result <> nil then CheckProcCall(Result);
          if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
          vno := InvalidVal;
        until (Result = nil) or (Temp = Result);
      end;
      exit;
    end;
    if GRFW(u) = '-1' then
      l := 0
    else
      l := 1;
    while Length(u) > 0 do
    begin
      if D1(GRFW(u)) = s then
      begin
        Result := TIFPSValueParamVar.Create;
        with TIFPSValueParamVar(Result) do
        begin
          SetParserPos(FParser);
          ParamNo := l;
        end;
        vt := ivtParam;
        vno := L;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result, False);
          if Result <> nil then CheckClass(Result, vt, vno, False);
          if Result <> nil then CheckProcCall(Result);
          if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
          vno := InvalidVal;
        until (Result = nil) or (Temp = Result);
        exit;
      end;
      Inc(l);
      GRFW(u);
    end;

    for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do
    begin
      if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and
        (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then
      begin
        PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use;
        vno := l;
        vt := ivtVariable;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
        Result := TIFPSValueLocalVar.Create;
        with TIFPSValueLocalVar(Result) do
        begin
          LocalVarNo := l;
          SetParserPos(FParser);
        end;
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result, False);
          if Result <> nil then CheckClass(Result, vt, vno, False);
          if Result <> nil then CheckProcCall(Result);
          if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
          vno := InvalidVal;
        until (Result = nil) or (Temp = Result);

        exit;
      end;
    end;

    for l := 0 to FVars.Count - 1 do
    begin
      if (TIFPSVar(FVars[l]).NameHash = h) and
        (TIFPSVar(FVars[l]).Name = s) then
      begin
        TIFPSVar(FVars[l]).Use;
        Result := TIFPSValueGlobalVar.Create;
        with TIFPSValueGlobalVar(Result) do
        begin
          SetParserPos(FParser);
          GlobalVarNo := l;

        end;
        vt := ivtGlobal;
        vno := l;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result, False);
          if Result <> nil then CheckClass(Result, vt, vno, False);
          if Result <> nil then CheckProcCall(Result);
          if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
          vno := InvalidVal;
        until (Result = nil) or (Temp = Result);
        exit;
      end;
    end;
    Temp1 := FindType(FParser.GetToken);
    if Temp1 <> InvalidVal then
    begin
      l := FParser.CurrTokenPos;
      if FType = 1 then
      begin
        Result := nil;
        MakeError('', ecVariableExpected, FParser.OriginalToken);
        exit;
      end;
      vt := ivtGlobal;
      vno := InvalidVal;
      FParser.Next;
      Result := CheckClassType(Temp1, l);
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result, False);
          if Result <> nil then CheckClass(Result, vt, vno, False);
          if Result <> nil then CheckProcCall(Result);
          if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
          vno := InvalidVal;
        until (Result = nil) or (Temp = Result);

      exit;
    end;
    Temp1 := FindProc(FParser.GetToken);
    if Temp1 <> InvalidVal then
    begin
      if FType = 1 then
      begin
        Result := nil;
        MakeError('', ecVariableExpected, FParser.OriginalToken);
        exit;
      end;
      FParser.Next;
      Result := ReadParameters(Temp1, nil);
      if Result = nil then
        exit;
      Result.SetParserPos(FParser);
      vt := ivtGlobal;
      vno := InvalidVal;
      repeat
        Temp := Result;
        if Result <> nil then CheckFurther(Result, False);
        if Result <> nil then CheckClass(Result, vt, vno, False);
        if Result <> nil then CheckProcCall(Result);
        if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
        vno := InvalidVal;
      until (Result = nil) or (Temp = Result);
      exit;
    end;
    for l := 0 to FConstants.Count -1 do
    begin
      t := TIFPSConstant(FConstants[l]);
      if (t.NameHash = h) and (t.Name = s) then
      begin
        if FType <> 0 then
        begin
          Result := nil;
          MakeError('', ecVariableExpected, FParser.OriginalToken);
          exit;
        end;
        fparser.next;
        Result := TIFPSValueData.Create;
        with TIFPSValueData(Result) do
        begin
          SetParserPos(FParser);
          Data := NewVariant(FUsedTypes, at2ut(t.Value.FType), t.Value.BaseType);
          CopyVariantContents(t.Value, Data);
        end;
        exit;
      end;
    end;
    Result := nil;
    MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  end;
  function ReadVarParameters(ProcNoVar: TIFPSValue): TIFPSValue;
  var
    Decl: string;
    Tmp: TIFPSValue;
    ParamType: TIFPSParameterMode;
    FType: Cardinal;
    modifier: Char;

    function IsVarInCompatible(ft1, ft2: TIFPSType): Boolean;
    begin
      ft1 := GetTypeCopyLink(ft1);
      ft2 := GetTypeCopyLink(ft2);
      Result := (ft1 <> ft2);
    end;

    function getfc(const s: string): Char;
    begin
      if Length(s) > 0 then
        Result := s[1]
      else
        Result := #0
    end;
  begin
    Decl := TIFPSProceduralType(FUsedTypes[GetTypeNo(ProcnoVar)]).ProcDef;

    Result := TIFPSValueProcVal.Create;

    with TIFPSValueProcVal(Result) do
    begin
      ResultType := StrToInt(GRFW(Decl));
      ProcNo := ProcNoVar;
      Parameters := TIFPSParameters.Create;
    end;
    if Length(Decl) = 0 then
    begin
      if FParser.CurrTokenId = CSTI_OpenRound then
      begin
        FParser.Next;
        if FParser.CurrTokenId <> CSTI_CloseRound then
        begin
          Result.Free;
          Result := nil;
          MakeError('', ecCloseRoundExpected, '');
          exit;
        end;
        FParser.Next;
      end;
    end
    else
    begin
      if FParser.CurrTokenId <> CSTI_OpenRound then
      begin
        Result.Free;
        MakeError('', ecOpenRoundExpected, '');
        Result := nil;
        exit;
      end;
      FParser.Next;
      while Length(Decl) > 0 do
      begin
        modifier := getfc(GRFW(Decl));
        FType := StrToInt(GRFW(Decl));
        if (modifier = '@') then
        begin
          Tmp := calc(CSTI_CloseRound);
          if Tmp = nil then
          begin
            Result.Free;
            Result := nil;
            exit;
          end;
          ParamType := pmIn;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            MakeError('', ecIdentifierExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end;
          Tmp := GetIdentifier(1); // only variables
          if Tmp = nil then
          begin
            Result.Free;
            Result := nil;
            exit;
          end;
          if ((FType = InvalidVal) and (TIFPSType(FUsedTypes[GetTypeNo(Tmp)]).BaseType = btArray)) then
          begin
            {nothing}
          end else if IsVarInCompatible(FUsedTypes[FType], FUsedTypes[GetTypeNo(Tmp)]) then
          begin
            MakeError('', ecTypeMismatch, '');
            Result.Free;
            Tmp.Free;
            Result := nil;
            exit;
          end;
          ParamType := pmInOut;
        end;
        with TIFPSValueProc(Result).Parameters.Add do
        begin
          Val := Tmp;
          ExpectedType := FType;
          ParamMode := ParamType;
        end;
        if Length(Decl) = 0 then
        begin
          if FParser.CurrTokenId <> CSTI_CloseRound then
          begin
            MakeError('', ecCloseRoundExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Comma then
          begin
            MakeError('', ecCommaExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end; {else if}
      end; {for}
    end; {else if}
  end;

  function calc(endOn: TIfPasToken): TIFPSValue;
    function TryEvalConst(var P: TIFPSValue): Boolean; forward;


    function ReadExpression: TIFPSValue; forward;
    function ReadTerm: TIFPSValue; forward;
    function ReadFactor: TIFPSValue;
    var
      NewVar: TIFPSValue;
      NewVarU: TIFPSUnValueOp;
      Proc: TIFPSProcedure;
      function ReadString: PIfRVariant;
      {$IFNDEF IFPS3_NOWIDESTRING}var wchar: Boolean;{$ENDIF}

        function ParseString: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};
        var
          temp3: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};

          function ChrToStr(s: string): {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF};
          var
            w: Longint;
          begin
            Delete(s, 1, 1); {First char : #}
            w := StrToInt(s);
            Result := {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w);
            {$IFNDEF IFPS3_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
          end;

          function PString(s: string): string;
          begin
            s := copy(s, 2, Length(s) - 2);
            PString := s;
          end;
        begin
          temp3 := '';
          while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
          begin
            if FParser.CurrTokenId = CSTI_String then
            begin
              temp3 := temp3 + PString(FParser.GetToken);
              FParser.Next;
              if FParser.CurrTokenId = CSTI_String then
                temp3 := temp3 + #39;
            end {if}
            else
            begin
              temp3 := temp3 + ChrToStr(FParser.GetToken);
              FParser.Next;
            end; {else if}
          end; {while}
          ParseString := temp3;
        end;
      {$IFNDEF IFPS3_NOWIDESTRING}
      var
        w: widestring;
        s: string;
      begin
        w := ParseString;
        if wchar then
        begin
          New(Result);
          if Length(w) = 1 then
          begin
            InitializeVariant(FUsedTypes, Result, GetType(True, btwidechar), btWideChar);
            Result^.twidechar := w[1];
          end else begin
            InitializeVariant(FUsedTypes, Result, GetType(True, btwidestring), btWidestring);
            tbtwidestring(result^.twidestring) := w;
          end;
        end else begin
          s := w;
          New(Result);
          if Length(s) = 1 then
          begin
            InitializeVariant(FUsedTypes, Result, GetType(True, btChar), btChar);
            Result^.tchar := s[1];
          end else begin
            InitializeVariant(FUsedTypes, Result, GetType(True, btstring), btstring);
            tbtstring(Result^.tstring) := s;
          end;
        end;
      end;
      {$ELSE}
      var
        s: string;
      begin
        s := ParseString;
        New(Result);
        if Length(s) = 1 then
        begin
          InitializeVariant(FUsedTypes, Result, GetType(true, btChar), btChar);
          Result^.tchar := s[1];
        end else begin
          InitializeVariant(FUsedTypes, Result, GetType(true, btstring), btstring);
          tbtstring(Result^.tstring) := s;
        end;
      end;
      {$ENDIF}
    function ReadReal(const s: string): PIfRVariant;
    var
      C: Integer;
    begin
      New(Result);
      InitializeVariant(FUsedTypes, Result, GetType(True, btExtended), btExtended);
      System.Val(s, Result^.textended, C);
    end;
      function ReadInteger(const s: string): PIfRVariant;
      {$IFNDEF IFPS3_NOINT64}
      var
        R: Int64;
      begin
        r := StrToInt64Def(s, 0);
        New(Result);
        if (r >= High(Longint)) or (r <= Low(Longint))then
        begin
          InitializeVariant(FUsedTypes, Result, GetType(True, bts64), bts64);
          Result^.ts64 := r;
        end else
        begin
          InitializeVariant(FUsedTypes, Result, GetType(True, bts32), bts32);
          Result^.ts32 := r;
        end;
      end;
      {$ELSE}
      var
        r: Longint;
      begin
        r := StrToIntDef(s, 0);
        New(Result);
        InitializeVariant(FUsedTypes, Result, GetType(true, bts32), bts32);
        Result^.ts32 := r;
      end;
      {$ENDIF}
      function ReadArray: Boolean;
      var
        tmp: TIFPSValue;
      begin
        FParser.Next;
        NewVar := TIFPSValueArray.Create;
        NewVar.SetParserPos(FParser);
        if FParser.CurrTokenID <> CSTI_CloseBlock then 
        begin
          while True do
          begin
            tmp := nil;
            Tmp := ReadExpression();
            if Tmp = nil then
            begin
              Result := False;
              NewVar.Free;
              exit;
            end;
            if not TryEvalConst(tmp) then
            begin
              tmp.Free;
              NewVar.Free;
              Result := False;
              exit;
            end;
            TIFPSValueArray(NewVar).Add(tmp);
            if FParser.CurrTokenID = CSTI_CloseBlock then Break;
            if FParser.CurrTokenID <> CSTI_Comma then
            begin
              MakeError('', ecCloseBlockExpected, '');
              NewVar.Free;
              Result := False;
              exit;
            end;
            FParser.Next;
          end;
        end;
        FParser.Next;
        Result := True;
      end;

      function CallAssigned(P: TIFPSValue): TIFPSValue;
      var
        temp: TIFPSValueProcNo;
      begin
        temp := TIFPSValueProcNo.Create;
        temp.ProcNo := FindProc('!ASSIGNED');
        temp.ResultType := at2ut(FBooleanType);
        temp.Parameters := TIFPSParameters.Create;
        with Temp.Parameters.Add do
        begin
          Val := p;
          ExpectedType := GetTypeNo(p);
          FParamMode := pmIn;
        end;
        Result := Temp;
      end;

    begin
      case fParser.CurrTokenID of
        CSTI_OpenBlock:
          begin
            if not ReadArray then
            begin
              Result := nil;
              exit;
            end;
          end;
        CSTII_Not:
        begin
          FParser.Next;
          NewVar := ReadFactor;
          if NewVar = nil then
          begin
            Result := nil;
            exit;
          end;
          NewVarU := TIFPSUnValueOp.Create;
          NewVarU.SetParserPos(FParser);
          NewVarU.aType := GetTypeNo(NewVar);
          NewVarU.Operator := otNot;
          NewVarU.Val1 := NewVar;
          NewVar := NewVarU;
        end;
        CSTI_Minus:
        begin
          FParser.Next;
          NewVar := ReadTerm;
          if NewVar = nil then
          begin
            Result := nil;
            exit;
          end;
          NewVarU := TIFPSUnValueOp.Create;
          NewVarU.SetParserPos(FParser);
          NewVarU.aType := GetTypeNo(NewVar);
          NewVarU.Operator := otMinus;
          NewVarU.Val1 := NewVar;
          NewVar := NewVarU;
        end;
        CSTII_Nil:
          begin
            FParser.Next;
            NewVar := TIFPSValueNil.Create;
            NewVar.SetParserPos(FParser);
          end;
        CSTI_AddressOf:
          begin
            FParser.Next;
            if FParser.CurrTokenID <> CSTI_Identifier then
            begin
              MakeError('', ecIdentifierExpected, '');
              Result := nil;
              exit;
            end;
            NewVar := TIFPSValueProcPtr.Create;
            NewVar.SetParserPos(FParser);
            TIFPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken);
            if TIFPSValueProcPtr(NewVar).ProcPtr = InvalidVal then
            begin
              MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
              NewVar.Free;
              Result := nil;
              exit;
            end;
            Proc := FProcs[TIFPSValueProcPtr(NewVar).ProcPtr];
            if Proc.ClassType <> TIFPSInternalProcedure then
            begin
              MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
              NewVar.Free;
              Result := nil;
              exit;
            end;
            TIFPSInternalProcedure(Proc).aExport := etExportDecl;
            FParser.Next;
          end;
        CSTI_OpenRound:
          begin
            FParser.Next;
            NewVar := ReadExpression();
            if NewVar = nil then
            begin
              Result := nil;
              exit;
            end;
            if FParser.CurrTokenId <> CSTI_CloseRound then
            begin
              NewVar.Free;
              Result := nil;
              MakeError('', ecCloseRoundExpected, '');
              exit;
            end;
            FParser.Next;
          end;
        CSTI_Char, CSTI_String:
          begin
            NewVar := TIFPSValueData.Create;
            NewVar.SetParserPos(FParser);
            TIFPSValueData(NewVar).Data := ReadString;
          end;
        CSTI_HexInt, CSTI_Integer:
          begin
            NewVar := TIFPSValueData.Create;
            NewVar.SetParserPos(FParser);
            TIFPSValueData(NewVar).Data := ReadInteger(FParser.GetToken);
            FParser.Next;
          end;
        CSTI_Real:
          begin
            NewVar := TIFPSValueData.Create;
            NewVar.SetParserPos(FParser);
            TIFPSValueData(NewVar).Data := ReadReal(FParser.GetToken);
            FParser.Next;
          end;
        CSTII_Ord:
          begin
            FParser.Next;
            if fParser.Currtokenid <> CSTI_OpenRound then
            begin
              Result := nil;
              MakeError('', ecOpenRoundExpected, '');
              exit;
            end;
            FParser.Next;
            NewVar := ReadExpression();
            if NewVar = nil then
            begin
              Result := nil;
              exit;
            end;
            if FParser.CurrTokenId <> CSTI_CloseRound then
            begin
              NewVar.Free;
              Result := nil;
              MakeError('', ecCloseRoundExpected, '');
              exit;
            end;
            if not ((TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType = btChar) or
            {$IFNDEF IFPS3_NOWIDESTRING} (TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType = btWideChar) or{$ENDIF}
            (TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType = btEnum) or (IsIntType(TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType))) then
            begin
              NewVar.Free;
              Result := nil;
              MakeError('', ecTypeMismatch, '');
              exit;
            end;
            NewVarU := TIFPSUnValueOp.Create;
            NewVarU.SetParserPos(FParser);
            NewVarU.Operator := otCast;
            NewVarU.FType := GetType(True, btU32);
            NewVarU.Val1 := NewVar;
            NewVar := NewVarU;
            FParser.Next;
          end;
        CSTII_Chr:
          begin
            FParser.Next;
            if fParser.Currtokenid <> CSTI_OpenRound then
            begin
              Result := nil;
              MakeError('', ecOpenRoundExpected, '');
              exit;
            end;
            FParser.Next;
            NewVar := ReadExpression();
            if NewVar = nil then
            begin
              Result := nil;
              exit;
            end;
            if FParser.CurrTokenId <> CSTI_CloseRound then
            begin
              NewVar.Free;
              Result := nil;
              MakeError('', ecCloseRoundExpected, '');
              exit;
            end;
            if not (IsIntType(TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType)) then
            begin
              NewVar.Free;
              Result := nil;
              MakeError('', ecTypeMismatch, '');
              exit;
            end;
            NewVarU := TIFPSUnValueOp.Create;
            NewVarU.SetParserPos(FParser);
            NewVarU.Operator := otCast;
            NewVarU.FType := GetType(True, btChar);
            NewVarU.Val1 := NewVar;
            NewVar := NewVarU;
            FParser.Next;
          end;
        CSTI_Identifier:
          begin
            if FParser.GetToken = 'ASSIGNED' then
            begin
              FParser.Next;
              if FParser.CurrTokenID <> CSTI_OpenRound then
              begin
                Result := nil;
                MakeError('', ecOpenRoundExpected, '');
                exit;
              end;
              FParser.Next;
              NewVar := GetIdentifier(0);
              if NewVar = nil then
              begin
                result := nil;
                exit;
              end;
              if (TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType <> btClass) and
                (TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType <> btPChar) and
                (TIFPSType(FUsedTypes[GetTypeNo(NewVar)]).BaseType <> btString) then
              begin
                NewVar.Free;
                Result := nil;
                MakeError('', ecTypeMismatch, '');
                exit;
              end;
              if FParser.CurrTokenID <> CSTI_CloseRound then
              begin
                NewVar.Free;
                Result := nil;
                MakeError('', eccloseRoundExpected, '');
                exit;
              end;
              NewVar := CallAssigned(NewVar);
              FParser.Next;
            end  else
            begin
              NewVar := GetIdentifier(0);
              if NewVar = nil then
              begin
                Result := nil;
                exit;
              end;
            end;
          end;
      else
        begin
          MakeError('', ecSyntaxError, '');
          Result := nil;
          exit;
        end;
      end; {case}
      Result := NewVar;
    end; // ReadFactor

function GetResultType(p1, P2: TIFPSValue; Cmd: TIFPSBinOperatorType): Cardinal;
    var
      pp, t1, t2: PIFPSType;
      tt1, tt2: Cardinal;
    begin
      tt1 := GetTypeNo(p1);
      t1 := FUsedTypes[tt1];
      tt2 := GetTypeNo(P2);
      t2 := FUsedTypes[tt2];
      if (t1 = nil) or (t2 = nil) then
      begin
        if ((p1.ClassType = TIFPSValueNil) or (p2.ClassType = TIFPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then
        begin
          if p1.ClassType = TIFPSValueNil then
            pp := t2
          else
            pp := t1;
          if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) then
            Result := AT2UT(FBooleanType)
          else
            Result := InvalidVal;
          exit;
        end;
        Result := InvalidVal;
        exit;
      end;
      case Cmd of
        otAdd: {plus}
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (t2.BaseType = btString) or
              {$IFNDEF IFPS3_NOWIDESTRING}
              (t2.BaseType = btwideString) or
              (t2.BaseType = btwidechar) or
              {$ENDIF}
              (t2.BaseType = btPchar) or
              (t2.BaseType = btChar) or
              (isIntRealType(t2.BaseType))) then
              Result := tt1
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (t1.BaseType = btString) or
              (t1.BaseType = btPchar) or
              (t1.BaseType = btChar) or
              (isIntRealType(t1.BaseType))) then
              Result := tt2
            else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
              Result := tt1
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := tt1
            else if IsIntRealType(t1.BaseType) and
              IsIntRealType(t2.BaseType) then
            begin
              if IsRealType(t1.BaseType) then
                Result := tt1
              else
                Result := tt2;
            end
            else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
              Result := tt1
            else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
              Result := tt2
            else if ((t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btString) or (t2.BaseType = btChar)) then
              Result := GetType(True, btString)
            {$IFNDEF IFPS3_NOWIDESTRING}
            else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar)) and
            ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar)) then
              Result := GetType(True, btWideString)
            {$ENDIF}
            else
              Result := InvalidVal;
          end;
        otSub, otMul, otDiv: { -  * / }
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (isIntRealType(t2.BaseType))) then
              Result := tt1
            else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul))  then
              Result := tt1
            else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
              Result := tt1
            else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
              Result := tt2
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (isIntRealType(t1.BaseType))) then
              Result := tt2
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := tt1
            else if IsIntRealType(t1.BaseType) and
              IsIntRealType(t2.BaseType) then
            begin
              if IsRealType(t1.BaseType) then
                Result := tt1
              else
                Result := tt2;
            end
            else
              Result := InvalidVal;
          end;
        otAnd, otOr, otXor: {and,or,xor}
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (isIntType(t2.BaseType))) then
              Result := tt1
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (isIntType(t1.BaseType))) then
              Result := tt2
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := tt1
            else if (tt1 = at2ut(FBooleanType)) and (tt2 = tt1) then
            begin
              Result := tt1;
              if ((p1.ClassType = TIFPSValueData) or (p2.ClassType = TIFPSValueData)) then
              begin
                if cmd = otAnd then {and}
                begin
                  if p1.ClassType = TIFPSValueData then
                  begin
                    if (TIFPSValueData(p1).FData^.tu8 <> 0) then
                    begin
                      with MakeWarning('', ewIsNotNeeded, '"True and"') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end else
                    begin
                      with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end;
                  end else begin
                    if (TIFPSValueData(p2).Data.tu8 <> 0) then
                    begin
                      with MakeWarning('', ewIsNotNeeded, '"and True"') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end
                    else
          begin
                      with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end;
                  end;
                end else if cmd = otOr then {or}
                begin
                  if p1.ClassType = TIFPSValueData then
                  begin
                    if (TIFPSValueData(p1).Data.tu8 <> 0) then
                    begin
                      with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end
                    else
                    begin
                      with MakeWarning('', ewIsNotNeeded, '"False or"') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end
                  end else begin
                    if (TIFPSValueData(p2).Data.tu8 <> 0) then
                    begin
                      with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end
                    else
                    begin
                      with MakeWarning('', ewIsNotNeeded, '"or False"') do
                      begin
                        FRow := p1.Row;
                        FCol := p1.Col;
                        FPosition := p1.Pos;
                      end;
                    end
                  end;
                end;
              end;
            end else
              Result := InvalidVal;
          end;
        otMod, otShl, otShr: {mod,shl,shr}
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (isIntType(t2.BaseType))) then
              Result := tt1
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (isIntType(t1.BaseType))) then
              Result := tt2
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := tt1
            else
              Result := InvalidVal;
          end;
        otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <}
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (t2.BaseType = btString) or
              (t2.BaseType = btPchar) or
              (t2.BaseType = btChar) or
              (isIntRealType(t2.BaseType))) then
              Result := at2ut(FBooleanType)
            else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual))  then
              Result := at2ut(FBooleanType)
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (t1.BaseType = btString) or
              (t1.BaseType = btPchar) or
              (t1.BaseType = btChar) or
              (isIntRealType(t1.BaseType))) then
              Result := at2ut(FBooleanType)
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := at2ut(FBooleanType)
            else if IsIntRealType(t1.BaseType) and
              IsIntRealType(t2.BaseType) then
              Result := at2ut(FBooleanType)
            else if
            ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF IFPS3_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar){$ENDIF}) and
            ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF IFPS3_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar){$ENDIF}) then
              Result := at2ut(FBooleanType)
            else if (t1.BaseType = btVariant) or (t2.BaseType = btVariant) then
              Result := at2ut(FBooleanType)
            else
              Result := InvalidVal;
          end;
        otEqual, otNotEqual: {=, <>}
          begin
            if (t1.BaseType = btVariant) and (
              (t2.BaseType = btVariant) or
              (t2.BaseType = btString) or
              (t2.BaseType = btPchar) or
              (t2.BaseType = btChar) or
              (isIntRealType(t2.BaseType))) then
              Result := at2ut(FBooleanType)
            else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
              Result := at2ut(FBooleanType)
            else
            if (t2.BaseType = btVariant) and (
              (t1.BaseType = btVariant) or
              (t1.BaseType = btString) or
              (t1.BaseType = btPchar) or
              (t1.BaseType = btChar) or
              (isIntRealType(t1.BaseType))) then
              Result := at2ut(FBooleanType)
            else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
              Result := at2ut(FBooleanType)
            else if IsIntRealType(t1.BaseType) and
              IsIntRealType(t2.BaseType) then
              Result := at2ut(FBooleanType)
            else if
            ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF IFPS3_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar){$ENDIF}) and
            ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF IFPS3_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar){$ENDIF}) then
              Result := at2ut(FBooleanType)
            else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
              Result := at2ut(FBooleanType)
            else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
              Result := at2ut(FBooleanType)
            else if (t1.BaseType = btEnum) and (t1 = t2) then
              Result := at2ut(FBooleanType)
            else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
              Result := at2ut(FBooleanType)
            else if (t1.BaseType = btVariant) or (t2.BaseType = btVariant) then
              Result := at2ut(FBooleanType)
            else Result := InvalidVal;
          end;
        otIn:
          begin
            if (t2.BaseType = btSet) and (TIFPSSetType(t2).SetType = t1) then
              Result := at2ut(FBooleanType)
            else
              Result := InvalidVal;
          end;
        otIs:
          begin
            Result := InvalidVal;
          end;
        otAs:
          begin
            Result := InvalidVal;
          end;
      else
        Result := InvalidVal;
      end;
    end;


    function ReadTerm: TIFPSValue;
    var
      F1, F2: TIFPSValue;
      F: TIFPSBinValueOp;
      Token: TIfPasToken;
      Op: TIFPSBinOperatorType;
    begin
      F1 := ReadFactor;
      if F1 = nil then
      begin
        Result := nil;
        exit;
      end;
      while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do
      begin
        Token := FParser.CurrTokenID;
        FParser.Next;
        F2 := ReadFactor;
        if f2 = nil then
        begin
          f1.Free;
          Result := nil;
          exit;
        end;
        case Token of
          CSTI_Multiply: Op := otMul;
          CSTII_div, CSTI_Divide: Op := otDiv;
          CSTII_mod: Op := otMod;
          CSTII_and: Op := otAnd;
          CSTII_shl: Op := otShl;
          CSTII_shr: Op := otShr;
          CSTII_As:  Op := otAs;
        else
          Op := otAdd;
        end;
        F := TIFPSBinValueOp.Create;
        f.Val1 := F1;
        f.Val2 := F2;
        f.Operator := Op;
        f.aType := GetResultType(F1, F2, Op);
        if f.aType = InvalidVal then
        begin
          MakeError('', ecTypeMismatch, '');
          f.Free;
          Result := nil;
          exit;
        end;
        f1 := f;
      end;
      Result := F1;
    end;  // ReadTerm

    function ReadSimpleExpression: TIFPSValue;
    var
      F1, F2: TIFPSValue;
      F: TIFPSBinValueOp;
      Token: TIfPasToken;
      Op: TIFPSBinOperatorType;
    begin
      F1 := ReadTerm;
      if F1 = nil then
      begin
        Result := nil;
        exit;
      end;
      while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
      begin
        Token := FParser.CurrTokenID;
        FParser.Next;
        F2 := ReadTerm;
        if f2 = nil then
        begin
          f1.Free;
          Result := nil;
          exit;
        end;
        case Token of
          CSTI_Plus: Op := otAdd; 
          CSTI_Minus: Op := otSub;
          CSTII_or: Op := otOr;
          CSTII_xor: Op := otXor;
        else
          Op := otAdd;
        end;
        F := TIFPSBinValueOp.Create;
        f.Val1 := F1;
        f.Val2 := F2;
        f.Operator := Op;
        f.aType := GetResultType(F1, F2, Op);
        if f.aType = InvalidVal then
        begin
          MakeError('', ecTypeMismatch, '');
          f.Free;
          Result := nil;
          exit;
        end;
        f1 := f;
      end;
      Result := F1;
    end;  // ReadSimpleExpression


    function ReadExpression: TIFPSValue;
    var
      F1, F2: TIFPSValue;
      F: TIFPSBinValueOp;
      Token: TIfPasToken;
      Op: TIFPSBinOperatorType;
    begin
      F1 := ReadSimpleExpression;
      if F1 = nil then
      begin
        Result := nil;
        exit;
      end;
      while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do
      begin
        Token := FParser.CurrTokenID;
        FParser.Next;
        F2 := ReadSimpleExpression;
        if f2 = nil then
        begin
          f1.Free;
          Result := nil;
          exit;
        end;
        case Token of
          CSTI_GreaterEqual: Op := otGreaterEqual;
          CSTI_LessEqual: Op := otLessEqual;
          CSTI_Greater: Op := otGreater;
          CSTI_Less: Op := otLess;
          CSTI_Equal: Op := otEqual;
          CSTI_NotEqual: Op := otNotEqual;
          CSTII_in: Op := otIn;
          CSTII_is: Op := otIs;
        else
          Op := otAdd;
        end;
        F := TIFPSBinValueOp.Create;
        f.Val1 := F1;
        f.Val2 := F2;
        f.Operator := Op;
        f.aType := GetResultType(F1, F2, Op);
        if f.aType = InvalidVal then
        begin
          MakeError('', ecTypeMismatch, '');
          f.Free;
          Result := nil;
          exit;
        end;
        f1 := f;
      end;
      Result := F1;
    end;  // ReadExpression





    function TryEvalConst(var P: TIFPSValue): Boolean;
    var
      preplace: TIFPSValue;
    begin
      if p is TIFPSBinValueOp then
      begin
        TryEvalConst(TIFPSBinValueOp(p).FVal1);
        TryEvalConst(TIFPSBinValueOp(p).FVal2);
        if (TIFPSBinValueOp(p).FVal1.ClassType = TIFPSValueData) and (TIFPSBinValueOp(p).FVal2.ClassType = TIFPSValueData) then
        begin
          if not PreCalc(True, 0, TIFPSValueData(TIFPSBinValueOp(p).Val1).Data, 0, TIFPSValueData(TIFPSBinValueOp(p).Val2).Data, TIFPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then
          begin
            MakeError('', ecTypeMismatch, '');
            Result := False;
            exit;
          end;
          preplace := TIFPSValueData.Create;
          preplace.Pos := p.Pos;
          preplace.Row := p.Row;
          preplace.Col := p.Col;
          TIFPSValueData(preplace).Data := TIFPSValueData(TIFPSBinValueOp(p).Val1).Data;
          TIFPSValueData(TIFPSBinValueOp(p).Val1).Data := nil;
          p.Free;
          p := preplace;
        end;
      end else if p is TIFPSUnValueOp then
      begin
        TryEvalConst(TIFPSUnValueOp(p).FVal1);
        if TIFPSUnValueOp(p).FVal1.ClassType = TIFPSValueData then
        begin
//
          case TIFPSUnValueOp(p).Operator of
            otNot:
              begin
                case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.BaseType of
                  btEnum:
                    begin
                      if TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.FType = at2ut(FBooleanType) then
                      begin
                        TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8 := (not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8) and 1;
                      end else
                      begin
                        MakeError('', ecTypeMismatch, '');
                        Result := False;
                        exit;
                      end;
                    end;
                  btU8: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                  btU16: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                  btU32: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu32 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu32;
                  bts8: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts8 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts8;
                  bts16: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts16 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts16;
                  bts32: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts32 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts32;
                  {$IFNDEF IFPS3_NOINT64}
                  bts64: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64 := not TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                  {$ENDIF}
                else
                  begin
                    MakeError('', ecTypeMismatch, '');
                    Result := False;
                    exit;
                  end;
                end;
                preplace := TIFPSUnValueOp(p).Val1;
                TIFPSUnValueOp(p).Val1 := nil;
                p.Free;
                p := preplace;
              end;
            otMinus:
              begin
                case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.BaseType of
                  btU8: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                  btU16: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                  btU32: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu32 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu32;
                  bts8: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts8 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts8;
                  bts16: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts16 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts16;
                  bts32: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts32 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts32;
                  {$IFNDEF IFPS3_NOINT64}
                  bts64: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64 := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                  {$ENDIF}
                  btSingle: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tsingle := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tsingle;
                  btDouble: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tdouble := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tdouble;
                  btExtended: TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.textended := -TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.textended;
                else
                  begin
                    MakeError('', ecTypeMismatch, '');
                    Result := False;
                    exit;
                  end;
                end;
                preplace := TIFPSUnValueOp(p).Val1;
                TIFPSUnValueOp(p).Val1 := nil;
                p.Free;
                p := preplace;
              end;
            otCast:
              begin
                preplace := TIFPSValueData.Create;
                TIFPSValueData(preplace).Data := NewVariant(FUsedTypes, TIFPSUnValueOp(p).FType, TIFPSType(FUsedTypes[TIFPSUnValueOp(p).FType]).BaseType);
                case TIFPSType(FUsedTypes[TIFPSUnValueOp(p).FType]).BaseType of
                  btU8:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.tu8 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.tu8 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.tu8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  btS8:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.ts8 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.ts8 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.ts8 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  btU16:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.tu16 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.tu16 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.tu16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  bts16:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.ts16 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.ts16 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.ts16 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  btU32:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.tu32 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.tu32 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  btS32:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.ts32 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.ts32 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.ts32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.tu32 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  {$IFNDEF IFPS3_NOINT64}
                  btS64:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.ts64 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar);
                        {$IFNDEF IFPS3_NOWIDESTRING}
                        btwidechar: TIFPSValueData(preplace).Data.ts64 := ord(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.twidechar);
                        {$ENDIF}
                        btU8: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8;
                        btS8: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8;
                        btU16: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16;
                        btS16: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16;
                        btU32: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32;
                        btS32: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32;
                        btS64: TIFPSValueData(preplace).Data.ts64 := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64;
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          preplace.Free;
                          Result := False;
                          exit;
                        end;
                      end;
                    end;
                  {$ENDIF}
                  btChar:
                    begin
                      case TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.basetype of
                        btchar: TIFPSValueData(preplace).Data.tchar := TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tchar;
                        btU8: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu8);
                        btS8: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS8);
                        btU16: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tu16);
                        btS16: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS16);
                        btU32: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tU32);
                        btS32: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.tS32);
                        {$IFNDEF IFPS3_NOINT64}
                        btS64: TIFPSValueData(preplace).Data.tchar := chr(TIFPSValueData(TIFPSUnValueOp(p).FVal1).Data^.ts64);
                        {$ENDIF}
                      else
                        begin
                          MakeError('', ecTypeMismatch, '');
                          Result := False;
                          preplace.Free;
                          exit;
                        end;
                      end;
                    end;
                else
                  begin
                    MakeError('', ecTypeMismatch, '');
                    Result := False;
                    preplace.Free;
                    exit;
                  end;
                end;
                TIFPSUnValueOp(p).Val1 := nil;
                p.Free;
                p := preplace;
              end;
            else
              begin
                MakeError('', ecTypeMismatch, '');
                Result := False;
                exit;
              end;
          end; // case
        end; // if
      end;
      Result := True;
    end;

  var
    Val: TIFPSValue;
  begin
    Val := ReadExpression;
    if Val = nil then
    begin
      Result := nil;
      exit;
    end;
    if not TryEvalConst(Val) then
    begin
      Val.Free;
      Result := nil;
      exit;
    end;
    Result := Val;
  end;

  function ReadParameters(ProcNo: Cardinal; fSelf: TIFPSValue): TIFPSValue;
  var
    Decl: string;
    Tmp: TIFPSValue;
    FType: Cardinal;
    modifier: Char;
    ParamType: TIFPSParameterMode;
    PType: TIFPSType;
    ignoretype: Boolean;

    function IsVarInCompatible(ft1, ft2: TIFPSType): Boolean;
    begin
      ft1 := GetTypeCopyLink(ft1);
      ft2 := GetTypeCopyLink(ft2);
      Result := (ft1 <> ft2);
    end;

    function getfc(const s: string): Char;
    begin
      if Length(s) > 0 then
        Result := s[1]
      else
        Result := #0
    end;
  begin
    if TIFPSProcedure(FProcs[ProcNo]).ClassType = TIFPSInternalProcedure then
      Decl := TIFPSInternalProcedure(FProcs[ProcNo]).Decl
    else
      Decl := TIFPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
    Result := TIFPSValueProcNo.Create;
    TIFPSValueProcNo(Result).ProcNo := ProcNo;
    TIFPSValueProcNo(Result).ResultType := STrToInt(GRFW(Decl));
    with TIFPSValueProcNo(Result) do
    begin
      SetParserPos(FParser);
      Parameters := TIFPSParameters.Create;
      if FSelf <> nil then
      begin
        with Parameters.Add do
        begin
          Val := FSelf;
          ExpectedType := GetTypeNo(FSelf);
        end;
      end;
    end;
    if Length(Decl) = 0 then
    begin
      if FParser.CurrTokenId = CSTI_OpenRound then
      begin
        FParser.Next;
        if FParser.CurrTokenId <> CSTI_CloseRound then
        begin
          Result.Free;
          Result := nil;
          MakeError('', ecCloseRoundExpected, '');
          exit;
        end;
        FParser.Next;
      end;
    end
    else
    begin
      if FParser.CurrTokenId <> CSTI_OpenRound then
      begin
        Result.Free;
        MakeError('', ecOpenRoundExpected, '');
        Result := nil;
        exit;
      end;
      FParser.Next;
      while Length(Decl) > 0 do
      begin
        modifier := getfc(GRFW(Decl));
        FType := StrToInt(GRFW(Decl));
        ignoretype := False;
        if (modifier = '@') then
        begin
          Tmp := calc(CSTI_CloseRound);
          if Tmp = nil then
          begin
            Result.Free;
            Result := nil;
            exit;
          end;
          ParamType := pmIn;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            MakeError('', ecIdentifierExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end;
          Tmp := GetIdentifier(1); // only variables
          if Tmp = nil then
          begin
            Result.Free;
            Result := nil;
            exit;
          end;
          PType := TIFPSType(FUsedTypes[FType]);
          if (FType = InvalidVal) or ((PType.BaseType = btArray) and (TIFPSArrayType(PType).ArrayTypeNo = InvalidVal) and (TIFPSType(FUsedTypes[GetTypeNo(Tmp)]).BaseType = btArray)) then
          begin
            ignoretype := True;
          end else if (PType.BaseType = btArray) and (TIFPSType(FUsedTypes[GetTypeNo(Tmp)]).BaseType = btArray) then
          begin
            if TIFPSArrayType(FUsedTypes[GetTypeNo(Tmp)]).ArrayTypeNo <> TIFPSArrayType(FUsedTypes[FType]).ArrayTypeNo then
            begin
              MakeError('', ecTypeMismatch, '');
              Result.Free;
              Tmp.Free;
              Result := nil;
              exit;
            end;
          end else if IsVarInCompatible(FUsedTypes[FType], FUsedTypes[GetTypeNo(Tmp)]) then
          begin
            MakeError('', ecTypeMismatch, '');
            Result.Free;
            Tmp.Free;
            Result := nil;
            exit;
          end;
          ParamType := pmInOut;
        end;
        with TIFPSValueProc(Result).Parameters.Add do
        begin
          Val := Tmp;
          if ignoretype then
            ExpectedType := GetTypeNo(tmp)
          else
            ExpectedType := FType;
          ParamMode := ParamType;
        end;
        if Length(Decl) = 0 then
        begin
          if FParser.CurrTokenId <> CSTI_CloseRound then
          begin
            MakeError('', ecCloseRoundExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Comma then
          begin
            MakeError('', ecCommaExpected, '');
            Result.Free;
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end; {else if}
      end; {for}
    end; {else if}
  end;


  function WriteCalculation(InData, OutReg: TIFPSValue): Boolean;

    function CheckOutreg(Where, Outreg: TIFPSValue): Boolean;
    var
      i: Longint;
    begin
      Result := False;
      if Where.ClassType = TIFPSUnValueOp then
      begin
        if CheckOutReg(TIFPSUnValueOp(Where).Val1, OutReg) then
          Result := True;
      end else if Where.ClassType = TIFPSBinValueOp then
      begin
        if CheckOutreg(TIFPSBinValueOp(Where).Val1, OutReg) or CheckOutreg(TIFPSBinValueOp(Where).Val2, OutReg) then
          Result := True;
      end else if Where is TIFPSValueVar then
      begin
        if SameReg(Where, OutReg) then
          Result := True;
      end else if Where is TIFPSValueProc then
      begin
        for i := 0 to TIFPSValueProc(Where).Parameters.Count -1 do
        begin
          if Checkoutreg(TIFPSValueProc(Where).Parameters[i].Val, Outreg) then
          begin
            Result := True;
            break;
          end;
        end;
      end;
    end;
  begin
    if not CheckCompatType(Outreg, InData) then
    begin
      MakeError('', ecTypeMismatch, '');
      Result := False;
      exit;
    end;
    if SameReg(OutReg, InData) then
    begin
      Result := True;
      exit;
    end;
    if InData is TIFPSValueProc then
    begin
      Result := ProcessFunction(TIFPSValueProc(indata), OutReg)
    end else begin
      if not PreWriteOutRec(OutReg, InvalidVal) then
      begin
        Result := False;
        exit;
      end;
      if (not CheckOutReg(InData, OutReg)) and (InData is TIFPSBinValueOp) or (InData is TIFPSUnValueOp) then
      begin
        if InData is TIFPSBinValueOp then
        begin
          if not DoBinCalc(TIFPSBinValueOp(InData), OutReg) then
          begin
            AfterWriteOutRec(OutReg);
            Result := False;
            exit;
          end;
        end else
        begin
          if not DoUnCalc(TIFPSUnValueOp(InData), OutReg) then
          begin
            AfterWriteOutRec(OutReg);
            Result := False;
            exit;
          end;
        end;
      end else if (InData is TIFPSBinValueOp) and (not CheckOutReg(TIFPSBinValueOp(InData).Val2, OutReg)) then
      begin
        if not DoBinCalc(TIFPSBinValueOp(InData), OutReg) then
        begin
          AfterWriteOutRec(OutReg);
          Result := False;
          exit;
        end;
      end else begin
        if not PreWriteOutRec(InData, GetTypeNo(OutReg)) then
        begin
          Result := False;
          exit;
        end;
        WriteCommand(CM_A);
        if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then
        begin
          Result := False;
          exit;
        end;
        AfterWriteOutRec(InData);
      end;
      AfterWriteOutRec(OutReg);
      Result := True;
    end;
  end; {WriteCalculation}


  function ProcessFunction(ProcCall: TIFPSValueProc; ResultRegister: TIFPSValue): Boolean;
  var
    res: Cardinal;
    tmp: TIFPSParameter;
    resreg: TIFPSValue;
    l: Longint;

    function Cleanup: Boolean;
    var
      i: Longint;
    begin
      for i := 0 to ProcCall.Parameters.Count -1 do
      begin
        if ProcCall.Parameters[i].TempVar <> nil then
          ProcCall.Parameters[i].TempVar.Free;
        ProcCall.Parameters[i].TempVar := nil;
      end;
      if ProcCall is TIFPSValueProcVal then
        AfterWriteOutRec(TIFPSValueProcVal(ProcCall).fProcNo);
      if ResReg <> nil then
        AfterWriteOutRec(resreg);
      if ResReg <> nil then
      begin
        if ResReg <> ResultRegister then
        begin
          if ResultRegister <> nil then
          begin
            if not WriteCalculation(ResReg, ResultRegister) then
            begin
              Result := False;
              resreg.Free;
              exit;
            end;
          end;
          resreg.Free;
        end;
      end;
      Result := True;
    end;

  begin
    Res := ProcCall.ResultType;
    Result := False;
    if (res = InvalidVal) and (ResultRegister <> nil) then
    begin
      MakeError('', ecNoResult, '');
      exit;
    end
    else if (res <> InvalidVal)  then
    begin
      if (ResultRegister = nil) or (Res <> GetTypeNo(ResultRegister)) then
      begin
        resreg := AllocStackReg(res);
      end else resreg := ResultRegister;
    end
    else
      resreg := nil;
    if ResReg <> nil then
    begin
      if not PreWriteOutRec(resreg, InvalidVal) then
      begin
        Cleanup;
        exit;
      end;
    end;
    if Proccall is TIFPSValueProcVal then
    begin
      if not PreWriteOutRec(TIFPSValueProcVal(ProcCall).fProcNo, InvalidVal) then
      begin
        Cleanup;
        exit;
      end;
    end;
    for l := ProcCall.Parameters.Count - 1 downto 0 do
    begin
      Tmp := ProcCall.Parameters[l];
      if (Tmp.ParamMode <> pmIn)  then
      begin
        tmp.TempVar := AllocStackReg(GetType(True, btPointer));
//        tmp.TempVar := AllocStackReg2(Tmp.ExpectedType);
        if not PreWriteOutRec(Tmp.FValue, InvalidVal) then
        begin
          cleanup;
          exit;
        end;
        WriteCommand(cm_sp);
        WriteOutRec(tmp.TempVar, False);
        WriteOutRec(Tmp.FValue, False);
        AfterWriteOutRec(Tmp.FValue);
      end
      else
      begin
        Tmp.TempVar := AllocStackReg(Tmp.ExpectedType);
        if not WriteCalculation(Tmp.Val, Tmp.TempVar) then
        begin
          Cleanup;
          exit;
        end;
      end;
    end; {for}
    if res <> InvalidVal then
    begin
      WriteCommand(CM_PV);

      if not WriteOutRec(resreg, False) then
      begin
        Cleanup;
        MakeError('', ecInternalError, '00015');
        exit;
      end;
    end;
    if ProcCall is TIFPSValueProcVal then
    begin
      WriteCommand(Cm_cv);
      WriteOutRec(TIFPSValueProcVal(ProcCall).ProcNo, True);
    end else begin
      WriteCommand(CM_C);
      WriteLong(TIFPSValueProcNo(ProcCall).ProcNo);
    end;
    if res <> InvalidVal then
      WriteCommand(CM_PO);
    if not Cleanup then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessVarFunction}

  function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
  var
    I, J: Longint;
    Ok: LongBool;
    FLabelsInBlock: TIfStringList;
    s: string;
  begin
    FLabelsInBlock := TIfStringList.Create;
    for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
    begin
      s := BlockInfo.Proc.FLabels[I];
      if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
      begin
        Delete(s, 1, 8);
        FLabelsInBlock.Add(s);
      end;
    end;
    for i := 0 to BlockInfo.Proc.FGotos.Count -1 do
    begin
      s := BlockInfo.Proc.FGotos[I];
      if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
      begin
        Delete(s, 1, 8);
        OK := False;
        for J := 0 to FLabelsInBlock.Count -1 do
        begin
          if FLabelsInBlock[J] = s then
          begin
            Ok := True;
            Break;
          end;
        end;
        if not Ok then
        begin
          MakeError('', ecInvalidJump, '');
          Result := True;
          FLabelsInBlock.Free;
          exit;
        end;
      end else begin
        Delete(s, 1, 4);
        OK := True;
        for J := 0 to FLabelsInBlock.Count -1 do
        begin
          if FLabelsInBlock[J] = s then
          begin
            Ok := False;
            Break;
          end;
        end;
        if not Ok then
        begin
          MakeError('', ecInvalidJump, '');
          Result := True;
          FLabelsInBlock.Free;
          exit;
        end;
      end;
    end;
    FLabelsInBlock.Free;
    Result := False;
  end;

  function ProcessFor: Boolean;
    { Process a for x := y to z do }
  var
    VariableVar: TIFPSValue;
      TempBool,
      TempNum,
      InitVal,
      finVal: TIFPSValue;
    Block: TIFPSBlockInfo;
    Backwards: Boolean;
    FPos, NPos, EPos, RPos: Longint;
    OldCO, OldBO: TIfList;
    I: Longint;
  begin
    Debug_WriteLine(BlockInfo);
    Result := False;
    FParser.Next;
    if FParser.CurrTokenId <> CSTI_Identifier then
    begin
      MakeError('', ecIdentifierExpected, '');
      exit;
    end;
    VariableVar := GetIdentifier(1);
    if VariableVar = nil then
      exit;
    case TIFPSType(FUsedTypes[GetTypeNo(VariableVar)]).BaseType of
      btU8, btS8, btU16, btS16, btU32, btS32: ;
    else
      begin
        MakeError('', ecTypeMismatch, '');
        VariableVar.Free;
        exit;
      end;
    end;
    if FParser.CurrTokenId <> CSTI_Assignment then
    begin
      MakeError('', ecAssignmentExpected, '');
      VariableVar.Free;
      exit;
    end;
    FParser.Next;
    InitVal := calc(CSTII_DownTo);
    if InitVal = nil then
    begin
      VariableVar.Free;
      exit;
    end;
    if FParser.CurrTokenId = CSTII_To then
      Backwards := False
    else if FParser.CurrTokenId = CSTII_DownTo then
      Backwards := True
    else
    begin
      MakeError('', ecToExpected, '');
      VariableVar.Free;
      InitVal.Free;
      exit;
    end;
    FParser.Next;
    finVal := calc(CSTII_do);
    if finVal = nil then
    begin
      VariableVar.Free;
      InitVal.Free;
      exit;
    end;
    if FParser.CurrTokenId <> CSTII_do then
    begin
      MakeError('', ecDoExpected, '');
      finVal.Free;
      InitVal.Free;
      VariableVar.Free;
      exit;
    end;
    FParser.Next;
    if not WriteCalculation(InitVal, VariableVar) then
    begin
      VariableVar.Free;
      InitVal.Free;
      finVal.Free;
      exit;
    end;
    InitVal.Free;
    TempBool := AllocStackReg(at2ut(FBooleanType));
    NPos := Length(BlockInfo.Proc.Data);
    if not (PreWriteOutRec(VariableVar, InvalidVal) and PreWriteOutRec(finVal, InvalidVal)) then
    begin
      TempBool.Free;
      VariableVar.Free;
      finVal.Free;
      exit;
    end;
    WriteCommand(CM_CO);
    if Backwards then
    begin
      WriteByte(0); { >= }
    end
    else
    begin
      WriteByte(1); { <= }
    end;
    if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then
    begin
      TempBool.Free;
      VariableVar.Free;
      finVal.Free;
      exit;
    end;
    AfterWriteOutRec(finVal);
    AfterWriteOutRec(VariableVar);
    finVal.Free;
    WriteCommand(Cm_CNG);
    EPos := Length(BlockInfo.Proc.Data);
    WriteLong($12345678);
    WriteOutRec(TempBool, False);
    RPos := Length(BlockInfo.Proc.Data);
    OldCO := FContinueOffsets;
    FContinueOffsets := TIfList.Create;
    OldBO := FBreakOffsets;
    FBreakOffsets := TIFList.Create;
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tOneLiner;
    if not ProcessSub(Block) then
    begin
      Block.Free;
      TempBool.Free;
      VariableVar.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    Block.Free;
    TempNum := TIFPSValueData.Create;
    TempNum.SetParserPos(FParser);
    TIFPSValueData(TempNum).Data := NewVariant(FUsedTypes, GetTypeNo(VariableVar), TIFPSType(FUsedTypes[GetTypeNo(VariableVar)]).BaseType);
    case TIFPSValueData(TempNum).Data.BaseType of
      btU8, btS8: TIFPSValueData(TempNum).Data.tu8 := 1;
      btU16, btS16: TIFPSValueData(TempNum).Data.tu16 := 1;
      btU32, btS32: TIFPSValueData(TempNum).Data.tu32 := 1;
    else
      begin
        MakeError('', ecInternalError, '00019');
        TempNum.Free;
        TempBool.Free;
        VariableVar.Free;
        FBreakOffsets.Free;
        FContinueOffsets.Free;
        FContinueOffsets := OldCO;
        FBreakOffsets := OldBo;
        exit;
      end;
    end;
    FPos := Length(BlockInfo.Proc.Data);
    if not PreWriteOutRec(VariableVar, InvalidVal) then
    begin
      TempNum.Free;
      TempBool.Free;
      VariableVar.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    WriteCommand(CM_CA);
    if Backwards then
      WriteByte(1) {-}
    else
      WriteByte(0); {+}
    if not (WriteOutRec(VariableVar, False) and WriteOutRec(TempNum, True)) then
    begin
      TempNum.Free;
      TempBool.Free;
      VariableVar.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    AfterWriteOutRec(VariableVar);
    TempNum.Free;
    WriteCommand(Cm_G);
    WriteLong(Longint(NPos - Length(BlockInfo.Proc.Data) - 4));
    Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos;
    for i := 0 to FBreakOffsets.Count -1 do
    begin
      EPos := Cardinal(FBreakOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
    end;
    for i := 0 to FContinueOffsets.Count -1 do
    begin
      EPos := Cardinal(FContinueOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
    end;
    FBreakOffsets.Free;
    FContinueOffsets.Free;
    FContinueOffsets := OldCO;
    FBreakOffsets := OldBo;
    TempBool.Free;
    VariableVar.Free;
    if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessFor}

  function ProcessWhile: Boolean;
  var
    vin, vout: TIFPSValue;
    SPos, EPos: Cardinal;
    OldCo, OldBO: TIfList;
    I: Longint;
    Block: TIFPSBlockInfo;
  begin
    Result := False;
    Debug_WriteLine(BlockInfo);
    FParser.Next;
    vout := calc(CSTII_do);
    if vout = nil then
      exit;
    if FParser.CurrTokenId <> CSTII_do then
    begin
      vout.Free;
      MakeError('', ecDoExpected, '');
      exit;
    end;
    vin := AllocStackReg(at2ut(FBooleanType));
    SPos := Length(BlockInfo.Proc.Data); // start position
    OldCo := FContinueOffsets;
    FContinueOffsets := TIfList.Create;
    OldBO := FBreakOffsets;
    FBreakOffsets := TIFList.Create;
    if not WriteCalculation(vout, vin) then
    begin
      vout.Free;
      vin.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    vout.Free;
    FParser.Next; // skip DO
    WriteCommand(Cm_CNG); // only goto if expression is false
    WriteLong($12345678);
    EPos := Length(BlockInfo.Proc.Data);
    if not WriteOutRec(vin, False) then
    begin
      MakeError('', ecInternalError, '00017');
      vin.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tOneLiner;
    if not ProcessSub(Block) then
    begin
      Block.Free;
      vin.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    Block.Free;
    Debug_WriteLine(BlockInfo);
    WriteCommand(Cm_G);
    WriteLong(Longint(SPos) - Length(BlockInfo.Proc.Data) - 4);
    Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
    for i := 0 to FBreakOffsets.Count -1 do
    begin
      EPos := Cardinal(FBreakOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
    end;
    for i := 0 to FContinueOffsets.Count -1 do
    begin
      EPos := Cardinal(FContinueOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
    end;
    FBreakOffsets.Free;
    FContinueOffsets.Free;
    FContinueOffsets := OldCO;
    FBreakOffsets := OldBo;
    vin.Free;
    if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end;

  function ProcessRepeat: Boolean;
  var
    vin, vout: TIFPSValue;
    SPos, EPos: Cardinal;
    I: Longint;
    OldCo, OldBO: TIfList;
    Block: TIFPSBlockInfo;
  begin
    Result := False;
    Debug_WriteLine(BlockInfo);
    FParser.Next;
    OldCo := FContinueOffsets;
    FContinueOffsets := TIfList.Create;
    OldBO := FBreakOffsets;
    FBreakOffsets := TIFList.Create;
    vin := AllocStackReg(at2ut(FBooleanType));
    SPos := Length(BlockInfo.Proc.Data);
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tRepeat;
    if not ProcessSub(Block) then
    begin
      Block.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      vin.Free;
      exit;
    end;
    Block.Free;
    FParser.Next; //cstii_until
    vout := calc(CSTI_Semicolon);
    if vout = nil then
    begin
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      vin.Free;
      exit;
    end;
    if not WriteCalculation(vout, vin) then
    begin
      vout.Free;
      vin.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    vout.Free;
    WriteCommand(Cm_CNG);
    WriteLong($12345678);
    EPos := Length(BlockInfo. Proc.Data);
    if not WriteOutRec(vin, False) then
    begin
      MakeError('', ecInternalError, '00016');
      vin.Free;
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) -
      Length(BlockInfo.Proc.Data);
    for i := 0 to FBreakOffsets.Count -1 do
    begin
      EPos := Cardinal(FBreakOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos);
    end;
    for i := 0 to FContinueOffsets.Count -1 do
    begin
      EPos := Cardinal(FContinueOffsets[I]);
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
    end;
    FBreakOffsets.Free;
    FContinueOffsets.Free;
    FContinueOffsets := OldCO;
    FBreakOffsets := OldBo;
    vin.Free;
    if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessRepeat}

  function ProcessIf: Boolean;
  var
    vout, vin: TIFPSValue;
    SPos, EPos: Cardinal;
    Block: TIFPSBlockInfo;
  begin
    Result := False;
    Debug_WriteLine(BlockInfo);
    FParser.Next;
    vout := calc(CSTII_Then);
    if vout = nil then
      exit;
    if FParser.CurrTokenId <> CSTII_Then then
    begin
      vout.Free;
      MakeError('', ecThenExpected, '');
      exit;
    end;
    vin := AllocStackReg(at2ut(FBooleanType));
    if not WriteCalculation(vout, vin) then
    begin
      vout.Free;
      vin.Free;
      exit;
    end;
    vout.Free;
    WriteCommand(cm_sf);
    if not WriteOutRec(vin, False) then
    begin
      MakeError('', ecInternalError, '00018');
      vin.Free;
      exit;
    end;
    WriteByte(1);
    vin.Free;
    WriteCommand(cm_fg);
    WriteLong($12345678);
    SPos := Length(BlockInfo.Proc.Data);
    FParser.Next; // skip then
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tifOneliner;
    if not ProcessSub(Block) then
    begin
      Block.Free;
      exit;
    end;
    Block.Free;
    if FParser.CurrTokenId = CSTII_Else then
    begin
      WriteCommand(Cm_G);
      WriteLong($12345678);
      EPos := Length(BlockInfo.Proc.Data);
      Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
      FParser.Next;
      Block := TIFPSBlockInfo.Create(BlockInfo);
      Block.SubType := tOneLiner;
      if not ProcessSub(Block) then
      begin
        Block.Free;
        exit;
      end;
      Block.Free;
      Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
    end
    else
    begin
      Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
    end;
    Result := True;
  end; {ProcessIf}

  function ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
  var
    I, H: Longint;
    s: string;
  begin
    h := MakeHash(FParser.GetToken);
    for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
    begin
      s := BlockInfo.Proc.FLabels[I];
      delete(s, 1, 4);
      if Longint((@s[1])^) = h then
      begin
        delete(s, 1, 4);
        if s = FParser.GetToken then
        begin
          s := BlockInfo.Proc.FLabels[I];
          Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data);
          BlockInfo.Proc.FLabels[i] := s;
          FParser.Next;
          if fParser.CurrTokenId = CSTI_Colon then
          begin
            Result := 1;
            FParser.Next;
            exit;
          end else begin
            MakeError('', ecColonExpected, '');
            Result := 0;
            Exit;
          end;
        end;
      end;
    end;
    result := 2;
  end;

  function ProcessIdentifier: Boolean;
  var
    vin, vout: TIFPSValue;
  begin
    Result := False;
    Debug_WriteLine(BlockInfo);
    vin := GetIdentifier(2);
    if vin <> nil then
    begin
      if vin is TIFPSValueVar then
      begin // assignment needed
        if FParser.CurrTokenId <> CSTI_Assignment then
        begin
          MakeError('', ecAssignmentExpected, '');
          vin.Free;
          exit;
        end;
        FParser.Next;
        vout := calc(CSTI_Semicolon);
        if vout = nil then
        begin
          vin.Free;
          exit;
        end;
        if not WriteCalculation(vout, vin) then
        begin
          vin.Free;
          vout.Free;
          exit;
        end;
        vin.Free;
        vout.Free;
      end else if vin is TIFPSValueProc then
      begin
        Result := ProcessFunction(TIFPSValueProc(vin), nil);
        vin.Free;
        Exit;
      end else
      begin
        MakeError('', ecInternalError, '20');
        vin.Free;
        REsult := False;
        exit;
      end;
    end
    else
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessIdentifier}

  function ProcessCase: Boolean;
  var
    TempRec, Val, CalcItem: TIFPSValue;
    p: TIFPSBinValueOp;
    SPos, CurrP: Cardinal;
    I: Longint;
    EndReloc: TIfList;
    Block: TIFPSBlockInfo;
  begin
    Debug_WriteLine(BlockInfo);
    FParser.Next;
    Val := calc(CSTII_of);
    if Val = nil then
    begin
      ProcessCase := False;
      exit;
    end; {if}
    if FParser.CurrTokenId <> CSTII_Of then
    begin
      MakeError('', ecOfExpected, '');
      val.Free;
      ProcessCase := False;
      exit;
    end; {if}
    FParser.Next;
    TempRec := AllocStackReg(GetTypeNo(Val));
    if not WriteCalculation(Val, TempRec) then
    begin
      TempRec.Free;
      val.Free;
      ProcessCase := False;
      exit;
    end; {if}
    val.Free;
    EndReloc := TIfList.Create;
    CalcItem := AllocStackReg(at2ut(FBooleanType));
    SPos := Length(BlockInfo.Proc.Data);
    repeat
      Val := calc(CSTI_Colon);
      if (Val = nil) or (FParser.CurrTokenID <> CSTI_Colon) then
      begin
        if FParser.CurrTokenID <> CSTI_Colon then
          MakeError('', ecColonExpected, '');
        CalcItem.Free;
        TempRec.Free;
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end; {if}
      FParser.Next;
      p := TIFPSBinValueOp.Create;
      p.SetParserPos(FParser);
      p.Operator := otEqual;
      p.aType := at2ut(FBooleanType);
      p.Val1 := Val;
      p.Val2 := TempRec;
      if not WriteCalculation(p, CalcItem) then
      begin
        CalcItem.Free;
        p.Free;
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end;
      p.Val2 := nil;
      p.Free;
      WriteByte(Cm_CNG);
      WriteLong($12345678);
      CurrP := Length(BlockInfo.Proc.Data);
      WriteOutRec(CalcItem, False);
      Block := TIFPSBlockInfo.Create(BlockInfo);
      Block.SubType := tifOneliner;
      if not ProcessSub(Block) then
      begin
        Block.Free;
        CalcItem.Free;
        TempRec.Free;
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end;
      Block.Free;
      WriteByte(Cm_G);
      WriteLong($12345678);
      EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data)));
      Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
      if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
      if FParser.CurrTokenID = CSTII_Else then
      begin
        FParser.Next;
        Block := TIFPSBlockInfo.Create(BlockInfo);
        Block.SubType := tOneliner;
        if not ProcessSub(Block) then
        begin
          Block.Free;
          CalcItem.Free;
          TempRec.Free;
          EndReloc.Free;
          ProcessCase := False;
          exit;
        end;
        Block.Free;
        if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
        if FParser.CurrtokenId <> CSTII_End then
        begin
          MakeError('', ecEndExpected, '');
          CalcItem.Free;
          TempRec.Free;
          EndReloc.Free;
          ProcessCase := False;
          exit;
        end;
      end;
    until FParser.CurrTokenID = CSTII_End;
    FParser.Next;
    for i := 0 to EndReloc.Count -1 do
    begin
      Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
    end;
    CalcItem.Free;
    TempRec.Free;
    EndReloc.Free;
    if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessCase}
  function ProcessGoto: Boolean;
  var
    I, H: Longint;
    s: string;
  begin
    Debug_WriteLine(BlockInfo);
    FParser.Next;
    h := MakeHash(FParser.GetToken);
    for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
    begin
      s := BlockInfo.Proc.FLabels[I];
      delete(s, 1, 4);
      if Longint((@s[1])^) = h then
      begin
        delete(s, 1, 4);
        if s = FParser.GetToken then
        begin
          FParser.Next;
          WriteCommand(Cm_G);
          WriteLong($12345678);
          BlockInfo.Proc.FGotos.Add(IFPS3_mi2s(length(BlockInfo.Proc.Data))+IFPS3_mi2s(i));
          Result := True;
          exit;
        end;
      end;
    end;
    MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
    Result := False;
  end; {ProcessGoto}

  function ProcessWith: Boolean;
  var
    Block: TIFPSBlockInfo;
    aVar, aReplace: TIFPSValue;
    aType: TIFPSType;
  begin
    Debug_WriteLine(BlockInfo);
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tOneLiner;

    FParser.Next;
    repeat
      aVar := GetIdentifier(0);
      if aVar = nil then
      begin
        block.Free;
        Result := False;
        exit;
      end;
      AType := FUsedTypes[GetTypeNo(aVar)];
      if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then
      begin
        MakeError('', ecClassTypeExpected, '');
        Block.Free;
        Result := False;
        exit;
      end;

      aReplace := TIFPSValueReplace.Create;
      aReplace.SetParserPos(FParser);
      TIFPSValueReplace(aReplace).FreeOldValue := True;
      TIFPSValueReplace(aReplace).FreeNewValue := True;
      TIFPSValueReplace(aReplace).OldValue := aVar;
      TIFPSValueReplace(aReplace).NewValue := AllocStackReg(GetTypeNo(aVar));
      if not WriteCalculation(aVar, TIFPSValueReplace(aReplace).NewValue) then
      begin
        aReplace.Free;
        Block.Free;
        Result := False;
        exit;
      end;
      Block.WithList.Add(aReplace);

      if FParser.CurrTokenID = CSTII_do then
      begin
        FParser.Next;
        Break;
      end else
      if FParser.CurrTokenId <> CSTI_Comma then
      begin
        MakeError('', ecDoExpected, '');
        Block.Free;
        Result := False;
        exit;
      end;
      FParser.Next;
    until False;

    if not ProcessSub(Block) then
    begin
      Block.Free;
      Result := False;
      exit;
    end;
    Block.Free;
    Result := True;
  end;

  function ProcessTry: Boolean;
  var
    FStartOffset: Cardinal;
    Block: TIFPSBlockInfo;
  begin
    FParser.Next;
    WriteCommand(cm_puexh);
    FStartOffset := Length(BlockInfo.Proc.Data) + 1;
    WriteLong(InvalidVal);
    WriteLong(InvalidVal);
    WriteLong(InvalidVal);
    WriteLong(InvalidVal);
    Block := TIFPSBlockInfo.Create(BlockInfo);
    Block.SubType := tTry;
    if ProcessSub(Block) then
    begin
      Block.Free;
      WriteCommand(cm_poexh);
      WriteByte(0);
      if FParser.CurrTokenID = CSTII_Except then
      begin
        FParser.Next;
        Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
        Block := TIFPSBlockInfo.Create(BlockInfo);
        Block.SubType := tTryEnd;
        if ProcessSub(Block) then
        begin
          Block.Free;
          WriteCommand(cm_poexh);
          writeByte(2);
          if FParser.CurrTokenId = CSTII_Finally then
          begin
            Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
            Block := TIFPSBlockInfo.Create(BlockInfo);
            Block.SubType := tTryEnd;
            FParser.Next;
            if ProcessSub(Block) then
            begin
              Block.Free;
              if FParser.CurrTokenId = CSTII_End then
              begin
                WriteCommand(cm_poexh);
                writeByte(3);
              end else begin
                MakeError('', ecEndExpected, '');
                Result := False;
                exit;
              end;
            end else begin Block.Free; Result := False; exit; end;
          end else if FParser.CurrTokenID <> CSTII_End then
          begin
            MakeError('', ecEndExpected, '');
            Result := False;
            exit;
          end;
          FParser.Next;
        end else begin Block.Free; Result := False; exit; end;
      end else if FParser.CurrTokenId = CSTII_Finally then
      begin
        FParser.Next;
        Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
        Block := TIFPSBlockInfo.Create(BlockInfo);
        Block.SubType := tTryEnd;
        if ProcessSub(Block) then
        begin
          Block.Free;
          WriteCommand(cm_poexh);
          writeByte(1);
          if FParser.CurrTokenId = CSTII_Except then
          begin
            Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
            FParser.Next;
            Block := TIFPSBlockInfo.Create(BlockInfo);
            Block.SubType := tTryEnd;
            if ProcessSub(Block) then
            begin
              Block.Free;
              if FParser.CurrTokenId = CSTII_End then
              begin
                WriteCommand(cm_poexh);
                writeByte(2);
              end else begin
                MakeError('', ecEndExpected, '');
                Result := False;
                exit;
              end;
            end else begin Block.Free; Result := False; exit; end;
          end else if FParser.CurrTokenID <> CSTII_End then
          begin
            MakeError('', ecEndExpected, '');
            Result := False;
            exit;
          end;
          FParser.Next;
        end else begin Block.Free;Result := False; exit; end;
      end;
    end else begin Block.Free; Result := False; exit; end;
    Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
    Result := True;
  end; {ProcessTry}

var
  Block: TIFPSBlockInfo;

begin
  ProcessSub := False;
  if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or (BlockInfo.SubType= tSubBegin) then
  begin
    FParser.Next; // skip CSTII_Begin
  end;
  while True do
  begin
    case FParser.CurrTokenId of
      CSTII_Goto:
        begin
          if not ProcessGoto then
            Exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_With:
        begin
          if not ProcessWith then
            Exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_Try:
        begin
          if not ProcessTry then
            Exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_Finally, CSTII_Except:
        begin
          if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then
            Break
          else
            begin
              MakeError('', ecEndExpected, '');
              Exit;
            end;
        end;
      CSTII_Begin:
        begin
          Block := TIFPSBlockInfo.Create(BlockInfo);
          Block.SubType := tSubBegin;
          if not ProcessSub(Block) then
          begin
            Block.Free;
            Exit;
          end;
          Block.Free;
        
          FParser.Next; // skip END
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTI_Semicolon:
        begin
          FParser.Next;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_until:
        begin
          Debug_WriteLine(BlockInfo);
          if BlockInfo.SubType = tRepeat then
          begin
            break;
          end
          else
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_Else:
        begin
          if BlockInfo.SubType = tifOneliner then
            break
          else
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
        end;
      CSTII_repeat:
        begin
          if not ProcessRepeat then
            exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_For:
        begin
          if not ProcessFor then
            exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_While:
        begin
          if not ProcessWhile then
            exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_Exit:
        begin
          Debug_WriteLine(BlockInfo);
          WriteCommand(Cm_R);
          FParser.Next;
        end;
      CSTII_Case:
        begin
          if not ProcessCase then
            exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTII_If:
        begin
          if not ProcessIf then
            exit;
          if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
            break;
        end;
      CSTI_Identifier:
        begin
          case ProcessLabel of
            0: Exit;
            1: ;
            else
            begin
              if FParser.GetToken = 'BREAK' then
              begin
                if FBreakOffsets = nil then
                begin
                  MakeError('', ecNotInLoop, '');
                  exit;
                end;
                WriteCommand(Cm_G);
                WriteLong($12345678);
                FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
                FParser.Next;
                if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then
                  break;
              end else if FParser.GetToken = 'CONTINUE' then
              begin
                if FBreakOffsets = nil then
                begin
                  MakeError('', ecNotInLoop, '');
                  exit;
                end;
                WriteCommand(Cm_G);
                WriteLong($12345678);
                FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
                FParser.Next;
                if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
                  break;
              end else
              if not ProcessIdentifier then
                exit;
              if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
                break;
            end;
          end; {case}
        end;
      CSTII_End:
        begin
          if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tSubBegin) or
          (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner) then
          begin
            break;
          end
          else
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
        end;
      CSTI_EOF:
        begin
          MakeError('', ecUnexpectedEndOfFile, '');
          exit;
        end;
    else
      begin
        MakeError('', ecIdentifierExpected, '');
        exit;
      end;
    end;
  end;
  if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin) then
  begin
    Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
    WriteCommand(Cm_R);
    FParser.Next; // skip end
    if (BlockInfo.SubType = tMainBegin) and (FParser.CurrTokenId <> CSTI_Period) then
    begin
      MakeError('', ecPeriodExpected, '');
      exit;
    end;
    if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
    begin
      MakeError('', ecSemicolonExpected, '');
      exit;
    end;
    FParser.Next;
  end;
  ProcessSub := True;
end;


function TIFPSPascalCompiler.ProcessLabelForwards(Proc: TIFPSInternalProcedure): Boolean;
var
  i: Longint;
  s, s2: string;
begin
  for i := 0 to Proc.FLabels.Count -1 do
  begin
    s := Proc.FLabels[I];
    if Longint((@s[1])^) = -1 then
    begin
      delete(s, 1, 8);
      MakeError('', ecUnSetLabel, s);
      Result := False;
      exit;
    end;
  end;
  for i := Proc.FGotos.Count -1 downto 0 do
  begin
    s := Proc.FGotos[I];
    s2 := Proc.FLabels[Cardinal((@s[5])^)];
    Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) :=  Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
  end;
  Result := True;
end;


type
  TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation);

function TIFPSPascalCompiler.Compile(const s: string): Boolean;
var
  Position: TCompilerState;
  i: Longint;

  procedure Cleanup;
  var
    I: Longint;
    PT: TIFPSType;
  begin
    FGlobalBlock.Free;

    for I := 0 to FRegProcs.Count - 1 do
      TObject(FRegProcs[I]).Free;
    FRegProcs.Free;
    for i := 0 to FConstants.Count -1 do
    begin
      TIFPSConstant(FConstants[I]).Free;
    end;
    Fconstants.Free;
    for I := 0 to FVars.Count - 1 do
    begin
      TIFPSVar(FVars[I]).Free;
    end;
    FVars.Free;
    for I := 0 to FProcs.Count - 1 do
      TIFPSProcedure(FProcs[I]).Free;
    FProcs.Free;
    FProcs := nil;
    for I := 0 to FAvailableTypes.Count - 1 do
    begin
      PT := FAvailableTypes[I];
      pt.Free;
    end;
    FAvailableTypes.Free;
    FUsedTypes.Free;
    for i := FClasses.Count -1 downto 0 do
    begin
      TIFPSCompileTimeClass(FClasses[I]).Free;
    end;
    FClasses.Free;
  end;

  procedure MakeOutput;

    procedure WriteByte(b: Byte);
    begin
      FOutput := FOutput + Char(b);
    end;

    procedure WriteData(const Data; Len: Longint);
    var
      l: Longint;
    begin
      if Len < 0 then Len := 0;
      l := Length(FOutput);
      SetLength(FOutput, l + Len);
      Move(Data, FOutput[l + 1], Len);
    end;

    procedure WriteLong(l: Cardinal);
    begin
      WriteData(l, 4);
    end;


    procedure WriteTypes;
    var
      l, n: Longint;
      bt: TIFPSBaseType;
      Tmp: Cardinal;
      x: TIFPSType;
      FExportName: string;
      procedure WriteTypeNo(TypeNo: Cardinal);
      begin
        WriteData(TypeNo, 4);
      end;
    begin
      for l := 0 to FUsedTypes.Count - 1 do
      begin
        x := FUsedTypes[l];
        if x.FExportName then
          FExportName := x.Name
        else
          FExportName := '';
        if x.BaseType = btClass then
        begin
          x := GetTypeCopyLink(FAvailableTypes[TIFPSClassType(x).ClassHelper.SelfType]);
        end;
        bt := x.BaseType;
        if (x.BaseType = btEnum) then begin
          if TIFPSEnumType(x).HighValue <= 256 then
            bt := btU8
          else if TIFPSEnumType(x).HighValue <= 65536 then
            bt := btU16
          else
            bt := btU32;
        end;
        if FExportName <> '' then
        begin
          WriteByte(bt + 128);
        end
        else
          WriteByte(bt);
        if x.BaseType = btResourcePointer then
        begin
          WriteLong(Length(TIFPSResourcePtrType(X).ResourceType));
          WriteData(TIFPSResourcePtrType(X).ResourceType[1], Length(TIFPSResourcePtrType(X).ResourceType));
        end else
        if (x.BaseType = btSet) then
        begin
          WriteLong(TIFPSSetType(x).BitSize);
        end else
        if (x.BaseType = btArray) or (x.basetype = btStaticArray) then
        begin
          WriteLong(Longint(TIFPSArrayType(x).ArrayTypeNo));
          if (x.baseType = btstaticarray) then
            WriteLong(Longint(TIFPSStaticArrayType(x).Length));
        end else if x.BaseType = btRecord then
        begin
          n := TIFPSRecordType(x).RecValCount;
          WriteData(n, 4);
          for n := 0 to TIFPSRecordType(x).RecValCount - 1 do
          begin
            Tmp := TIFPSRecordType(x).RecVal(n).FType;
            WriteTypeNo(Tmp);
          end;
        end;
        if FExportName <> '' then
        begin
          WriteLong(Length(FExportName));
          WriteData(FExportName[1], length(FExportName));
        end;
      end;
    end;

    procedure WriteVars;
    var
      l: Longint;
      x: TIFPSVar;
    begin
      for l := 0 to FVars.Count - 1 do
      begin
        x := FVars[l];
        WriteLong(x.FType);
        if x.exportname <> '' then
        begin
          WriteByte(1);
          WriteLong(Length(X.ExportName));
          WriteData(X.ExportName[1], length(X.ExportName));
        end else
          WriteByte(0);
      end;
    end;

    procedure WriteProcs;
    var
      l: Longint;
      xp: TIFPSProcedure;
      xo: TIFPSInternalProcedure;
      xe: TIFPSExternalProcedure;
      s: string;
    begin
      for l := 0 to FProcs.Count - 1 do
      begin
        xp := FProcs[l];
        if xp.ClassType = TIFPSInternalProcedure then
        begin
          xo := TIFPSInternalProcedure(xp);
          xo.OutputDeclPosition := Length(FOutput);
          if xo.aExport <> etExportNone then
            WriteByte(2) // exported
          else
            WriteByte(0); // not imported
          WriteLong(0); // offset is unknown at this time
          WriteLong(0); // length is also unknown at this time
          if xo.aExport <> etExportNone then
          begin
            WriteLong(Length(xo.Name));
            WriteData(xo.Name[1], length(xo.Name));
            if xo.FExport = etExportName then
            begin
              WriteLong(0);
            end else begin
              s := MakeExportDecl(xo.Decl);
              WriteLong(Length(s));
              WriteData(s[1], length(S));
            end;
          end;
        end
        else
        begin
          xe := TIFPSExternalProcedure(xp);
          if xe.RegProc.ImportDecl <> '' then
          begin
            WriteByte(3); // imported
            if xe.RegProc.FExportName then
            begin
              WriteByte(Length(xe.RegProc.Name));
              WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
            end else begin
              WriteByte(0);
            end;
            WriteLong(Length(xe.RegProc.ImportDecl));
            WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl));
          end else begin
            WriteByte(1); // imported
            WriteByte(Length(xe.RegProc.Name));
            WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
          end;
        end;
      end;
    end;

    procedure WriteProcs2;
    var
      l: Longint;
      L2: Cardinal;
      x: TIFPSProcedure;
    begin
      for l := 0 to FProcs.Count - 1 do
      begin
        x := FProcs[l];
        if x.ClassType = TIFPSInternalProcedure then
        begin
          if TIFPSInternalProcedure(x).Data = '' then
            TIFPSInternalProcedure(x).Data := Chr(Cm_R);
          L2 := Length(FOutput);
          Move(L2, FOutput[TIFPSInternalProcedure(x).OutputDeclPosition + 2], 4);
          // write position
          WriteData(TIFPSInternalProcedure(x).Data[1], Length(TIFPSInternalProcedure(x).Data));
          L2 := Cardinal(Length(FOutput)) - L2;
          Move(L2, FOutput[TIFPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length
        end;
      end;
    end;

    function FindMainProc: Cardinal;
    var
      l: Longint;
    begin
      for l := 0 to FProcs.Count - 1 do
      begin
        if (TIFPSProcedure(FProcs[l]).ClassType = TIFPSInternalProcedure) and
          (TIFPSInternalProcedure(FProcs[l]).Name = IFPSMainProcName) then
        begin
          Result := l;
          exit;
        end;
      end;
      Result := InvalidVal;
    end;
    procedure CreateDebugData;
    var
      I: Longint;
      p: TIFPSProcedure;
      pv: TIFPSVar;
      s: string;
    begin
      s := #0;
      for I := 0 to FProcs.Count - 1 do
      begin
        p := FProcs[I];
        if p.ClassType = TIFPSInternalProcedure then
        begin
          if TIFPSInternalProcedure(p).Name = IFPSMainProcName then
            s := s + #1
          else
            s := s + TIFPSInternalProcedure(p).Name + #1;
        end
        else
        begin
          s := s+ TIFPSExternalProcedure(p).RegProc.Name + #1;
        end;
      end;
      s := s + #0#1;
      for I := 0 to FVars.Count - 1 do
      begin
        pv := FVars[I];
        s := s + pv.Name + #1;
      end;
      s := s + #0;
      WriteDebugData(s);
    end;
  begin
    CreateDebugData;
    WriteLong(IFPSValidHeader);
    WriteLong(IFPSCurrentBuildNo);
    WriteLong(FUsedTypes.Count);
    WriteLong(FProcs.Count);
    WriteLong(FVars.Count);
    WriteLong(FindMainProc);
    WriteLong(0);
    WriteTypes;
    WriteProcs;
    WriteVars;
    WriteProcs2;
  end;

  function CheckExports: Boolean;
  var
    i: Longint;
    p: TIFPSProcedure;
  begin
    if @FOnExportCheck = nil then
    begin
      result := true;
      exit;
    end;
    for i := 0 to FProcs.Count -1 do
    begin
      p := FProcs[I];
      if p.ClassType = TIFPSInternalProcedure then
      begin
        if not FOnExportCheck(Self, TIFPSInternalProcedure(p), MakeDecl(TIFPSInternalProcedure(p).Decl)) then
        begin
          Result := false;
          exit;
        end;
      end;
    end;
    Result := True;
  end;
  function DoConstBlock: Boolean;
  var
    CName: string;
    CTemp, CValue: PIFRVariant;
    Cp: TIFPSConstant;
  begin
    FParser.Next;
    repeat
      if FParser.CurrTokenID <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
        Result := False;
        Exit;
      end;
      CName := FParser.GetToken;
      if IsDuplicate(CName, [dcVars, dcProcs, dcConsts]) then
      begin
        MakeError('', ecDuplicateIdentifier, '');
        Result := False;
        exit;
      end;
      FParser.Next;
      if FParser.CurrTokenID <> CSTI_Equal then
      begin
        MakeError('', ecIsExpected, '');
        Result := False;
        Exit;
      end;
      FParser.Next;
      CValue := ReadConstant(FParser, CSTI_SemiColon);
      if CValue = nil then
      begin
        Result := False;
        Exit;
      end;
      if FParser.CurrTokenID <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        Result := False;
        exit;
      end;
      cp := TIFPSConstant.Create;
      cp.Name := CName;
      New(CTemp);
      InitializeVariant(FAvailableTypes, CTemp, CValue.FType, TIFPSType(FAvailableTypes[CValue.FType]).BaseType);
      CopyVariantContents(cvalue, CTemp);
      cp.Value := CTemp;
      FConstants.Add(cp);
      DisposeVariant(CValue);
      FParser.Next;
    until FParser.CurrTokenId <> CSTI_Identifier;
    Result := True;
  end;
  function ProcessUses: Boolean;
  var
    FUses: TIfStringList;
    I: Longint;
    s: string;
  begin
    FParser.Next;
    FUses := TIfStringList.Create;
    FUses.Add('SYSTEM');
    repeat
      if FParser.CurrTokenID <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
        FUses.Free;
        Result := False;
        exit;
      end;
      s := FParser.GetToken;
      for i := 0 to FUses.Count -1 do
      begin
        if FUses[I] = s then
        begin
          MakeError('', ecDuplicateIdentifier, s);
          FUses.Free;
          Result := False;
          exit;
        end;
      end;
      FUses.Add(s);
      if @FOnUses <> nil then
      begin
        try
          if not OnUses(Self, FParser.GetToken) then
          begin
            FUses.Free;
            Result := False;
            exit;
          end;
        except
          on e: Exception do
          begin
            MakeError('', ecCustomError, e.Message);
            FUses.Free;
            Result := False;
            exit;
          end;
        end;
      end;
      FParser.Next;
      if FParser.CurrTokenID = CSTI_Semicolon then break
      else if FParser.CurrTokenId <> CSTI_Comma then
      begin
        MakeError('', ecSemicolonExpected, '');
        Result := False;
        FUses.Free;
        exit;
      end;
      FParser.Next;
    until False;
    FUses.Free;
    FParser.next;
    Result := True;
  end;

var
  Proc: TIFPSProcedure;  

begin
  FIsUnit := False;
  Result := False;
  Clear;
  FParser.SetText(s);

  FProcs := TIfList.Create;
  FConstants := TIFList.Create;
  FVars := TIfList.Create;
  FAvailableTypes := TIfList.Create;
  FUsedTypes := TIfList.Create;
  FRegProcs := TIfList.Create;
  FClasses := TIfList.Create;
  FGlobalBlock := TIFPSBlockInfo.Create(nil);
  FGlobalBlock.SubType := tMainBegin;

  FGlobalBlock.Proc := NewProc(IFPSMainProcNameOrg, IFPSMainProcName);
  FGlobalBlock.ProcNo := FindProc(IFPSMainProcName);

  DefineStandardTypes;
  DefineStandardProcedures;
  if @FOnUses <> nil then
  begin
    try
      if not OnUses(Self, 'SYSTEM') then
      begin
        Cleanup;
        exit;
      end;
    except
      on e: Exception do
      begin
        MakeError('', ecCustomError, e.Message);
        Cleanup;
        exit;
      end;
    end;
  end;
  Position := csStart;
  repeat
    if FParser.CurrTokenId = CSTI_EOF then
    begin
      if FAllowNoEnd then
        Break
      else
      begin
        MakeError('', ecUnexpectedEndOfFile, '');
        Cleanup;
        exit;
      end;
    end;
    if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then
    begin
      Position := csProgram;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
        Cleanup;
        exit;
      end;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        Cleanup;
        exit;
      end;
      FParser.Next;
    end else
    if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then
    begin
      Position := csImplementation;
      FParser.Next;
    end else
    if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then
    begin
      Position := csInterface;
      FParser.Next;
    end else
    if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then
    begin
      Position := csUnit;
      FIsUnit := True;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
        Cleanup;
        exit;
      end;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        Cleanup;
        exit;
      end;
      FParser.Next;
    end
    else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then
    begin
      if Position = csInterface then
        Position := csInterfaceUses
      else
        Position := csUses;
      if not ProcessUses then
      begin
        Cleanup;
        exit;
      end;
    end else if (FParser.CurrTokenId = CSTII_Procedure) or
      (FParser.CurrTokenId = CSTII_Function) then
    begin
      if (Position = csInterface) or (position = csInterfaceUses) then
      begin
        if not ProcessFunction(True) then
        begin
          Cleanup;
          exit;
        end;
      end else begin
        Position := csUses;
        if not ProcessFunction(False) then
        begin
          Cleanup;
          exit;
        end;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Label) then
    begin
      Position := csUses;
      if not ProcessLabel(FGlobalBlock.Proc) then
      begin
        Cleanup;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Var) then
    begin
      Position := csUses;
      if not DoVarBlock(nil) then
      begin
        Cleanup;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Const) then
    begin
      Position := csUses;
      if not DoConstBlock then
      begin
        Cleanup;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Type) then
    begin
      Position := csUses;
      if not DoTypeBlock(FParser) then
      begin
        Cleanup;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Begin) then
    begin
      if ProcessSub(FGlobalBlock) then
      begin
        break;
      end
      else
      begin
        Cleanup;
        exit;
      end;
    end
    else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
    begin
      FParser.Next;
      if FParser.CurrTokenID <> CSTI_Period then
      begin
        MakeError('', ecPeriodExpected, '');
        Cleanup;
        exit;
      end;
      break;
    end else
    begin
      MakeError('', ecBeginExpected, '');
      Cleanup;
      exit;
    end;
  until False;
  if not ProcessLabelForwards(FGlobalBlock.Proc) then
  begin
    Cleanup;
    exit;
  end;
  for i := 0 to FProcs.Count -1 do
  begin
    Proc := FProcs[I];
    if (Proc.ClassType = TIFPSInternalProcedure) and (TIFPSInternalProcedure(Proc).Forwarded) then
    begin
      with MakeError('', ecUnsatisfiedForward, TIFPSInternalProcedure(Proc).Name) do
      begin
        FPosition := TIFPSInternalProcedure(Proc).DeclarePos;
        FRow := TIFPSInternalProcedure(Proc).DeclareRow;
        FCol := TIFPSInternalProcedure(Proc).DeclareCol;
      end;
      Cleanup;
      Exit;
    end;
  end;
  if not CheckExports then
  begin
    Cleanup;
    exit;
  end;
  for i := 0 to FVars.Count -1 do
  begin
    if not TIFPSVar(FVars[I]).Used then
    begin
      with MakeHint('', ehVariableNotUsed, TIFPSVar(FVars[I]).Name) do
      begin
        FPosition := TIFPSVar(FVars[I]).DeclarePos;
        FRow := TIFPSVar(FVars[I]).DeclareRow;
        FCol := TIFPSVar(FVars[I]).DeclareCol;
      end;
    end;
  end;
  MakeOutput;
  Cleanup;
  Result := True;
end;

constructor TIFPSPascalCompiler.Create;
begin
  inherited Create;
  FParser := TIfPascalParser.Create;
  FParser.OnParserError := ParserError;
  FAutoFreeList := TIfList.Create;
  FOutput := '';
  FMessages := TIfList.Create;
end;

destructor TIFPSPascalCompiler.Destroy;
begin
  Clear;
  FAutoFreeList.Free;

  FMessages.Free;
  FParser.Free;
  inherited Destroy;
end;

function TIFPSPascalCompiler.GetOutput(var s: string): Boolean;
begin
  if Length(FOutput) <> 0 then
  begin
    s := FOutput;
    Result := True;
  end
  else
    Result := False;
end;

function TIFPSPascalCompiler.GetMsg(l: Longint): TIFPSPascalCompilerMessage;
begin
  Result := FMessages[l];
end;

function TIFPSPascalCompiler.GetMsgCount: Longint;
begin
  Result := FMessages.Count;
end;

procedure TIFPSPascalCompiler.DefineStandardTypes;
var
  i: Longint;
begin
  AddType('Byte', btU8);
  AddTypeS('Boolean', '(False, True)');
  FBooleanType := FAvailableTypes.Count -1;
  AddType('Char', btChar);
  {$IFNDEF IFPS3_NOWIDESTRING}
  AddType('WideChar', btWideChar);
  AddType('WideString', btWideString);
  {$ENDIF}
  AddType('ShortInt', btS8);
  AddType('Word', btU16);
  AddType('SmallInt', btS16);
  AddType('LongInt', btS32);
  AddType('LongWord', btU32);
  AddTypeCopyN('Integer', 'LONGINT');
  AddTypeCopyN('Cardinal', 'LONGWORD');
  AddType('string', btString);
  {$IFNDEF IFPS3_NOINT64}
  AddType('Int64', btS64);
  {$ENDIF}
  AddType('Single', btSingle);
  AddType('Double', btDouble);
  AddType('Extended', btExtended);

  for i := FAvailableTypes.Count -1 downto 0 do AT2UT(i);
  AddType('PChar', btPChar);
  AddType('Variant', btVariant);
  TIFPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('VARIANT');

  with AddFunction('function Assigned(I: Longint): Boolean;') do
  begin
    Name := '!ASSIGNED';
  end;
end;

procedure TIFPSPascalCompiler.UpdateRecordFields(r: TIFPSType);
var
  I: Longint;
  s: string;
begin
  if r.BaseType = btProcPtr then
  begin
    s := TIFPSProceduralType(r).ProcDef;
    ReplaceTypes(s);
    TIFPSProceduralType(r).ProcDef := s;
  end else if TIFPSType(r).BaseType = btRecord then
  begin
    for I := 0 to TIFPSRecordType(r).RecValCount - 1 do
      TIFPSRecordType(r).RecVal(I).FType := AT2UT(TIFPSRecordType(r).RecVal(I).FType);
  end
  else if (TIFPSType(r).BaseType = btArray) or (TIFPSType(r).BaseType = btStaticArray) then
  begin
    if TIFPSArrayType(r).FArrayTypeNo <> InvalidVal then
      TIFPSArrayType(r).FArrayTypeNo := AT2UT(TIFPSArrayType(r).FArrayTypeNo);
  end;
end;


function TIFPSPascalCompiler.FindType(const Name: string): Cardinal;
var
  i, n: Longint;
  p: TIFPSType;
  RName: string;
begin
  if FProcs = nil then begin Result := InvalidVal; exit;end;
  RName := Fastuppercase(Name);
  n := makehash(rname);
  for i := 0 to FAvailableTypes.Count - 1 do
  begin
    p := FAvailableTypes[I];
    if (p.NameHash = n) and (p.name = rname) then
    begin
      result := I;
      exit;
    end;
  end;
  result := InvalidVal;
end;

function TIFPSPascalCompiler.AddConstant(const Name: string; FType: Cardinal): TIFPSConstant;
var
  pc: TIFPSConstant;
  val: PIfRVariant;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');

  FType := GetTypeCopyLinkInt(FType);
  if FType = InvalidVal then
    Raise EIFPSCompilerException.Create('Unable to register constant '+name);
  pc := TIFPSConstant.Create;
  pc.Name := FastUppercase(name);
  New(Val);
  InitializeVariant(FAvailableTypes, Val, FType, TIFPSType(FAvailableTypes[FType]).BaseType);
  pc.Value := Val;
  FConstants.Add(pc);
  result := pc;
end;

type
  TConstOperation = class(TObject)
  private
    FDeclPosition, FDeclRow, FDeclCol: Cardinal;
  public
    property DeclPosition: Cardinal read FDeclPosition write FDeclPosition;
    property DeclRow: Cardinal read FDeclRow write FDeclRow;
    property DeclCol: Cardinal read FDeclCol write FDeclCol;
    procedure SetPos(Parser: TIfPascalParser);
  end;

  TUnConstOperation = class(TConstOperation)
  private
    FOpType: TIFPSUnOperatorType;
    FVal1: TConstOperation;
  public
    property OpType: TIFPSUnOperatorType read FOpType write FOpType;
    property Val1: TConstOperation read FVal1 write FVal1;

    destructor Destroy; override;
  end;

  TBinConstOperation = class(TConstOperation)
  private
    FOpType: TIFPSBinOperatorType;
    FVal2: TConstOperation;
    FVal1: TConstOperation;
  public
    property OpType: TIFPSBinOperatorType read FOpType write FOpType;
    property Val1: TConstOperation read FVal1 write FVal1;
    property Val2: TConstOperation read FVal2 write FVal2;

    destructor Destroy; override;
  end;

  TConstData = class(TConstOperation)
  private
    FData: PIfRVariant;
  public
    property Data: PIfRVariant read FData write FData;
    destructor Destroy; override;
  end;

function TIFPSPascalCompiler.ReadConstant(FParser: TIfPascalParser; StopOn: TIfPasToken): PIfRVariant;

  function ReadExpression: TConstOperation; forward;
  function ReadTerm: TConstOperation; forward;
  function ReadFactor: TConstOperation;
  var
    NewVar: TConstOperation;
    NewVarU: TUnConstOperation;
    function ReadString: PIfRVariant;
    {$IFNDEF IFPS3_NOWIDESTRING}var wchar: Boolean;{$ENDIF}

      function ParseString: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};
      var
        temp3: {$IFNDEF IFPS3_NOWIDESTRING}widestring{$ELSE}string{$ENDIF};

        function ChrToStr(s: string): {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF};
        var
          w: Longint;
        begin
          Delete(s, 1, 1); {First char : #}
          w := StrToInt(s);
          Result := {$IFNDEF IFPS3_NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w);
          {$IFNDEF IFPS3_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
        end;

        function PString(s: string): string;
        begin
          s := copy(s, 2, Length(s) - 2);
          PString := s;
        end;
      begin
        temp3 := '';
        while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
        begin
          if FParser.CurrTokenId = CSTI_String then
          begin
            temp3 := temp3 + PString(FParser.GetToken);
            FParser.Next;
            if FParser.CurrTokenId = CSTI_String then
              temp3 := temp3 + #39;
          end {if}
          else
          begin
            temp3 := temp3 + ChrToStr(FParser.GetToken);
            FParser.Next;
          end; {else if}
        end; {while}
        ParseString := temp3;
      end;
    {$IFNDEF IFPS3_NOWIDESTRING}
    var
      w: widestring;
      s: string;
    begin
      w := ParseString;
      if wchar then
      begin
        New(Result);
        if Length(w) = 1 then
        begin
          InitializeVariant(FAvailableTypes, Result, GetType(False, btwidechar), btWideChar);
          Result^.twidechar := w[1];
        end else begin
          InitializeVariant(FAvailableTypes, Result, GetType(False, btwidestring), btWidestring);
          tbtwidestring(result^.twidestring) := w;
        end;
      end else begin
        s := w;
        New(Result);
        if Length(s) = 1 then
        begin
          InitializeVariant(FAvailableTypes, Result, GetType(False, btChar), btChar);
          Result^.tchar := s[1];
        end else begin
          InitializeVariant(FAvailableTypes, Result, GetType(False, btstring), btstring);
          tbtstring(Result^.tstring) := s;
        end;
      end;
    end;
    {$ELSE}
    var
      s: string;
    begin
      s := ParseString;
      New(Result);
      if Length(s) = 1 then
      begin
        InitializeVariant(FAvailableTypes, Result, GetType(true, btChar), btChar);
        Result^.tchar := s[1];
      end else begin
        InitializeVariant(FAvailableTypes, Result, GetType(true, btstring), btstring);
        tbtstring(Result^.tstring) := s;
      end;
    end;
    {$ENDIF}
    function GetConstantIdentifier: PIfRVariant;
    var
      s: string;
      sh: Longint;
      i: Longint;
      p: TIFPSConstant;
    begin
      s := FParser.GetToken;
      sh := MakeHash(s);
      for i := FConstants.Count -1 downto 0 do
      begin
        p := FConstants[I];
        if (p.NameHash = sh) and (p.Name = s) then
        begin
          New(Result);
          InitializeVariant(FAvailableTypes, Result, p.Value.FType, p.Value.BaseType);
          CopyVariantContents(P.Value, Result);
          FParser.Next;
          exit;
        end;
      end;
      MakeError('', ecUnknownIdentifier, '');
      Result := nil;
    end;
  function ReadReal(const s: string): PIfRVariant;
  var
    C: Integer;
  begin
    New(Result);
    InitializeVariant(FAvailableTypes, Result, GetType(False, btExtended), btExtended);
    System.Val(s, Result^.textended, C);
  end;
    function ReadInteger(const s: string): PIfRVariant;
    {$IFNDEF IFPS3_NOINT64}
    var
      R: Int64;
    begin
      r := StrToInt64Def(s, 0);
      New(Result);
      if (r >= High(Longint)) or (r <= Low(Longint))then
      begin
        InitializeVariant(FAvailableTypes, Result, GetType(False, bts32), bts32);
        Result^.ts32 := r;
      end else
      begin
        InitializeVariant(FAvailableTypes, Result, GetType(False, bts64), bts64);
        Result^.ts64 := r;
      end;
    end;
    {$ELSE}
    var
      r: Longint;
    begin
      r := StrToIntDef(s, 0);
      New(Result);
      InitializeVariant(FAvailableTypes, Result, GetType(true, bts32), bts32);
      Result^.ts32 := r;
    end;
    {$ENDIF}
  begin
    case fParser.CurrTokenID of
      CSTII_Not:
      begin
        FParser.Next;
        NewVar := ReadFactor;
        if NewVar = nil then
        begin
          Result := nil;
          exit;
        end;
        NewVarU := TUnConstOperation.Create;
        NewVarU.OpType := otNot;
        NewVarU.Val1 := NewVar;
        NewVar := NewVarU;
      end;
      CSTI_Minus:
      begin
        FParser.Next;
        NewVar := ReadTerm;
        if NewVar = nil then
        begin
          Result := nil;
          exit;
        end;
        NewVarU := TUnConstOperation.Create;
        NewVarU.OpType := otMinus;
        NewVarU.Val1 := NewVar;
        NewVar := NewVarU;
      end;
      CSTI_OpenRound:
        begin
          FParser.Next;
          NewVar := ReadExpression;
          if NewVar = nil then
          begin
            Result := nil;
            exit;
          end;
          if FParser.CurrTokenId <> CSTI_CloseRound then
          begin
            NewVar.Free;
            Result := nil;
            MakeError('', ecCloseRoundExpected, '');
            exit;
          end;
          FParser.Next;
        end;
      CSTI_Char, CSTI_String:
        begin
          NewVar := TConstData.Create;
          NewVar.SetPos(FParser);
          TConstData(NewVar).Data := ReadString;
        end;
      CSTI_HexInt, CSTI_Integer:
        begin
          NewVar := TConstData.Create;
          NewVar.SetPos(FParser);
          TConstData(NewVar).Data := ReadInteger(FParser.GetToken);
          FParser.Next;
        end;
      CSTI_Real:
        begin
          NewVar := TConstData.Create;
          NewVar.SetPos(FParser);
          TConstData(NewVar).Data := ReadReal(FParser.GetToken);
          FParser.Next;
        end;
      CSTI_Identifier:
        begin
          NewVar := TConstData.Create;
          NewVar.SetPos(FParser);
          TConstData(NewVar).Data := GetConstantIdentifier;
          if TConstData(NewVar).Data = nil then
          begin
            NewVar.Free;
            Result := nil;
            exit;
          end
        end;
    else
      begin
        MakeError('', ecSyntaxError, '');
        Result := nil;
        exit;
      end;
    end; {case}
    Result := NewVar;
  end; // ReadFactor

  function ReadTerm: TConstOperation;
  var
    F1, F2: TConstOperation;
    F: TBinConstOperation;
    Token: TIfPasToken;
    Op: TIFPSBinOperatorType;
  begin
    F1 := ReadFactor;
    if F1 = nil then
    begin
      Result := nil;
      exit;
    end;
    while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do
    begin
      Token := FParser.CurrTokenID;
      FParser.Next;
      F2 := ReadFactor;
      if f2 = nil then
      begin
        f1.Free;
        Result := nil;
        exit;
      end;
      case Token of
        CSTI_Multiply: Op := otMul;
        CSTII_div, CSTI_Divide: Op := otDiv;
        CSTII_mod: Op := otMod;
        CSTII_and: Op := otAnd;
        CSTII_shl: Op := otShl;
        CSTII_shr: Op := otShr;
      else
        Op := otAdd;
      end;
      F := TBinConstOperation.Create;
      f.Val1 := F1;
      f.Val2 := F2;
      f.OpType := Op;
      f1 := f;
    end;
    Result := F1;
  end;  // ReadTerm

  function ReadSimpleExpression: TConstOperation;
  var
    F1, F2: TConstOperation;
    F: TBinConstOperation;
    Token: TIfPasToken;
    Op: TIFPSBinOperatorType;
  begin
    F1 := ReadTerm;
    if F1 = nil then
    begin
      Result := nil;
      exit;
    end;
    while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
    begin
      Token := FParser.CurrTokenID;
      FParser.Next;
      F2 := ReadTerm;
      if f2 = nil then
      begin
        f1.Free;
        Result := nil;
        exit;
      end;
      case Token of
        CSTI_Plus: Op := otAdd; 
        CSTI_Minus: Op := otSub;
        CSTII_or: Op := otOr;
        CSTII_xor: Op := otXor;
      else
        Op := otAdd;
      end;
      F := TBinConstOperation.Create;
      f.Val1 := F1;
      f.Val2 := F2;
      f.OpType := Op;
      f1 := f;
    end;
    Result := F1;
  end;  // ReadSimpleExpression


  function ReadExpression: TConstOperation;
  var
    F1, F2: TConstOperation;
    F: TBinConstOperation;
    Token: TIfPasToken;
    Op: TIFPSBinOperatorType;
  begin
    F1 := ReadSimpleExpression;
    if F1 = nil then
    begin
      Result := nil;
      exit;
    end;
    while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do
    begin
      Token := FParser.CurrTokenID;
      FParser.Next;
      F2 := ReadSimpleExpression;
      if f2 = nil then
      begin
        f1.Free;
        Result := nil;
        exit;
      end;
      case Token of
        CSTI_GreaterEqual: Op := otGreaterEqual;
        CSTI_LessEqual: Op := otLessEqual;
        CSTI_Greater: Op := otGreater;
        CSTI_Less: Op := otLess;
        CSTI_Equal: Op := otEqual;
        CSTI_NotEqual: Op := otNotEqual; 
      else
        Op := otAdd;
      end;
      F := TBinConstOperation.Create;
      f.Val1 := F1;
      f.Val2 := F2;
      f.OpType := Op;
      f1 := f;
    end;
    Result := F1;
  end;  // ReadExpression


  function EvalConst(P: TConstOperation): PIfRVariant;
  var
    p1, p2: PIfRVariant;
  begin
    if p is TBinConstOperation then
    begin
      p1 := EvalConst(TBinConstOperation(p).Val1);
      if p1 = nil then begin Result := nil; exit; end;
      p2 := EvalConst(TBinConstOperation(p).Val2);
      if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end;
      if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then
      begin
        DisposeVariant(p1);
        DisposeVariant(p2);
//        MakeError('', ecTypeMismatch, '');
        result := nil;
        exit;
      end;
      DisposeVariant(p2);
      Result := p1;
    end else if p is TUnConstOperation then
    begin
      with TUnConstOperation(P) do
      begin
        p1 := EvalConst(Val1);
        case OpType of
          otNot:
            case p1.BaseType of
              btU8: p1.tu8 := not p1.tu8;
              btU16: p1.tu16 := not p1.tu16;
              btU32: p1.tu32 := not p1.tu32;
              bts8: p1.ts8 := not p1.ts8;
              bts16: p1.ts16 := not p1.ts16;
              bts32: p1.ts32 := not p1.ts32;
              {$IFNDEF IFPS3_NOINT64}
              bts64: p1.ts64 := not p1.ts64;
              {$ENDIF}
            else
              begin
                MakeError('', ecTypeMismatch, '');
                DisposeVariant(p1);
                Result := nil;
                exit;
              end;
            end;
          otMinus:
            case p1.BaseType of
              btU8: p1.tu8 := -p1.tu8;
              btU16: p1.tu16 := -p1.tu16;
              btU32: p1.tu32 := -p1.tu32;
              bts8: p1.ts8 := -p1.ts8;
              bts16: p1.ts16 := -p1.ts16;
              bts32: p1.ts32 := -p1.ts32;
              {$IFNDEF IFPS3_NOINT64}
              bts64: p1.ts64 := -p1.ts64;
              {$ENDIF}
            else
              begin
                MakeError('', ecTypeMismatch, '');
                DisposeVariant(p1);
                Result := nil;
                exit;
              end;
            end;
        else
          begin
            DisposeVariant(p1);
            Result := nil;
            exit;
          end;
        end;
      end;
      Result := p1;
    end else
    begin
      New(p1);
      InitializeVariant(FAvailableTypes, p1, (p as TConstData).Data.FType,(p as TConstData).Data.BaseType);
      CopyVariantContents((p as TConstData).Data, p1);
      Result := p1;
    end;
  end;

var
  Val: TConstOperation;
begin
  Val := ReadExpression;
  if val = nil then
  begin
    Result := nil;
    exit;
  end;
  Result := EvalConst(Val);
  Val.Free;
end;

procedure TIFPSPascalCompiler.WriteDebugData(const s: string);
begin
  FDebugOutput := FDebugOutput + s;
end;

function TIFPSPascalCompiler.GetDebugOutput(var s: string): Boolean;
begin
  if Length(FDebugOutput) <> 0 then
  begin
    s := FDebugOutput;
    Result := True;
  end
  else
    Result := False;
end;

function TIFPSPascalCompiler.AddUsedFunction(var Proc: TIFPSInternalProcedure): Cardinal;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Proc := TIFPSInternalProcedure.Create;
  FProcs.Add(Proc);
  Result := FProcs.Count - 1;
end;

function TIFPSPascalCompiler.GetAvailableType(No: Cardinal): TIFPSType;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Result := FAvailableTypes[No];
end;

function TIFPSPascalCompiler.GetAvailableTypeCount: Cardinal;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Result := FAvailableTypes.Count;
end;


function TIFPSPascalCompiler.GetUsedType(No: Cardinal): TIFPSType;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Result := FUsedTypes[No];
end;

function TIFPSPascalCompiler.GetUsedTypeCount: Cardinal;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Result := FUsedTypes.Count;
end;

function TIFPSPascalCompiler.UseAvailableType(No: Cardinal): Cardinal;
var
  I: Longint;
  p: TIFPSType;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  p := FAvailableTypes[No];
  if p = nil then
  begin
    Result := InvalidVal;
    Exit;
  end;

  for I := 0 to FUsedTypes.Count - 1 do
  begin
    if FUsedTypes[I] = p then
    begin
      Result := I;
      exit;
    end;
  end;
  UpdateRecordFields(p);
  FUsedTypes.Add(p);
  Result := FUsedTypes.Count - 1;
end;

procedure TIFPSPascalCompiler.DefineStandardProcedures;
var
  p: TIFPSRegProc;
begin
  AddFunction('function inttostr(i: Longint): string;');
  AddFunction('function strtoint(s: string): Longint;');
  AddFunction('function strtointdef(s: string; def: Longint): Longint;');
  AddFunction('function copy(s: string; ifrom, icount: Longint): string;');
  AddFunction('function pos(substr, s: string): Longint;');
  AddFunction('procedure delete(var s: string; ifrom, icount: Longint);');
  AddFunction('procedure insert(s: string; var s2: string; ipos: Longint);');
  p := AddFunction('function getarraylength: integer;');
  p.Decl := p.Decl + ' !V -1';
  p := AddFunction('procedure setarraylength;');
  p.Decl := p.Decl + ' !V -1 @LENGTH '+IntToStr(Longint(FindType('INTEGER')));
  AddFunction('Function StrGet(var S : String; I : Integer) : Char;');
  AddFunction('procedure StrSet(c : Char; I : Integer; var s : String);');
  AddFunction('Function AnsiUppercase(s : string) : string;');
  AddFunction('Function AnsiLowercase(s : string) : string;');
  AddFunction('Function Uppercase(s : string) : string;');
  AddFunction('Function Lowercase(s : string) : string;');
  AddFunction('Function Trim(s : string) : string;');
  AddFunction('Function Length(s : String) : Longint;');
  AddFunction('procedure SetLength(var S: String; L: Longint);');
  AddFunction('Function Sin(e : Extended) : Extended;');
  AddFunction('Function Cos(e : Extended) : Extended;');
  AddFunction('Function Sqrt(e : Extended) : Extended;');
  AddFunction('Function Round(e : Extended) : Longint;');
  AddFunction('Function Trunc(e : Extended) : Longint;');
  AddFunction('Function Int(e : Extended) : Extended;');
  AddFunction('Function Pi : Extended;');
  AddFunction('Function Abs(e : Extended) : Extended;');
  AddFunction('function StrToFloat(s: string): Extended;');
  AddFunction('Function FloatToStr(e : Extended) : String;');
  AddFunction('Function Padl(s : string;I : longInt) : string;');
  AddFunction('Function Padr(s : string;I : longInt) : string;');
  AddFunction('Function Padz(s : string;I : longInt) : string;');
  AddFunction('Function Replicate(c : char;I : longInt) : string;');
  AddFunction('Function StringOfChar(c : char;I : longInt) : string;');
  AddTypeS('TVarType', '(vtNull, vtString, vtU64, vtS32, vtU32, vtS16, vtU16, vtS8, vtU8, vtSingle, vtDouble, vtExtended, vtResourcePointer, vtArray, vtRecord, vtChar, vtWideString, vtWideChar)');
  AddFunction('function VarGetType(x: Variant): TVarType;');
  AddFunction('function Null: Variant;');

  addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange, '+
    'ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException, erNullPointerException, erNullVariantError, erCustomError)');

  AddFunction('procedure RaiseLastException;');
  AddFunction('procedure RaiseException(Ex: TIFException; Param: string);');
  AddFunction('function ExceptionType: TIFException;');
  AddFunction('function ExceptionParam: string;');
  AddFunction('function ExceptionProc: Cardinal;');
  AddFunction('function ExceptionPos: Cardinal;');
  AddFunction('function ExceptionToString(er: TIFException; Param: string): string;');
  {$IFNDEF IFPS3_NOINT64}
  AddFunction('function StrToInt64(s: string): int64;');
  AddFunction('function Int64ToStr(i: Int64): string;');
  {$ENDIF}
end;

function TIFPSPascalCompiler.AddUsedFunction2(var Proc: TIFPSExternalProcedure): Cardinal;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Proc := TIFPSExternalProcedure.Create;
  FProcs.Add(Proc);
  Result := FProcs.Count -1;
end;

function TIFPSPascalCompiler.AddVariable(const Name: string; FType: Cardinal): TIFPSVar;
var
  P: TIFPSVar;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  if FType = InvalidVal then raise EIFPSCompilerException.Create('Invalid type');
  p := TIFPSVar.Create;
  p.Name := Fastuppercase(Name);
  p.FType := AT2UT(FType);
  if p <> nil then
    p.exportname := FastUppercase(Name);
  FVars.Add(p);
  Result := P;
end;


procedure TIFPSPascalCompiler.AddToFreeList(Obj: TObject);
begin
  FAutoFreeList.Add(Obj);
end;

function TIFPSPascalCompiler.AddConstantN(const Name,
  FType: string): TIFPSConstant;
var
  L: Cardinal;
begin
  L := FindType(FType);
  if l = InvalidVal then
    Raise EIFPSCompilerException.Create('Unable to register constant '+name)
  else
    Result := AddConstant(Name, L);
end;

function TIFPSPascalCompiler.AddTypeCopy(const Name: string;
  TypeNo: Cardinal): TIFPSType;
var
  b: TIFPSType;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  b := FAvailableTypes[TypeNo];
  if b.BaseType = btTypeCopy then TypeNo := TIFPSTypeLink(b).FLinkTypeNo;

  Result := AddType(Name, BtTypeCopy);
  TIFPSTypeLink(Result).LinkTypeNo := TypeNo;
end;

function TIFPSPascalCompiler.AddTypeCopyN(const Name,
  FType: string): TIFPSType;
var
  L: Cardinal;
begin
  L := FindType(FType);
  if L = InvalidVal then
    Raise EIFPSCompilerException.Create('Unable to register type '+name)
  else
    Result := AddTypeCopy(Name, L);
end;


function TIFPSPascalCompiler.AddUsedVariable(const Name: string;
  FType: Cardinal): TIFPSVar;
begin
  Result := AddVariable(Name, FType);
  if Result <> nil then
    Result.Use;
end;

function TIFPSPascalCompiler.AddUsedVariableN(const Name,
  FType: string): TIFPSVar;
begin
  Result := AddVariable(Name, FindType(FType));
  if Result <> nil then
    Result.Use;
end;

function TIFPSPascalCompiler.AddVariableN(const Name,
  FType: string): TIFPSVar;
begin
  Result := AddVariable(Name, FindType(FType));
end;

function TIFPSPascalCompiler.AddTypeS(const Name, Decl: string): TIFPSType;
var
  Parser: TIfPascalParser;
begin
  if FProcs = nil then raise EIFPSCompilerException.Create('This function can only be called from within the OnUses event');
  Parser := TIfPascalParser.Create;
  Parser.SetText(Decl);
  Result := FAvailableTypes[ReadType(Name, Parser)];
  Parser.Free;
  if result = nil then Raise EIFPSCompilerException.Create('Unable to register type '+name);
end;


function TIFPSPascalCompiler.CheckCompatProc(P: TIFPSType; ProcNo: Cardinal): Boolean;
var
  s1,s2: string;
  function c(const e1,e2: string): Boolean;
  begin
    Result := (Length(e1) = 0) or (Length(e2) = 0) or (e1[1] <> e2[1]);
  end;
begin
  if p.BaseType <> btProcPtr then begin
    Result := False;
    Exit;
  end;

  S1 := TIFPSProceduralType(p).ProcDef;

  if TIFPSProcedure(FProcs[ProcNo]).ClassType = TIFPSInternalProcedure then
    s2 := TIFPSInternalProcedure(FProcs[ProcNo]).Decl
  else
    s2 := TIFPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
  if GRFW(s1) <> GRFW(s2) then begin
    Result := False;
    Exit;
  end;
  while Length(s1) > 0 do
  begin
    if c(GRFW(s1), GRFW(s2)) or (GRFW(s1) <> GRFW(s2)) then begin
      Result := False;
      Exit;
    end;
  end;
  Result := True;
end;

function TIFPSPascalCompiler.MakeExportDecl(decl: string): string;
var
  c: char;
begin
  result := grfw(decl);
  while length(decl) > 0 do
  begin
    c := grfw(decl)[1];
    result := result +' '+c+grfw(decl);
  end;
end;


function TIFPSPascalCompiler.IsIntBoolType(FTypeNo: Cardinal): Boolean;
var
  f: TIFPSType;
begin
  if FTypeNo = at2ut(FBooleanType) then begin Result := True; exit;end;
  f := FUsedTypes[FTypeNo];
  
  case f.BaseType of
    btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF IFPS3_NOINT64}, btS64{$ENDIF}: Result := True;
  else
    Result := False;
  end;
end;


procedure TIFPSPascalCompiler.ParserError(Parser: TObject;
  Kind: TIFParserErrorKind);
begin
  case Kind of
    ICOMMENTERROR: MakeError('', ecCommentError, '');
    ISTRINGERROR: MakeError('', ecStringError, '');
    ICHARERROR: MakeError('', ecCharError, '');
  else
    MakeError('', ecSyntaxError, '');
  end;
end;

function TIFPSPascalCompiler.GetTypeCopyLinkInt(L: Cardinal): Cardinal;
var
  p: TIFPSType;
  i: Longint;
begin
  p := FAvailableTypes[l];
  if p = nil then
  begin
    Result := InvalidVal;
    exit;
  end;
  p := GetTypeCopyLink(p);
  for i := 0 to FAvailableTypes.Count -1 do
  begin
    if FAvailableTypes[I] = p then
    begin
      Result := i;
      exit;
    end;
  end;
  Result := InvalidVal;
end;

function TIFPSPascalCompiler.AddDelphiFunction(const Decl: string): TIFPSRegProc;
var
  p: TIFPSRegProc;
  DName, s: string;
  FT: TPMFuncType;

begin
  if not ParseMethod(Self, '', Decl, DName, s, FT) then
    Raise EIFPSCompilerException.Create('Unable to register function '+Decl);

  p := TIFPSRegProc.Create;
  P.Name := DName;
  p.ExportName := True;
  p.Decl := s;

  FRegProcs.Add(p);

  if GRFW(s) = '-1' then
  begin
    p.ImportDecl := p.ImportDecl + #0;
  end else
    p.ImportDecl := p.ImportDecl + #1;
  while length(s) > 0 do
  begin
    if s[1] = '!' then
      p.ImportDecl := p.ImportDecl + #1
    else
      p.ImportDecl := p.ImportDecl + #0;
    grfw(s);
    grfw(s);
  end;
  p.ExportName := True;
  Result := p;
end;

function TIFPSPascalCompiler.AddClass(InheritsFrom: TIFPSCompileTimeClass; aClass: TClass): TIFPSCompileTimeClass;
var
  f: TIFPSType;
begin
  Result := FindClass(aClass.ClassName);
  if Result <> nil then exit;
  Result := TIFPSCompileTimeClass.Create(aClass, Self);
  Result.FInheritsFrom := InheritsFrom;
  FClasses.Add(Result);
  f := AddType(Result.FClassName, btClass);
  TIFPSClassType(f).ClassHelper := TIFPSDelphiClass.Create(Result, FAvailableTypes.Count -1);
  f.ExportName := True;
end;

function TIFPSPascalCompiler.AddClassN(InheritsFrom: TIFPSCompileTimeClass; const aClass: string): TIFPSCompileTimeClass;
var
  f: TIFPSType;
begin
  Result := FindClass(aClass);
  if Result <> nil then exit; 
  Result := TIFPSCompileTimeClass.Create2(aClass, Self);
  Result.FInheritsFrom := InheritsFrom;
  FClasses.Add(Result);
  f := AddType(Result.FClassName, btClass);
  TIFPSClassType(f).ClassHelper := TIFPSDelphiClass.Create(Result, FAvailableTypes.Count -1);
  f.ExportName := True;
end;

function TIFPSPascalCompiler.FindClass(const aClass: string): TIFPSCompileTimeClass;
var
  i: Longint;
  Cl: string;
  H: Longint;
  x: TIFPSCompileTimeClass;
begin
  cl := FastUpperCase(aClass);
  H := MakeHash(Cl);
  for i :=0 to FClasses.Count -1 do
  begin
    x := FClasses[I];
    if (X.FClassNameHash = H) and (X.FClassName = Cl) then
    begin
      Result := X;
      Exit;
    end;
  end;
  Result := nil;
end;


{ TIFPSExternalClass }
function TIFPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.ClassFunc_Call(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.ClassFunc_Find(const Name: string;
  var Index: Cardinal): Boolean;
begin
  Result := False;
end;

constructor TIFPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: Cardinal);
begin
  inherited Create;
  Self.SE := se;
  Self.FTypeNo := TypeNo;
end;

function TIFPSExternalClass.Func_Call(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.Func_Find(const Name: string;
  var Index: Cardinal): Boolean;
begin
  Result := False;
end;


function TIFPSExternalClass.IsCompatibleWith(
  Cl: TIFPSExternalClass): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.Property_Find(const Name: string;
  var Index: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.Property_Get(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;


function TIFPSExternalClass.Property_GetHeader(Index: Cardinal;
  var s: string): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.Property_Set(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.SelfType: Cardinal;
begin
  Result := InvalidVal;
end;

function TIFPSExternalClass.CastToType(IntoType: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.CompareClass(OtherTypeNo: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := false;
end;

{  }

function TransDoubleToStr(D: Double): string;
begin
  SetLength(Result, SizeOf(Double));
  Double((@Result[1])^) := D;
end;

function TransSingleToStr(D: Single): string;
begin
  SetLength(Result, SizeOf(Single));
  Single((@Result[1])^) := D;
end;

function TransExtendedToStr(D: Extended): string;
begin
  SetLength(Result, SizeOf(Extended));
  Extended((@Result[1])^) := D;
end;

function TransLongintToStr(D: Longint): string;
begin
  SetLength(Result, SizeOf(Longint));
  Longint((@Result[1])^) := D;
end;

function TransCardinalToStr(D: Cardinal): string;
begin
  SetLength(Result, SizeOf(Cardinal));
  Cardinal((@Result[1])^) := D;
end;

function TransWordToStr(D: Word): string;
begin
  SetLength(Result, SizeOf(Word));
  Word((@Result[1])^) := D;
end;

function TransSmallIntToStr(D: SmallInt): string;
begin
  SetLength(Result, SizeOf(SmallInt));
  SmallInt((@Result[1])^) := D;
end;

function TransByteToStr(D: Byte): string;
begin
  SetLength(Result, SizeOf(Byte));
  Byte((@Result[1])^) := D;
end;

function TransShortIntToStr(D: ShortInt): string;
begin
  SetLength(Result, SizeOf(ShortInt));
  ShortInt((@Result[1])^) := D;
end;

function TIFPSExternalClass.CastToTypeAS(IntoType: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

function TIFPSExternalClass.CastToTypeIS(IntoType: Cardinal;
  var ProcNo: Cardinal): Boolean;
begin
  Result := False;
end;

{ TIFPSType }

procedure TIFPSType.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(Value);
end;

procedure TIFPSType.Use;
begin
  FUsed := True;
end;

{ TIFPSRecordType }

function TIFPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef;
begin
  Result := TIFPSRecordFieldTypeDef.Create;
  FRecordSubVals.Add(Result);
end;

constructor TIFPSRecordType.Create;
begin
  inherited Create;
  FRecordSubVals := TIfList.Create;
end;

destructor TIFPSRecordType.Destroy;
var
  i: Longint;
begin
  for i := FRecordSubVals.Count -1 downto 0 do
    TIFPSRecordFieldTypeDef(FRecordSubVals[I]).Free;
  FRecordSubVals.Free;
  inherited Destroy;
end;

function TIFPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
begin
  Result := FRecordSubVals[I]
end;

function TIFPSRecordType.RecValCount: Longint;
begin
  Result := FRecordSubVals.Count;
end;


{ TIFPSRegProc }

procedure TIFPSRegProc.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(FName);
end;

{ TIFPSRecordFieldTypeDef }

procedure TIFPSRecordFieldTypeDef.SetFieldName(const Value: string);
begin
  FFieldName := Value;
  FFieldNameHash := MakeHash(FFieldName);
end;

{ TIFPSProcVar }

procedure TIFPSProcVar.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(FName);
end;

procedure TIFPSProcVar.Use;
begin
  FUsed := True;
end;



{ TIFPSInternalProcedure }

constructor TIFPSInternalProcedure.Create;
begin
  inherited Create;
  FProcVars := TIfList.Create;
  FLabels := TIfStringList.Create;
  FGotos := TIfStringList.Create;
end;

destructor TIFPSInternalProcedure.Destroy;
var
  i: Longint;
begin
  for i := FProcVars.Count -1 downto 0 do
    TIFPSProcVar(FProcVars[I]).Free;
  FProcVars.Free;
  FGotos.Free;
  FLabels.Free;
  inherited Destroy;
end;

procedure TIFPSInternalProcedure.ResultUse;
begin
  FResultUsed := True;
end;

procedure TIFPSInternalProcedure.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(FName);
end;

procedure TIFPSInternalProcedure.Use;
begin
  FUsed := True;
end;


{ TIFPSVar }

procedure TIFPSVar.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(Value);
end;

procedure TIFPSVar.Use;
begin
  FUsed := True;
end;

{ TIFPSConstant }

destructor TIFPSConstant.Destroy;
begin
  DisposeVariant(Value);
  inherited Destroy;
end;

procedure TIFPSConstant.SetChar(c: Char);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btChar: FValue.tchar := c;
      btString: string(FValue.tstring) := c;
      {$IFNDEF IFPS3_NOWIDESTRING}
      btWideString: widestring(FValue.twidestring) := c;
      {$ENDIF}
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;

procedure TIFPSConstant.SetExtended(const Val: Extended);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btSingle: FValue.tsingle := Val;
      btDouble: FValue.tdouble := Val;
      btExtended: FValue.textended := Val;
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;

procedure TIFPSConstant.SetInt(const Val: Longint);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btEnum: FValue.tu32 := Val;
      btU32, btS32: FValue.ts32 := Val;
      btU16, btS16: FValue.ts16 := Val;
      btU8, btS8: FValue.ts8 := Val;
      btSingle: FValue.tsingle := Val;
      btDouble: FValue.tdouble := Val;
      btExtended: FValue.textended := Val;
      {$IFNDEF IFPS3_NOINT64}
      bts64: FValue.ts64 := Val;
      {$ENDIF}
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;
{$IFNDEF IFPS3_NOINT64}
procedure TIFPSConstant.SetInt64(const Val: Int64);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btEnum: FValue.tu32 := Val;
      btU32, btS32: FValue.ts32 := Val;
      btU16, btS16: FValue.ts16 := Val;
      btU8, btS8: FValue.ts8 := Val;
      btSingle: FValue.tsingle := Val;
      btDouble: FValue.tdouble := Val;
      btExtended: FValue.textended := Val;
      bts64: FValue.ts64 := Val;
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;
{$ENDIF}
procedure TIFPSConstant.SetName(const Value: string);
begin
  FName := Value;
  FNameHash := MakeHash(Value);
end;


procedure TIFPSConstant.SetString(const Val: string);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btString: string(FValue.tstring) := val;
      {$IFNDEF IFPS3_NOWIDESTRING}
      btWideString: widestring(FValue.twidestring) := val;
      {$ENDIF}
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;

procedure TIFPSConstant.SetUInt(const Val: Cardinal);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btEnum: FValue.tu32 := Val;
      btU32, btS32: FValue.tu32 := Val;
      btU16, btS16: FValue.tu16 := Val;
      btU8, btS8: FValue.tu8 := Val;
      btSingle: FValue.tsingle := Val;
      btDouble: FValue.tdouble := Val;
      btExtended: FValue.textended := Val;
      {$IFNDEF IFPS3_NOINT64}
      bts64: FValue.ts64 := Val;
      {$ENDIF}
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;

{$IFNDEF IFPS3_NOWIDESTRING}
procedure TIFPSConstant.SetWideChar(const val: WideChar);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btString: string(FValue.tstring) := val;
      btWideChar: FValue.twidechar := val;
      btWideString: widestring(FValue.twidestring) := val;
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;

procedure TIFPSConstant.SetWideString(const val: WideString);
begin
  if (FValue <> nil) then
  begin
    case FValue.BaseType of
      btString: string(FValue.tstring) := val;
      btWideString: widestring(FValue.twidestring) := val;
    else
      raise EIFPSCompilerException.Create('Constant Value Type Mismatch');
    end;
  end else
    raise EIFPSCompilerException.Create('Constant Value is not assigned')
end;
{$ENDIF}
{ TIFPSPascalCompilerError }

function TIFPSPascalCompilerError.ErrorType: string;
begin
  Result := 'Error';
end;

function TIFPSPascalCompilerError.ShortMessageToString: string;
begin
  case Error of
    ecUnknownIdentifier: Result := 'Unknown identifier ''' + Param + '''';
    ecIdentifierExpected: Result := 'Identifier expected';
    ecCommentError: Result := 'Comment error';
    ecStringError: Result := 'String error';
    ecCharError: Result := 'Char error';
    ecSyntaxError: Result := 'Syntax error';
    ecUnexpectedEndOfFile: Result := 'Unexpected end of file';
    ecSemicolonExpected: Result := 'Semicolon ('';'') expected';
    ecBeginExpected: Result := '''BEGIN'' expected';
    ecPeriodExpected: Result := 'period (''.'') expected';
    ecDuplicateIdentifier: Result := 'Duplicate identifier ''' + Param + '''';
    ecColonExpected: Result := 'colon ('':'') expected';
    ecUnknownType: Result := 'Unknown type ''' + Param + '''';
    ecCloseRoundExpected: Result := 'Close round expected';
    ecTypeMismatch: Result := 'Type mismatch';
    ecInternalError: Result := 'Internal error (' + Param + ')';
    ecAssignmentExpected: Result := 'Assignment expected';
    ecThenExpected: Result := '''THEN'' expected';
    ecDoExpected: Result := '''DO'' expected';
    ecNoResult: Result := 'No result';
    ecOpenRoundExpected: Result := 'open round (''('')expected';
    ecCommaExpected: Result := 'comma ('','') expected';
    ecToExpected: Result := '''TO'' expected';
    ecIsExpected: Result := 'is (''='') expected';
    ecOfExpected: Result := '''OF'' expected';
    ecCloseBlockExpected: Result := 'Close block('']'') expected';
    ecVariableExpected: Result := 'Variable Expected';
    ecStringExpected: result := 'String Expected';
    ecEndExpected: Result := '''END'' expected';
    ecUnSetLabel: Result := 'Label '''+Param+''' not set';
    ecNotInLoop: Result := 'Not in a loop';
    ecInvalidJump: Result := 'Invalid jump';
    ecOpenBlockExpected: Result := 'Open Block (''['') expected';
    ecWriteOnlyProperty: Result := 'Write-only property';
    ecReadOnlyProperty: Result := 'Read-only property';
    ecClassTypeExpected: Result := 'Class type expected';
    ecCustomError: Result := Param;
    ecDivideByZero: Result := 'Divide by Zero';
    ecMathError:  Result := 'Math Error';
    ecUnsatisfiedForward: Result := 'Unsatisfied Forward '+ Param;
    ecForwardParameterMismatch: Result := 'Forward Parameter Mismatch';
  else
    Result := 'Unknown error';
  end;
  Result := Result;
end;


{ TIFPSPascalCompilerHint }

function TIFPSPascalCompilerHint.ErrorType: string;
begin
  Result := 'Hint';
end;

function TIFPSPascalCompilerHint.ShortMessageToString: string;
begin
  case Hint of
    ehVariableNotUsed: Result := 'Variable ''' + Param + ''' never used';
    ehFunctionNotUsed: Result := 'Function ''' + Param + ''' never used';
    ehCustomHint: Result := Param;
  else
    Result := 'Unknown hint';
  end;
end;

{ TIFPSPascalCompilerWarning }

function TIFPSPascalCompilerWarning.ErrorType: string;
begin
  Result := 'Warning';
end;

function TIFPSPascalCompilerWarning.ShortMessageToString: string;
begin
  case Warning of
    ewCustomWarning: Result := Param;
    ewCalculationAlwaysEvaluatesTo: Result := 'Calculation always evaluates to '+Param;
    ewIsNotNeeded: Result := Param +' is not needed';
  else
    Result := 'Unknown warning'; 
  end;
end;

{ TIFPSPascalCompilerMessage }

function TIFPSPascalCompilerMessage.MessageToString: string;
begin
  Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString; 
end;

procedure TIFPSPascalCompilerMessage.SetParserPos(Parser: TIfPascalParser);
begin
  FPosition := Parser.CurrTokenPos;
  FRow := Parser.Row;
  FCol := Parser.Col;
end;

procedure TIFPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal);
begin
  FPosition := Pos;
  FRow := Row;
  FCol := Col;
end;

{ TUnConstOperation }

destructor TUnConstOperation.Destroy;
begin
  FVal1.Free;
  inherited Destroy;
end;


{ TBinConstOperation }

destructor TBinConstOperation.Destroy;
begin
  FVal1.Free;
  FVal2.Free;
  inherited Destroy;
end;

{ TConstData }

destructor TConstData.Destroy;
begin
  DisposeVariant(FData);
  inherited Destroy;
end;


{ TConstOperation }

procedure TConstOperation.SetPos(Parser: TIfPascalParser);
begin
  FDeclPosition := Parser.CurrTokenPos;
  FDeclRow := Parser.Row;
  FDeclCol := Parser.Col;
end;

{ TIFPSValue }

procedure TIFPSValue.SetParserPos(P: TIfPascalParser);
begin
  FPos := P.CurrTokenPos;
  FRow := P.Row;
  FCol := P.Col;
end;

{ TIFPSValueData }

destructor TIFPSValueData.Destroy;
begin
  DisposeVariant(FData);
  inherited Destroy;
end;


{ TIFPSValueReplace }

constructor TIFPSValueReplace.Create;
begin
  FFreeNewValue := True;
  FReplaceTimes := 1;
end;

destructor TIFPSValueReplace.Destroy;
begin
  if FFreeOldValue then
    FOldValue.Free;
  if FFreeNewValue then
    FNewValue.Free;
  inherited Destroy;
end;



{ TIFPSUnValueOp }

destructor TIFPSUnValueOp.Destroy;
begin
  FVal1.Free;
  inherited Destroy;
end;

{ TIFPSBinValueOp }

destructor TIFPSBinValueOp.Destroy;
begin
  FVal1.Free;
  FVal2.Free;
  inherited Destroy;
end;




{ TIFPSSubValue }

destructor TIFPSSubValue.Destroy;
begin
  FSubNo.Free;
  inherited Destroy;
end;

{ TIFPSValueVar }

constructor TIFPSValueVar.Create;
begin
  inherited Create;
  FRecItems := TIfList.Create;
end;

destructor TIFPSValueVar.Destroy;
var
  i: Longint;
begin
  for i := 0 to FRecItems.Count -1 do
  begin
    TIFPSSubItem(FRecItems[I]).Free;
  end;
  FRecItems.Free;
  inherited Destroy;
end;

function TIFPSValueVar.GetRecCount: Cardinal;
begin
  Result := FRecItems.Count;
end;

function TIFPSValueVar.GetRecItem(I: Cardinal): TIFPSSubItem;
begin
  Result := FRecItems[I];
end;

function TIFPSValueVar.RecAdd(Val: TIFPSSubItem): Cardinal;
begin
  Result := FRecItems.Add(Val);
end;

procedure TIFPSValueVar.RecDelete(I: Cardinal);
var
  rr :TIFPSSubItem;
begin
  rr := FRecItems[i];
  FRecItems.Delete(I);
  rr.Free;
end;

{ TIFPSValueProc }

destructor TIFPSValueProc.Destroy;
begin
  FSelfPtr.Free;
  FParameters.Free;
end;
{ TIFPSParameter }

destructor TIFPSParameter.Destroy;
begin
  FTempVar.Free;
  FValue.Free;
  inherited Destroy;
end;


  { TIFPSParameters }

function TIFPSParameters.Add: TIFPSParameter;
begin
  Result := TIFPSParameter.Create;
  FItems.Add(Result);
end;

constructor TIFPSParameters.Create;
begin
  inherited Create;
  FItems := TIfList.Create;
end;

procedure TIFPSParameters.Delete(I: Cardinal);
var
  p: TIFPSParameter;
begin
  p := FItems[I];
  FItems.Delete(i);
  p.Free;
end;

destructor TIFPSParameters.Destroy;
var
  i: Longint;
begin
  for i := FItems.Count -1 downto 0 do
  begin
    TIFPSParameter(FItems[I]).Free;
  end;
  FItems.Free;
  inherited Destroy;
end;

function TIFPSParameters.GetCount: Cardinal;
begin
  Result := FItems.Count;
end;

function TIFPSParameters.GetItem(I: Longint): TIFPSParameter;
begin
  Result := FItems[I];
end;


{ TIFPSValueArray }

function TIFPSValueArray.Add(Item: TIFPSValue): Cardinal;
begin
  Result := FItems.Add(Item);
end;

constructor TIFPSValueArray.Create;
begin
  inherited Create;
  FItems := TIfList.Create;
end;

procedure TIFPSValueArray.Delete(I: Cardinal);
begin
  FItems.Delete(i);
end;

destructor TIFPSValueArray.Destroy;
var
  i: Longint;
begin
  for i := FItems.Count -1 downto 0 do
    TIFPSValue(FItems[I]).Free;
  FItems.Free;

  inherited Destroy;
end;

function TIFPSValueArray.GetCount: Cardinal;
begin
  Result := FItems.Count;
end;

function TIFPSValueArray.GetItem(I: Cardinal): TIFPSValue;
begin
  Result := FItems[I];
end;


{ TIFPSValueAllocatedStackVar }

destructor TIFPSValueAllocatedStackVar.Destroy;
var
  pv: TIFPSProcVar;
begin
  {$IFDEF DEBUG}
  if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then
  begin
    Abort;
    exit;
  end;
  {$ENDIF}
  if Proc <> nil then
  begin
    pv := Proc.ProcVars[Proc.ProcVars.Count -1];
    Proc.ProcVars.Delete(Proc.ProcVars.Count -1);
    pv.Free;
    Proc.Data := Proc.Data + Char(CM_PO);
  end;
  inherited Destroy;
end;




function AddImportedClassVariable(Sender: TIFPSPascalCompiler; const VarName, VarType: string): Boolean;
var
  P: TIFPSVar;
begin
  P := Sender.AddVariableN(VarName, VarType);
  if p = nil then
  begin
    Result := False;
    Exit;
  end;
  SetVarExportName(P, FastUppercase(VarName));
  p.Use;
  Result := True;
end;


{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params

For property write functions there is an '@' after the funcname.
}
type
  PClassItem = ^TClassItem;
  TClassItem = record
    Owner: TIFPSCompileTimeClass;
    Name: string;
    NameHash: Longint;
    FType: Byte; { 0 = method; 1 = property; 2 = constructor/class method }
    ProcDecl: string;
    PropAC: TIFPSPropType;
    case byte of
      0: (MethodProcNo: Cardinal);
      1: (PropReadProcNo, PropWriteProcNo: Cardinal);
  end;

{ TIFPSCompileTimeClass }

constructor TIFPSCompileTimeClass.Create(FClass: TClass; aOwner: TIFPSPascalCompiler);
begin
  inherited Create;
  FDefaultProperty := InvalidVal;
  FClassName := FastUppercase(FClass.ClassName);
  FClassNameHash := MakeHash(FClassName);
  FClassItems := TIfList.Create;
  Self.FClass := FClass;
  FOwner := aOwner;
end;

constructor TIFPSCompileTimeClass.Create2(ClassName: string; aOwner: TIFPSPascalCompiler);
begin
  inherited Create;
  FDefaultProperty := InvalidVal;
  FClassName := Classname;
  FClassNameHash := MakeHash(FClassName);
  FClassItems := TIfList.Create;
  FOwner := aOwner;
end;

destructor TIFPSCompileTimeClass.Destroy;
var
  I: Longint;
  P: PClassItem;
begin
  for i := FClassItems.Count -1 downto 0 do
  begin
    p := FClassItems[I];
    Dispose(P);
  end;
  FClassItems.Free;
  inherited Destroy;
end;


function TIFPSCompileTimeClass.RegisterMethod(const Decl: string): Boolean;
var
  DName,
  DDecl: string;
  FT: TPMFuncType;
  p: PClassItem;
begin
  if not ParseMethod(FOwner, FClassName, Decl, DName, DDecl, FT) then
  begin
    Result := False;
    {$IFDEF DEBUG} raise EIFPSCompilerException.Create('Unable to register '+Decl); {$ENDIF}
    exit;
  end;
  New(p);
  p^.Owner := Self;
  p^.Name := DName;
  p^.NameHash := MakeHash(DName);
  if FT = mftConstructor then
    p^.FType := 2
  else
    p^.FType := 0;
  p^.ProcDecl := DDecl;
  p^.MethodProcNo := InvalidVal;
  FClassItems.Add(p);
  Result := True;
end;

procedure TIFPSCompileTimeClass.RegisterProperty(const PropertyName,
  PropertyType: string; PropAC: TIFPSPropType);
var
  FType: Cardinal;
  p: PClassItem;
  PT, s: string;
begin
  pt := PropertyType;
  repeat
    FType := FOwner.FindType(FastUpperCase(grfw(pt)));
    if FType = InvalidVal then Exit;
    if s = '' then s := inttostr(ftype) else s := s + ' '+ inttostr(ftype);
  until pt = '';
  New(p);
  p^.Owner := Self;
  p^.Name := FastUppercase(PropertyName);
  p^.NameHash := MakeHash(p^.Name);
  p^.FType := 1;
  p^.PropAC := PropAC;
  p^.ProcDecl := s;
  p^.PropReadProcNo := InvalidVal;
  p^.PropWriteProcNo := InvalidVal;
  FClassItems.Add(p);
end;


procedure TIFPSCompileTimeClass.RegisterPublishedProperties;
var
  p: PPropList;
  i, Count: Longint;
  a: TIFPSPropType;
begin
  if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
  Count := GetTypeData(fclass.ClassInfo)^.PropCount;
  GetMem(p, Count * SizeOf(Pointer));
  GetPropInfos(fclass.ClassInfo, p);
  for i := Count -1 downto 0 do
  begin
    if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod] then
    begin
      if (p^[i]^.GetProc <> nil) then
      begin
        if p^[i]^.SetProc = nil then
          a := iptr
        else
          a := iptrw;
      end else
      begin
        a := iptW;
        if p^[i]^.SetProc = nil then continue;
      end;
      RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
    end;
  end;
  FreeMem(p);
end;

function TIFPSCompileTimeClass.RegisterPublishedProperty(const Name: string): Boolean;
var
  p: PPropInfo;
  a: TIFPSPropType;
begin
  if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
  p := GetPropInfo(fclass.ClassInfo, Name);
  if p = nil then begin Result := False; exit; end;
  if (p^.GetProc <> nil) then
  begin
    if p^.SetProc = nil then
      a := iptr
    else
      a := iptrw;
  end else
  begin
    a := iptW;
    if p^.SetProc = nil then begin result := False; exit; end;
  end;
  RegisterProperty(p^.Name, p^.PropType^.Name, a);
  Result := True;
end;


const
  IFPSClassType = '!IFPSClass';
  ProcHDR = 'procedure a;';

procedure TIFPSCompileTimeClass.SetDefaultPropery(const Name: string);
var
  i,h: Longint;
  p: PClassItem;
  s: string;

begin
  s := FastUppercase(name);
  h := MakeHash(s);
  for i := FClassItems.Count -1 downto 0 do
  begin
    p := FClassItems[i];
    if (p^.NameHash = h) and (p^.Name = s) then
    begin
      if p^.FType = 1 then
      begin
        if pos(' ', p^.ProcDecl) = 0 then
          Raise EIFPSCompilerException.Create('Not an array property');
        FDefaultProperty := I;
        exit;
      end else Raise EIFPSCompilerException.Create('Not a property');
    end;
  end;
  raise EIFPSCompilerException.Create('Unknown Property');
end;

{ TIFPSDelphiClass }

constructor TIFPSDelphiClass.Create(CE: TIFPSCompileTimeClass; TypeNo: Cardinal);
begin
  inherited Create(CE.FOwner, TypeNo);
  NilProcNo := InvalidVal;
  CastProcNo := InvalidVal;
  CompareProcNo := InvalidVal;

  Self.Ce := CE;
end;

function TIFPSDelphiClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
var
  C: PClassItem;
  P: TIFPSExternalProcedure;
  s, w, n: string;

begin
  C := Pointer(Index);
  if c^.MethodProcNo = InvalidVal then
  begin
    ProcNo := Se.AddUsedFunction2(P);
    P.RegProc := SE.AddFunction(ProcHDR);
    P.RegProc.Name := '';
    Se.ReplaceTypes(C^.ProcDecl);
    P.RegProc.Decl := c^.ProcDecl;
    s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
    w := C^.ProcDecl;
    if GRFW(w) = '-1' then
      s := s + #0
    else
      s := s + #1;
    while W <> '' do
    begin
      n := grfw(w);
      grfw(w);
      if (n <> '') and (n[1] = '!') then
        s := s + #1
      else
        s := s + #0;
    end;
    P.RegProc.ImportDecl := s;
    C^.MethodProcNo := ProcNo;
  end else begin
     ProcNo := c^.MethodProcNo;
  end;
  Result := True;
end;

function TIFPSDelphiClass.Func_Find(const Name: string; var Index: Cardinal): Boolean;
var
  H: Longint;
  I: Longint;
  CurrClass: TIFPSCompileTimeClass;
  C: PClassItem;
begin
  H := MakeHash(Name);
  CurrClass := Ce;
  while CurrClass <> nil do
  begin
    for i := CurrClass.FClassItems.Count -1 downto 0 do
    begin
      C := CurrClass.FClassItems[I];
      if (c^.Ftype = 0) and (C^.NameHash = H) and (C^.Name = Name) then
      begin
        Index := Cardinal(C);
        Result := True;
        exit;
      end;
    end;
    CurrClass := CurrClass.FInheritsFrom;
  end;
  Result := False;
end;

function TIFPSDelphiClass.Property_Find(const Name: string;
  var Index: Cardinal): Boolean;
var
  H: Longint;
  I: Longint;
  CurrClass: TIFPSCompileTimeClass;
  C: PClassItem;
begin
  if Name = '' then
  begin
    CurrClass := Ce;
    while CurrClass <> nil do
    begin
      if CurrClass.FDefaultProperty <> InvalidVal then
      begin
        Index := Cardinal(CurrClass.FClassItems[Currclass.FDefaultProperty]);
        result := True;
        exit;
      end;
      CurrClass := CurrClass.FInheritsFrom;
    end;
    Result := False;
    exit;
  end;
  H := MakeHash(Name);
  CurrClass := Ce;
  while CurrClass <> nil do
  begin
    for i := CurrClass.FClassItems.Count -1 downto 0 do
    begin
      C := CurrClass.FClassItems[I];
      if (c^.Ftype = 1) and (C^.NameHash = H) and (C^.Name = Name) then
      begin
        Index := Cardinal(C);
        Result := True;
        exit;
      end;
    end;
    CurrClass := CurrClass.FInheritsFrom;
  end;
  Result := False;
end;

function TIFPSDelphiClass.Property_Get(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  C: PClassItem;
  P: TIFPSExternalProcedure;
  w,s: string;
  i: Longint;

begin
  C := Pointer(Index);
  if c^.PropAC = iptW then
  begin
    Result := False;
    exit;
  end;
  if c^.PropReadProcNo = InvalidVal then
  begin
    ProcNo := Se.AddUsedFunction2(P);
    P.RegProc := SE.AddFunction(ProcHDR);
    P.RegProc.Name := '';
    P.RegProc.Decl := IntToStr(Se.AT2UT(StrToIntDef(Fw(C^.ProcDecl), -1)));
    s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|';
    w := C^.ProcDecl;
    i := 0;
    repeat
      grfw(w);
      inc(i);
    until w = '';
    s := s + #0#0#0#0;
    Longint((@(s[length(s)-3]))^) := i;
    P.RegProc.ImportDecl := s;
    C^.PropReadProcNo := ProcNo;
  end else begin
     ProcNo := c^.PropReadProcNo;
  end;
  Result := True;
end;

function TIFPSDelphiClass.Property_Set(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  C: PClassItem;
  P: TIFPSExternalProcedure;
  s, w: string;
  i: Longint;

begin
  C := Pointer(Index);
  if c^.PropAC = iptR then
  begin
    Result := False;
    exit;
  end;
  if c^.PropWriteProcNo = InvalidVal then
  begin
    ProcNo := Se.AddUsedFunction2(P);
    P.RegProc := SE.AddFunction(ProcHDR);
    P.RegProc.Name := '';
    P.RegProc.Decl := '-1';
    s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|';
    w := C^.ProcDecl;
    i := 0;
    repeat
      grfw(w);
      inc(i);
    until w = '';
    s := s + #0#0#0#0;
    Longint((@(s[length(s)-3]))^) := i;
    P.RegProc.ImportDecl := s;
    C^.PropWriteProcNo := ProcNo;
  end else begin
     ProcNo := c^.PropWriteProcNo;
  end;
  Result := True;
end;

function TIFPSDelphiClass.Property_GetHeader(Index: Cardinal;
  var s: string): Boolean;
var
  c: PClassItem;
begin
  C := Pointer(Index);
  s := c^.ProcDecl;
  Result := True;
end;

function TIFPSDelphiClass.SelfType: Cardinal;
begin
  Result := SE.FindType(IFPSClassType);
  if Result = InvalidVal then
  begin
    TIFPSResourcePtrType(SE.AddType(IFPSClassType, btResourcePointer)).ResourceType := 'Class';
    Result := SE.FindType(IFPSClassType);
  end;
end;

function TIFPSDelphiClass.ClassFunc_Call(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  C: PClassItem;
  P: TIFPSExternalProcedure;
  s, w, n: string;

begin
  C := Pointer(Index);
  if c^.MethodProcNo = InvalidVal then
  begin
    ProcNo := Se.AddUsedFunction2(P);
    P.RegProc := SE.AddFunction(ProcHDR);
    P.RegProc.Name := '';
    Se.ReplaceTypes(C^.ProcDecl);
    P.RegProc.Decl := C^.ProcDecl;
    s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
    w := C^.ProcDecl;
    if GRFW(w) = '-1' then
      s := s + #0
    else
      s := s + #1;
    while W <> '' do
    begin
      n := grfw(w);
      grfw(w);
      if (n <> '') and (n[1] = '!') then
        s := s + #1
      else
        s := s + #0;
    end;
    P.RegProc.ImportDecl := s;
    C^.MethodProcNo := ProcNo;
  end else begin
     ProcNo := c^.MethodProcNo;
  end;
  Result := True;
end;

function TIFPSDelphiClass.ClassFunc_Find(const Name: string;
  var Index: Cardinal): Boolean;
var
  H: Longint;
  I: Longint;
  CurrClass: TIFPSCompileTimeClass;
  C: PClassItem;
begin
  H := MakeHash(Name);
  CurrClass := Ce;
  while CurrClass <> nil do
  begin
    for i := CurrClass.FClassItems.Count -1 downto 0 do
    begin
      C := CurrClass.FClassItems[I];
      if (c^.Ftype = 2) and (C^.NameHash = H) and (C^.Name = Name) then
      begin
        Index := Cardinal(C);
        Result := True;
        exit;
      end;
    end;
    CurrClass := CurrClass.FInheritsFrom;
  end;
  Result := False;
end;

function TIFPSDelphiClass.IsCompatibleWith(
  Cl: TIFPSExternalClass): Boolean;
var
  Temp: TIFPSCompileTimeClass;
begin
  if not (cl is TIFPSDelphiClass) then
  begin
    Result := False;
    exit;
  end;
  temp := TIFPSDelphiClass(cl).Ce;
  while Temp <> nil do
  begin
    if Temp = Ce then
    begin
      Result := True;
      exit;
    end;
    Temp := Temp.FInheritsFrom;
  end;
  Result := False;
end;

destructor TIFPSDelphiClass.Destroy;
begin
  inherited Destroy;
end;

function TIFPSDelphiClass.SetNil(var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;

begin
  if NilProcNo <> InvalidVal then
  begin
    Procno := NilProcNo;
    Result := True;
    exit;
  end;
  ProcNo := Se.AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  P.RegProc.Decl := '-1 !VARNO '+IntToStr(se.at2ut(FTypeNo));
  P.RegProc.ImportDecl := 'class:-';
  NilProcNo := Procno;
  Result := True;
end;

function TIFPSDelphiClass.CastToType(IntoType: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;
  Pt: TIFPSType;

begin
  pt := Se.FUsedTypes[IntoType];
  if (pt <> nil) and (pt.BaseType <> btClass) or (not (TIFPSClassType(pt).ClassHelper is TIFPSDelphiClass)) then
  begin
    Result := False;
    exit;
  end;
  if CastProcNo <> InvalidVal then
  begin
    Procno := CastProcNo;
    Result := True;
    exit;
  end;
  ProcNo := Se.AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  P.RegProc.Decl := '-1 !VARTO '+IntToStr(se.AT2UT(FTypeNo))+' !TYPENO '+IntToStr(SE.GetType(True, btu32));
  P.RegProc.ImportDecl := 'class:+';
  CastProcNo := ProcNo;
  Result := True;
end;

function TIFPSDelphiClass.CompareClass(OtherTypeNo: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;
  Pt: TIFPSType;

begin
  if OtherTypeNo <> InvalidVal then
  begin
    pt := Se.FUsedTypes[OtherTypeNo];
    if (pt <> nil) and (pt.BaseType <> btClass) or (not (TIFPSClassType(pt).ClassHelper is TIFPSDelphiClass)) then
    begin
      Result := False;
      exit;
    end;
  end;
  if CompareProcNo <> InvalidVal then
  begin
    Procno := CompareProcNo;
    Result := True;
    exit;
  end;
  ProcNo := Se.AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  P.RegProc.Decl := IntToStr(SE.at2ut(SE.FBooleanType))+' !K '+IntToStr(SE.at2ut(SE.FindType('TObject')))+' !J '+IntToStr(SE.at2ut(SE.FindType('TObject')));
  P.RegProc.ImportDecl := 'class:*';
  CompareProcNo := ProcNo;
  Result := True;
end;


{ TIFPSSetType }

function TIFPSSetType.GetBitSize: Longint;
begin
  case SetType.BaseType of
    btEnum: begin Result := TIFPSEnumType(setType).HighValue+1; end;
    btChar, btU8: Result := 256;
  else
    Result := 0;
  end;
end;

function TIFPSSetType.GetByteSize: Longint;
var
  r: Longint;
begin
  r := BitSize;
  if r mod 8 <> 0 then inc(r, 7);
   Result := r div 8;
end;


  { TIFPSClassType }

destructor TIFPSClassType.Destroy;
begin
  FClassHelper.Free;
  inherited Destroy;
end;


{ TIFPSBlockInfo }

procedure TIFPSBlockInfo.Clear;
var
  i: Longint;
begin
  for i := WithList.Count -1 downto 0 do
  begin
    TIFPSValue(WithList[i]).Free;
    WithList.Delete(i);
  end;
end;

constructor TIFPSBlockInfo.Create(Owner: TIFPSBlockInfo);
begin
  inherited Create;
  FOwner := Owner;
  FWithList := TIfList.Create;
  if FOwner <> nil then
  begin
    FProcNo := FOwner.ProcNo;
    FProc := FOwner.Proc;
  end;
end;

destructor TIFPSBlockInfo.Destroy;
begin
  Clear;
  FWithList.Free;
  inherited Destroy;
end;


{

Internal error counter: 00020 (increase and then use)

}
end.

