Componentes.Terceros.DevExpressVCL/internal/x.44/1/Innerfuse Pascal Script/Sources/ifpscomp.pas

{ifpscomp is the compiler part of the script engine}
unit ifpscomp;
{

Innerfuse Pascal Script III
Copyright (C) 2000-2002 by Carlo Kok (ck@carlo-kok.com)

Features:

  - Constants
  - Variables
  - Procedures/Functions
  - Procedural Variables
  - If, While, Repeat, For, Case
  - Break/Continue
  - External/Integer Procedures/Functions
  - Arrays, Records
  - Ability to create compiled code that can be used later
  - Debugging Support
  - Importing Delphi Funtions and classes

}
{$I ifps3_def.inc}
interface
uses
  SysUtils, ifps3utl, ifps3common;
const
  {Internal constant: used when a value must be read from an address}
  CVAL_Addr = 0;
  {Internal constant: used when a value is plain data}
  CVAL_Data = 1;
  {Internal constant: used when a value must be read from an address and pushed}
  CVAL_PushAddr = 2;
  {Internal constant: used for function calls}
  CVAL_Proc = 3;
  {Internal constant: used when there are sub calculations}
  CVAL_Eval = 4;
  {Internal constant: same as address except that it has to be freed otherwise}
  CVAL_AllocatedStackReg = 5;
  {Internal constant: A method call}
  CVAL_ClassProcCall = 7;
  {Internal contant: A method call}
  CVAL_ClassMethodCall = 8;
  {Internal constant: Property set method}
  CVAL_ClassPropertyCallSet = 9;
  {Internal constant: Property get method}
  CVAL_ClassPropertyCallGet = 10;
  {Internal Constant: Procedural Call with variable procedure number}
  CVAL_VarProc = 11;
  {Internal Constant: Procedural Pointer}
  CVAL_VarProcPtr = 12;
  {Internal Constant: Array}
  CVAL_Array = 13;
  {Internal Constant: ArrayAllocatedStackRec same as @link(CVAL_AllocatedStackReg)}
  CVAL_ArrayAllocatedStackRec = 14;
  {Internal Constant: Nil}
  CVAL_Nil = 15;
  {Internal Constant; Casting}
  CVAL_Cast = 16;

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

  {TIFPSExternalClass is used when external classes need to be called}
  TIFPSExternalClass = class;

  TIFPSRegProc = class(TObject)
  private
    FNameHash: Longint;
    FName, FDecl: string;
    FExportName: Boolean;
    FImportDecl: string;
    procedure SetName(const Value: string);
  public
    property Name: string read FName write SetName;
    property NameHash: Longint read FNameHash;
    property Decl: string read FDecl write FDecl;
    property ExportName: Boolean read FExportName write FExportName;
    property ImportDecl: string read FImportDecl write FImportDecl;
  end;
  PIFPSRegProc = TIFPSRegProc;
  {The compile time variant}
  PIfRVariant = ^TIfRVariant;
  {The compile time variant}
  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 NOINT64}
      17: (ts64: Tbts64);
      {$ENDIF}
      19: (tchar: tbtChar);
      {$IFNDEF NOWIDESTRING}
      18: (twidestring: Pointer);
      20: (twidechar: tbtwidechar);
      {$ENDIF}
  end;
  {TIFPSRecordFieldTypeDef is is used to store records}
  TIFPSRecordFieldTypeDef = class
  private
    FFieldNameHash: Longint;
    FFieldName: string;
    FRealFieldOffset: Cardinal;
    FType: Cardinal;
    procedure SetFieldName(const Value: string);
  public
    property FieldNameHash: Longint read FFieldNameHash;
    property FieldName: string read FFieldName write SetFieldName;
    property RealFieldOffset: Cardinal read FRealFieldOffset write FRealFieldOffset;
    property aType: Cardinal read FType write FType;
  end;
  {PIFPSRecordFieldTypeDef is is used to store records}
  PIFPSRecordFieldTypeDef = TIFPSRecordFieldTypeDef;
  {TIFPSType contains a type definition}
  TIFPSType = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
    FBaseType: TIFPSBaseType;
    FDeclarePosition: Cardinal;
    FUsed: Boolean;
    FTypeSize: Cardinal;
    FExportName: Boolean;
    procedure SetName(const Value: string);
  public
    property Name: string read FName write SetName;
    property NameHash: Longint read FNameHash;
    property BaseType: TIFPSBaseType read FBaseType write FBaseType;
    property DeclarePosition: Cardinal read FDeclarePosition write FDeclarePosition;
    property Used: Boolean read FUsed;
    property TypeSize: Cardinal read FTypeSize write FTypeSize;
    property ExportName: Boolean read FExportName write FExportName;

    procedure Use;
  end;

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

  TIFPSRecordType = class(TIFPSType)
  private
    FRecordSubVals: TIfList;
  public
    constructor Create;
    destructor Destroy; override;

    function RecValCount: Longint;
    function RecVal(I: Longint): PIFPSRecordFieldTypeDef;

    function AddRecVal: PIFPSRecordFieldTypeDef;
  end;

  TIFPSClassType = class(TIFPSType)
  private
    FClassHelper: TIFPSExternalClass;
  public
    property ClassHelper: TIFPSExternalClass read FClassHelper write FClassHelper;
  end;

  TIFPSProceduralType = class(TIFPSType)
  private
    FProcDef: string;
  public
    property ProcDef: string read FProcDef write FProcDef;
  end;

  TIFPSArrayType = class(TIFPSType)
  private
    FArrayTypeNo: Cardinal;
  public
    property ArrayTypeNo: Cardinal read FArrayTypeNo write FArrayTypeNo;
  end;

  TIFPSTypeLink = class(TIFPSType)
  private
    FLinkTypeNo: Cardinal;
  public
    property LinkTypeNo: Cardinal read FLinkTypeNo write FLinkTypeNo;
  end;

  TIFPSEnumType = class(TIFPSType)
  private
    FHighValue: Cardinal;
  public
    property HighValue: Cardinal read FHighValue write FHighValue;
  end;

  {TIFPSProcVar is used to store procedural variables}
  TIFPSProcVar = class(TObject)
  private
    FNameHash: Longint;
    FName: string;
    FType: Cardinal; // only for calculation types
    FUsed: Boolean;
    FDeclarePosition: Cardinal;
    procedure SetName(const Value: string);
  public
    property NameHash: Longint read FNameHash;
    property Name: string read FName write SetName;
    property AType: Cardinal read FType write FType;
    property Used: Boolean read FUsed;
    property DeclarePosition: Cardinal read FDeclarePosition write FDeclarePosition;
    procedure Use;
  end;
  {@link(TIFPSProcVar)
  PIFPSProcVar is a TIFPSProcVar class}
  PIFPSProcVar = TIFPSProcVar;

  TIFPSProcedure = class(TObject)
  end;

  TIFPSExternalProcedure = class(TIFPSProcedure)
  private
    FRegProc: TIFPSRegProc;
  public
    property RegProc: TIFPSRegProc read FRegProc write FRegProc;
  end;

  TIFPSExportType = (etExportNone, etExportName, etExportDecl);
  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;
    FDeclarePosition: Cardinal;
    FOutputDeclPosition: Cardinal;
    FResultUsed: Boolean;
    FExport: TIFPSExportType;
    FLabels: TIfStringList; // mi2s(position)+mi2s(namehash)+name   [position=$FFFFFFFF means position unknown]
    FGotos: TIfStringList;
    procedure SetName(const Value: string);  // mi2s(position)+mi2s(destinationnamehash)+destinationname
  public
    constructor Create;
    destructor Destroy; override;

    property Forwarded: Boolean read FForwarded write FForwarded;
    property Data: string read FData write FData;
    property Decl: string read FDecl write FDecl;
    property Name: string read FName write SetName;
    property NameHash: Longint read FNameHash;
    property ProcVars: TIFList read FProcVars;
    property Used: Boolean read FUsed;
    property DeclarePosition: Cardinal read FDeclarePosition write FDeclarePosition;
    property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
    property ResultUsed: Boolean read FResultUsed;

    property aExport: TIFPSExportType read FExport write FExport;

    property Labels: TIfStringList read FLabels;
    property Gotos: TIfStringList read FGotos;

    procedure Use;
    procedure ResultUse;
  end;
  {PIFPSVar is a pointer to a TIFPSVar record}
  PIFPSVar = ^TIFPSVar;
  {TIFPSVar is used to store global variables}
  TIFPSVar = record
    NameHash: Longint;
    Name: string;
    FType: Cardinal;
    Used: Boolean;
    DeclarePosition: Cardinal;
    exportname: string;
  end;
  {PIFPSContant is a pointer to a TIFPSConstant}
  PIFPSConstant = ^TIFPSConstant;
  {TIFPSContant contains a constant}
  TIFPSConstant = record
    NameHash: Longint;
    Name: string;
    Value: TIfRVariant;
  end;
  {Is used to store the type of a compiler error}
  TIFPSPascalCompilerError = (
    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}
  TIFPSPascalCompilerHint = (
    ehVariableNotUsed, {param = variable name}
    ehFunctionNotUsed, {param = function name}
    ehCustomHint
    );
  {Is used to store the type of a warning}
  TIFPSPascalCompilerWarning = (
    ewCalculationAlwaysEvaluatesTo,
    ewIsNotNeeded,
    ewCustomWarning
  );
  {Is used to store the type of the messages}
  TIFPSPascalCompilerMessageType = (ptWarning, ptError, ptHint);
  {Contains a pointer to an TIFPSPascalCompilerMessages record}
  PIFPSPascalCompilerMessage = ^TIFPSPascalCompilerMessage;
  {Contains compiler messages}
  TIFPSPascalCompilerMessage = packed record

    ModuleName: string;
    Param: string;
    Position: Cardinal;
    MessageType: TIFPSPascalCompilerMessageType;
    case TIFPSPascalCompilerMessageType of
      ptError: (Error: TIFPSPascalCompilerError);
      ptWarning: (Warning: TIFPSPascalCompilerWarning);
      ptHint: (Hint: TIFPSPascalCompilerHint);
  end;

  {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;
  TIFPSPascalCompiler = class
  private
    FLastProgramName: string;
    {$IFNDEF NOWIDESTRING}
    function GetWideString(FUseTypes: TIfList; Src: PIfRVariant;
      var s: Boolean): WideString;
    {$ENDIF}
  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;
    function GetType(BaseType: TIFPSBaseType): Cardinal;
    function GetMsgCount: Longint;
    function MakeDecl(decl: string): string;
    function MakeExportDecl(decl: string): string;
    function GetMsg(l: Longint): PIFPSPascalCompilerMessage;
    procedure DefineStandardTypes;
    procedure UpdateRecordFields(r: TIFPSType);
    function GetTypeCopyLink(p: PIFPSType): PIFPSType;
    function GetTypeCopyLinkInt(L: Cardinal): Cardinal;
    function IsIntBoolType(FTypeNo: Cardinal): Boolean;
    function GetUInt(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Cardinal;
    function GetInt(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Longint;
    {$IFNDEF NOINT64}
    function GetInt64(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): Int64;
    {$ENDIF}
    function GetReal(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Extended;
    function GetString(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): string;
    function PreCalc(FUseTypes: TIFList; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
      Var2: PIfRVariant; Cmd: Byte; Pos: Cardinal): Boolean;
    function ReadConstant(StopOn: TIfPasToken): PIfRVariant;
    procedure WriteDebugData(const s: string);
    function ProcessFunction(AlwaysForward: Boolean): Boolean;
    function IsDuplicate(const s: string): Boolean;
    function DoVarBlock(proc: TIFPSInternalProcedure): Boolean;
    function DoTypeBlock(FParser: TIfPascalParser): Boolean;
    function ReadType(const Name: string; FParser: TIfPascalParser): Cardinal;
    function NewProc(const Name: string): TIFPSInternalProcedure;
    function ProcessLabel(Proc: TIFPSInternalProcedure): Boolean;
    procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TIFPSInternalProcedure; TokenPos: Cardinal);
    procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
    function ProcessSub(FType: TSubOptType; ProcNo: Cardinal; proc: TIFPSInternalProcedure): Boolean;
    function ProcessLabelForwards(Proc: TIFPSInternalProcedure): Boolean;

    procedure ReplaceTypes(var s: string);
    function AT2UT(L: Cardinal): Cardinal;
    function GetUsedType(No: Cardinal): PIFPSType;
    function GetAvailableType(No: Cardinal): PIFPSType;
    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(FTypeNo, ProcNo: Cardinal): Boolean;
    procedure ParserError(Parser: TObject; Kind: TIFParserErrorKind; Position: Cardinal);
  public
    {Add an object to the auto-free list}
    procedure AddToFreeList(Obj: TObject);
    {Tag}
    property ID: Pointer read FID write FID;
    {Add an error the messages}
    function MakeError(const Module: string; E: TIFPSPascalCompilerError; const
      Param: string): PIFPSPascalCompilerMessage;
    {Add a warning to the messages}
    function MakeWarning(const Module: string; E: TIFPSPascalCompilerWarning;
      const Param: string): PIFPSPascalCompilerMessage;
    {Add a hint to the messages}
    function MakeHint(const Module: string; E: TIFPSPascalCompilerHint;
      const Param: string): PIFPSPascalCompilerMessage;
    {Add a function}
    function AddFunction(const Header: string): TIFPSRegProc;
    {add a type}
    function AddType(const Name: string; const BaseType: TIFPSBaseType): PIFPSType;
    {Add a type declared in a string}
    function AddTypeS(const Name, Decl: string): PIFPSType;
    {Add a type copy type}
    function AddTypeCopy(const Name: string; TypeNo: Cardinal): PIFPSType;
    {Add a type copy type}
    function AddTypeCopyN(const Name, FType: string): PIFPSType;
    {Add a constant}
    function AddConstant(const Name: string; FType: Cardinal): PIFPSConstant;
    {Add a constant}
    function AddConstantN(const Name, FType: string): PIFPSConstant;
    {Add a variable}
    function AddVariable(const Name: string; FType: Cardinal): PIFPSVar;
    {Add a variable}
    function AddVariableN(const Name, FType: string): PIFPSVar;
    {Add an used variable}
    function AddUsedVariable(const Name: string; FType: Cardinal): PIFPSVar;
    {add an used variable (with named type)}
    function AddUsedVariableN(const Name, FType: string): PIFPSVar;
    {Add a variable and export it}
    function AddExportVariableN(const Name, FType: string): PIFPSVar;
    {Add an used variable and export it}
    function AddUsedExportVariableN(const Name, FType: string): PIFPSVar;
    {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]: PIFPSPascalCompilerMessage 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;
    {Last Program or Unit name}
    property LastProgramName: string read FLastProgramName;
  end;
  {Pointer to @link(TIFPSValue) type}
  PIFPSValue = ^TIFPSValue;
  {Type containing types}
  TIFPSValue = packed record
    FType: Byte;
    Modifiers: byte;
    {
      1 = not
      2 = minus
      4 = ignore types (casting)
      8 = override type
      128 = don't free
    }
    FNewTypeNo: Cardinal;
    DPos: Cardinal;
    case Byte of
      CVAL_Nil: ();
      CVAL_Addr: (Address: Cardinal; RecField: TIfList); {i/o}
      CVAL_Data: (FData: PIfRVariant); {i}
      CVAL_PushAddr: (Address_: Cardinal; RecField__: TIfList);
      CVAL_Proc: (Parameters: TIfList; ProcNo: Cardinal);
      CVAL_VarProc: (_Parameters: TIfList; _ProcNo: PIFPSValue);
      CVAL_Eval: (SubItems: TIfList; frestype: Cardinal);
      CVAL_ClassPropertyCallGet,
      CVAL_ClassPropertyCallSet,
      CVAL_ClassMethodCall,
      CVAL_ClassProcCall: (Self: PIFPSValue; ClassProcNo: Cardinal; Params: TIfList);
      CVAL_Array: (ArrayItems: TIfList);
      CVAL_VarProcPtr: (VProcNo: Cardinal);
      CVAL_Cast: (NewTypeNo: Cardinal; Input: PIFPSValue);
  end;
  {Internal type: PCalc_Item}
  PCalc_Item = ^TCalc_Item;
  {Internal type: TCalc_Item}
  TCalc_Item = packed record
    C: Boolean;
    case Boolean of
      False: (OutRec: PIFPSValue);
      True: (calcCmd: Byte);
  end;
  {Internal type: PIFRecField}
  PIFRecField = ^TIFRecField;
  {Internal type: TIFRecField}
  TIFRecField = packed record
    FKind: Byte;
    FType: Cardinal;
    case Byte of
      0: (RecFieldNo: Cardinal);
      1: (ArrayFieldNo: Cardinal);
      2: (ReadArrayFieldNoFrom: PIFPSValue);
      3: (ResultRec: PIFPSValue);
  end;
  {TIFPSExternalClass is used when external classes need to be called}
  TIFPSExternalClass = class
  protected
    SE: TIFPSPascalCompiler;
  public
    {The type used as a class}
    function SelfType: Cardinal; virtual;
	{Create}
    constructor Create(Se: TIFPSPascalCompiler);
    {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 variant}
    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(TypeNo: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for casting}
    function CastToType(TypeNo, IntoType: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
    {Return the procno for comparing two classes}
    function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  end;
{Convert a message to a string}
function IFPSMessageToString(x: PIFPSPascalCompilerMessage): string;
{Set the name of an exported variable}
procedure SetVarExportName(P: PIFPSVar; const ExpName: string);


implementation

procedure SetVarExportName(P: PIFPSVar; const ExpName: string);
begin
  if p <> nil then
    p^.exportname := ExpName;
end;
function TIFPSPascalCompiler.GetType(BaseType: TIFPSBaseType): Cardinal;
var
  l: Longint;
  x: PIFPSType;
begin
  for l := 0 to FUsedTypes.Count - 1 do
  begin
    x := FUsedTypes.GetItem(l);
    if (x.BaseType = BaseType) and (x.ClassType = TIFPSType) then
    begin
      Result := l;
      exit;
    end;
  end;
  for l := 0 to FAvailableTypes.Count - 1 do
  begin
    x := FAvailableTypes.GetItem(l);
    if (x.BaseType = BaseType) and (x.ClassType = TIFPSType) then
    begin
      FUsedTypes.Add(x);
      Result := FUsedTypes.Count - 1;
      exit;
    end;
  end;
  X := TIFPSType.Create;
  x.Name := '';
  x.BaseType := BaseType;
  x.TypeSize := 1;
  x.DeclarePosition := Cardinal(-1);
  x.Use;
  FAvailableTypes.Add(x);
  FUsedTypes.Add(x);
  Result := FUsedTypes.Count - 1;
end;

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

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


{ TIFPSPascalCompiler }

const
  BtTypeCopy = 255;

function IFPSMessageToString(x: PIFPSPascalCompilerMessage): string;
begin
  case x^.MessageType of
    ptError:
      begin
        case x^.Error of
          ecUnknownIdentifier: Result := 'Unknown identifier ''' + x^.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 ''' + x^.Param + '''';
          ecColonExpected: Result := 'colon ('':'') expected';
          ecUnknownType: Result := 'Unknown type ''' + x^.Param + '''';
          ecCloseRoundExpected: Result := 'Close round expected';
          ecTypeMismatch: Result := 'Type mismatch';
          ecInternalError: Result := 'Internal error (' + x^.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 '''+x^.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 := x^.Param;
          ecDivideByZero: Result := 'Divide by Zero';
          ecMathError:  Result := 'Math Error';
          ecUnsatisfiedForward: Result := 'Unsatisfied Forward '+ X^.Param;
          ecForwardParameterMismatch: Result := 'Forward Parameter Mismatch';
        else
          Result := 'Unknown error';
        end;
        Result := '[Error] ' + x^.ModuleName + ': ' + Result;
      end;
    ptHint:
      begin
        case x^.Hint of
          ehVariableNotUsed: Result := 'Variable ''' + x^.Param + ''' never used';
          ehFunctionNotUsed: Result := 'Function ''' + x^.Param + ''' never used';
          ehCustomHint: Result := x^.Param;
        else
          Result := 'Unknown hint';
        end;
        Result := '[Hint] ' + x^.ModuleName + ': ' + Result;
      end;
    ptWarning:
      begin
        case x^.Warning of
          ewCustomWarning: Result := x^.Param;
          ewCalculationAlwaysEvaluatesTo: Result := 'Calculation always evaluates to '+x^.Param;
          ewIsNotNeeded: Result := x^.Param +' is not needed';
        end;
        Result := '[Warning] ' + x^.ModuleName + ': ' + Result;
      end;
  else
    Result := 'Unknown message';
  end;
end;

type
  TFuncType = (ftProc, ftFunc);

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




function TIFPSPascalCompiler.AddType(const Name: string; const BaseType: TIFPSBaseType): PIFPSType;
begin
  if FProcs = nil then begin Result := nil; exit;end;

  case BaseType of
    btProcPtr: Result := TIFPSProceduralType.Create;
    BtTypeCopy: Result := TIFPSTypeLink.Create;
    btRecord: Result := TIFPSRecordType.Create;
    btArray: Result := TIFPSArrayType.Create;
    btClass: Result := TIFPSClassType.Create;
  else
    Result := TIFPSType.Create;
  end;
  Result.Name := FastUppercase(Name);
  Result.BaseType := BaseType;
  Result.TypeSize := 1;
  Result.DeclarePosition := Cardinal(-1);
  FAvailableTypes.Add(Result);
end;


function TIFPSPascalCompiler.AddFunction(const Header: string): TIFPSRegProc;

  function FindType(const s: string): Cardinal;
  var
    h, l: Longint;
  begin
    h := MakeHash(s);
    for l := 0 to FAvailableTypes.Count - 1 do
    begin
      if (PIFPSType(FAvailableTypes.GetItem(l)).NameHash = h) and
        (PIFPSType(FAvailableTypes.GetItem(l)).Name = s) then
      begin
        Result := l;
        exit;
      end;
    end;
    Result := Cardinal(-1);
  end;
var
  Parser: TIfPascalParser;
  IsFunction: Boolean;
  VNames, Name, Decl: string;
  modifier: Char;
  VCType: Cardinal;
  x: TIFPSRegProc;
begin
  if FProcs = nil then begin Result := nil; exit;end;
  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;
    Result := nil;
    exit;
  end;
  Decl := '';
  Parser.Next;
  if Parser.CurrTokenId <> CSTI_Identifier then
  begin
    Parser.Free;
    Result := nil;
    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 := nil;
          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 := nil;
            exit;
          end;
          VNames := VNames + Parser.GetToken + '|';
          Parser.Next;
        end;
        if Parser.CurrTokenId <> CSTI_Colon then
        begin
          Parser.Free;
          Result := nil;
          exit;
        end;
        Parser.Next;
        VCType := FindType(Parser.GetToken);
        if VCType = Cardinal(-1) then
        begin
          Parser.Free;
          Result := nil;
          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;
        Parser.Next;
        if Parser.CurrTokenId = CSTI_CloseRound then
          break;
        if Parser.CurrTokenId <> CSTI_Semicolon then
        begin
          Parser.Free;
          Result := nil;
          exit;
        end;
        Parser.Next;
      end; {while}
    end; {if}
    Parser.Next;
  end; {if}
  if IsFunction then
  begin
    if Parser.CurrTokenId <> CSTI_Colon then
    begin
      Parser.Free;
      Result := nil;
      exit;
    end;

    Parser.Next;
    VCType := FindType(Parser.GetToken);
    if VCType = Cardinal(-1) then
    begin
      Parser.Free;
      Result := nil;
      exit;
    end;
  end
  else
    VCType := Cardinal(-1);
  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: TIFPSPascalCompilerHint; const Param: string): PIFPSPascalCompilerMessage;
var
  n: PIFPSPascalCompilerMessage;
begin
  New(n);
  n^.ModuleName := Module;
  n^.Param := Param;
  n^.Position := FParser.CurrTokenPos;
  n^.MessageType := ptHint;
  n^.Hint := E;
  FMessages.Add(n);
  Result := n;
end;
function TIFPSPascalCompiler.MakeError(const Module: string; E:
  TIFPSPascalCompilerError; const Param: string): PIFPSPascalCompilerMessage;
var
  n: PIFPSPascalCompilerMessage;
begin
  New(n);
  n^.ModuleName := Module;
  n^.Param := Param;
  n^.Position := FParser.CurrTokenPos;
  n^.MessageType := ptError;
  n^.Error := E;
  FMessages.Add(n);
  Result := n;
end;

function TIFPSPascalCompiler.MakeWarning(const Module: string; E:
  TIFPSPascalCompilerWarning; const Param: string): PIFPSPascalCompilerMessage;
var
  n: PIFPSPascalCompilerMessage;
begin
  New(n);
  n^.ModuleName := Module;
  n^.Param := Param;
  n^.Position := FParser.CurrTokenPos;
  n^.MessageType := ptWarning;
  n^.Warning := E;
  FMessages.Add(n);
  Result := n;
end;

procedure TIFPSPascalCompiler.Clear;
var
  l: Longint;
  p: PIFPSPascalCompilerMessage;
begin
  FDebugOutput := '';
  FOutput := '';
  for l := 0 to FMessages.Count - 1 do
  begin
    p := FMessages.GetItem(l);
    Dispose(p);
  end;
  FMessages.Clear;
  for L := FAutoFreeList.Count -1 downto 0 do
  begin
    TObject(FAutoFreeList.GetItem(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 NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
    btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
    {$IFNDEF NOWIDESTRING}
    btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
    btwidechar: Dest^.tchar := src^.tchar;
    {$ENDIF}
  end;
end;

procedure InitializeVariant(Vari: PIfRVariant; FType: Cardinal; BaseType: TIFPSBaseType);
begin
  FillChar(vari^, SizeOf(TIfRVariant), 0);
  vari^.FType := FType;
  vari.BaseType := BaseType;
end;

procedure FinalizeVariant(var p: TIfRVariant);
begin
  if p.BaseType = btString then
    finalize(tbtstring(p.tstring))
  {$IFNDEF 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^);
{$IFDEF DEBUG}    FillChar(p^, sizeof(p^), 0);{$ENDIF}
    Dispose(p);
  end;
end;

type
  PParam = ^TParam;
  TParam = record
    InReg, OutReg: PIFPSValue;
    FType: Cardinal;
    OutRegPos: Cardinal;
  end;

procedure DisposePValue(r: PIFPSValue); forward;

procedure FreeRecFields(List: TIfList);
var
  i: Longint;
  p: PIFRecField;
begin
  if list = nil then
    exit;
  for i := List.Count - 1 downto 0 do
  begin
    p := List.GetItem(i);
    if p^.FKind >= 2 then
    begin
      DisposePValue(p^.ReadArrayFieldNoFrom);
    end;
    Dispose(p);
  end;
  List.Free;
end;

procedure DisposePValue(r: PIFPSValue);
var
  l: Longint;
  p: PCalc_Item;
  P2: PParam;
begin
  if (r <> nil) and ((r^.Modifiers and 128)= 0) then
  begin
    if (r^.FType = CVAL_Array) then
    begin
      for l := 0 to r.ArrayItems.Count -1 do
      begin
        DisposePValue(R.ArrayItems.GetItem(l));
      end;
      r.ArrayItems.Free;
    end else
    if (r^.FType = CVAL_AllocatedStackReg) or (r^.FType = CVAL_Addr) or (r^.FType = CVAL_PushAddr) then
    begin
      FreeRecFields(R^.RecField);
    end
    else if r.FType = CVAL_Data then
      DisposeVariant(r^.FData)
    else if r.FType = CVAL_Eval then
    begin
      for l := 0 to r.SubItems.Count - 1 do
      begin
        p := r.SubItems.GetItem(l);
        if not p^.C then
          DisposePValue(p^.OutRec);
        Dispose(p);
      end;
      r^.SubItems.Free;
    end
    else if (r.FType = CVAL_Proc) or (r.FType = CVAL_varProc)then
    begin
      for l := 0 to r^.Parameters.Count - 1 do
      begin
        P2 := r^.Parameters.GetItem(l);
        if P2^.InReg <> nil then
          DisposePValue(P2^.InReg);
        Dispose(P2);
      end;
      r.Parameters.Free;
      if r.FType = CVAL_VarProc then
        DisposePValue(r._ProcNo);
    end else if (r.FType = CVAL_ClassPropertyCallGet) or (r.FType = CVAL_ClassPropertyCallSet) or (r.FType = CVAL_ClassMethodCall) or (r.FType = CVAL_ClassProcCall) then
    begin
      DisposePValue(r.Self);
      for l := 0 to r^.Params.Count - 1 do
      begin
        P2 := r^.Params.GetItem(l);
        if P2^.InReg <> nil then
          DisposePValue(P2^.InReg);
        Dispose(P2);
      end;
    end;
   {$IFDEF DEBUG}FillChar(r^, sizeof(r^), 0);{$ENDIF}
    Dispose(r);
  end;
end;

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

function IsIntType(b: TIFPSBaseType): Boolean;
begin
  case b of
    btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF 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 NOINT64}, btS64{$ENDIF}:
      Result := True;
  else
    Result := False;
  end;

end;

function DiffRec(p1, p2: PIFRecField): Boolean;
begin
  Result :=
    (p1^.FKind <> p2^.FKind) or
    (p1^.RecFieldNo <> p2^.RecFieldNo);
end;

function SameReg(x1, x2: PIFPSValue): Boolean;
var
  I: Longint;
begin
  if x1^.FType = x2^.FType then
  begin
    case x1^.FType of
      CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg, CVAL_AllocatedStackReg +1:
        begin
          if x1^.Address = x2^.Address then
          begin
            if (x1^.RecField = nil) and (x2^.RecField = nil) then
              Result := True
            else if (x1^.RecField <> nil) and (x2^.RecField <> nil) and
              (x1^.RecField.Count = x2^.RecField.Count) then
            begin
              for I := x1^.RecField.Count - 1 downto 0 do
              begin
                if DiffRec(x1^.RecField.GetItem(I), x2^.RecField.GetItem(I))
                  then
                begin
                  Result := False;
                  exit;
                end;
              end;
              Result := True;
            end
            else
              Result := False;
          end
          else
            Result := False;
        end;
    else
      Result := False;
    end;
  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: PIFPSType;
begin
  if L = Cardinal(-1) then begin Result := Cardinal(-1); exit; end;
  p := FAvailableTypes.GetItem(L);
  p := GetTypeCopyLink(p);
  if p.Used then
  begin
    for i := 0 to FUsedTypes.Count - 1 do
    begin
      if FUSedTypes.GetItem(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 TIFPSPascalCompiler.GetUInt(FUseTypes: TIfList; 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 NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;

function TIFPSPascalCompiler.GetInt(FUseTypes: TIfList; 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 NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;
{$IFNDEF NOINT64}
function TIFPSPascalCompiler.GetInt64(FUseTypes: TIfList; 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 NOWIDESTRING}
    btWideChar: Result := ord(tbtwidechar(src^.twidechar));
    {$ENDIF}
    btEnum: Result := src^.tu32;
  else
    begin
      s := False;
      Result := 0;
    end;
  end;
end;
{$ENDIF}

function TIFPSPascalCompiler.GetReal(FUseTypes: TIfList; 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 NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btChar: Result := ord(Src^.tchar);
    {$IFNDEF 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 TIFPSPascalCompiler.GetString(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): string;
begin
  case Src.BaseType of
    btChar: Result := Src^.tchar;
    btString: Result := tbtstring(src^.tstring);
    {$IFNDEF NOWIDESTRING}
    btWideChar: Result := src^.twidechar;
    btWideString: Result := tbtWideString(src^.twidestring);
    {$ENDIF}
  else
    begin
      s := False;
      Result := '';
    end;
  end;
end;

{$IFNDEF NOWIDESTRING}
function TIFPSPascalCompiler.GetWideString(FUseTypes: TIfList; 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;


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

  procedure SetBoolean(b: Boolean);
  begin
    FinalizeVariant(var1^);
    if FUseTypes = FAvailableTypes then
      Var1^.FType := FBooleanType
    else
      Var1^.FType := at2ut(FBooleanType);
    var1.BaseType := PIFPSType(FUseTypes.GetItem(at2ut(FBooleanType))).BaseType;
    var1^.tu32 := Ord(b);
  end;

  procedure SetString(const s: string);
  begin
    FinalizeVariant(var1^);
    InitializeVariant(var1, GetType(btString), btString);
    tbtstring(var1^.tstring) := s;
  end;
{$IFNDEF NOWIDESTRING}
  procedure SetWideString(const s: WideString);
  begin
    FinalizeVariant(var1^);
    InitializeVariant(var1, GetType(btWideString), btWideString);
    tbtwidestring(var1^.tstring) := s;
  end;
{$ENDIF}
  procedure MakeFloat(var1: PIfRVariant; NewType: Cardinal);
  var
    vartemp: PIfRVariant;
    b: Boolean;
  begin
    New(vartemp);
    InitializeVariant(vartemp, var1.FType, Var1.BaseType);
    CopyVariantContents(var1, vartemp);
    FinalizeVariant(var1^);
    InitializeVariant(var1, newtype, PIFPSType(FUsedTypes.GetItem(NewType)).BaseType);
    case var1.basetype of
      btSingle:
        begin
          if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
            var1^.tsingle := GetUInt(FUsedTypes, vartemp, b)
          else
            var1^.tsingle := GetInt(FUsedTypes, vartemp, b)
        end;
      btDouble:
        begin
          if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
            var1^.tdouble := GetUInt(FUsedTypes, vartemp, b)
          else
            var1^.tdouble := GetInt(FUsedTypes, vartemp, b)
        end;
      btExtended:
        begin
          if (vartemp.BaseType = btu8) or (vartemp.BaseType = btu16) or (vartemp.BaseType = btu32) then
            var1^.textended:= GetUInt(FUsedTypes, vartemp, b)
          else
            var1^.textended:= GetInt(FUsedTypes, vartemp, b)
        end;
    end;
    FinalizeVariant(vartemp^);
    DisposeVariant(vartemp);
  end;

begin
  Result := True;
  try
    if (IsRealType(var2.BaseType) and IsIntType(var1.BaseType)) then
      MakeFloat(var1, var2^.FType);
    case Cmd of
      0:
        begin { + }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 + GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 + GetInt(FUseTypes,Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 + GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 + GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 + GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 + GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle + GetReal(FUseTypes, Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble + GetReal(FUseTypes, Var2, Result);
            btExtended: var1^.textended := var1^.textended + GetReal(FUseTypes, Var2, Result);
            btChar:
              begin
                if var2.BaseType = btchar then
                  var1^.tu8 := var1^.tu8 + GetUInt(FUseTypes, Var2, Result)
                else
                begin
                  SetString(getstring(FUseTypes, Var1, b)+getstring(FUseTypes, Var2, b));
                end;
              end;
            btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(FUseTypes, Var2, Result);
            {$IFNDEF NOWIDESTRING}
            btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(FUseTypes, Var2, Result);
            btWidechar:
              begin
                if (var2.BaseType = btchar) or (var2.BaseType = btwidechar) then
                  var1^.tu16 := var1^.tu16 + GetUInt(FUseTypes, Var2, Result)
                else
                begin
                  SetWideString(GetWideString(FUseTypes, Var1, b)+GetWideString(FUseTypes, Var2, b));
                end;
              end;
            {$ENDIF}
            else b := False;
          end;
        end;
      1:
        begin { - }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 - GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 - GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 - GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 - GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 - GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 - GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle - GetReal(FUseTypes, Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble - GetReal(FUseTypes,Var2, Result);
            btExtended: var1^.textended := var1^.textended - GetReal(FUseTypes,Var2, Result);
            else b := False;
          end;
        end;
      2:
        begin { * }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 * GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 * GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 * GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 * GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 * GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 * GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle * GetReal(FUseTypes,Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble * GetReal(FUseTypes,Var2, Result);
            btExtended: var1^.textended := var1^.textended * GetReal(FUseTypes, Var2, Result);
            else b := False;
          end;
        end;
      3:
        begin { / }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 div GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 div GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 div GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 div GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 div GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 div GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle / GetReal(FUseTypes, Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble / GetReal(FUseTypes, Var2, Result);
            btExtended: var1^.textended := var1^.textended / GetReal(FUseTypes, Var2, Result);
            else b := False;
          end;
        end;
      4:
        begin { MOD }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 mod GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 mod GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 mod GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 mod GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 mod GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 mod GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            else b := False;
          end;
        end;
      5:
        begin { SHL }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shl GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 shl GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shl GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shl GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shl GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shl GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            else b := False;
          end;
        end;
      6:
        begin { SHR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shr GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 shr GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shr GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shr GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shr GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shr GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            else b := False;
          end;
        end;
      7:
        begin { AND }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 and GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 and GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 and GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 and GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 and GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 and GetInt(FUseTypes, Var2, Result);
            btEnum: var1^.ts32 := var1^.ts32 and GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            else b := False;
          end;
        end;
      8:
        begin { OR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 or GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 or GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 or GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 or GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 or GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 or GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btEnum: var1^.ts32 := var1^.ts32 or GetInt(FUseTypes, Var2, Result);
            else b := False;
          end;
        end;
      9:
        begin { XOR }
          case var1.BaseType of
            btU8: var1^.tu8 := var1^.tu8 xor GetUInt(FUseTypes, Var2, Result);
            btS8: var1^.ts8 := var1^.ts8 xor GetInt(FUseTypes, Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 xor GetUInt(FUseTypes, Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 xor GetInt(FUseTypes, Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 xor GetUInt(FUseTypes, Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 xor GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btEnum: var1^.ts32 := var1^.ts32 xor GetInt(FUseTypes, Var2, Result);
            else b := False;
          end;
        end;
      10:
        begin { >= }
          case var1.BaseType of
            btU8: b := var1^.tu8 >= GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 >= GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 >= GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 >= GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 >= GetUInt(FUseTypes, Var2, Result);
            btS32: b := var1^.ts32 >= GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 >= GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle >= GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble >= GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended >= GetReal(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
      11:
        begin { <= }
          case var1.BaseType of
            btU8: b := var1^.tu8 <= GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 <= GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 <= GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 <= GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 <= GetUInt(FUseTypes, Var2, Result);
            btS32: b := var1^.ts32 <= GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 <= GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle <= GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble <= GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended <= GetReal(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
      12:
        begin { > }
          case var1.BaseType of
            btU8: b := var1^.tu8 > GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 > GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 > GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 > GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 > GetUInt(FUseTypes, Var2, Result);
            btS32: b := var1^.ts32 > GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 > GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle > GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble > GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended > GetReal(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
      13:
        begin { < }
          case var1.BaseType of
            btU8: b := var1^.tu8 < GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 < GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 < GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 < GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 < GetUInt(FUseTypes, Var2, Result);
            btS32: b := var1^.ts32 < GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 < GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle < GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble < GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended < GetReal(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
      14:
        begin { <> }
          case var1.BaseType of
            btU8: b := var1^.tu8 <> GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 <> GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 <> GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 <> GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 <> GetUInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 <> GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btS32: b := var1^.ts32 <> GetInt(FUseTypes, Var2, Result);
            btSingle: b := var1^.tsingle <> GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble <> GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended <> GetReal(FUseTypes, Var2, Result);
            btEnum: b := var1^.ts32 <> GetInt(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
      15:
        begin { = }
          case var1.BaseType of
            btU8: b := var1^.tu8 = GetUInt(FUseTypes, Var2, Result);
            btS8: b := var1^.ts8 = GetInt(FUseTypes, Var2, Result);
            btU16: b := var1^.tu16 = GetUInt(FUseTypes, Var2, Result);
            btS16: b := var1^.ts16 = GetInt(FUseTypes, Var2, Result);
            btU32: b := var1^.tu32 = GetUInt(FUseTypes, Var2, Result);
            btS32: b := var1^.ts32 = GetInt(FUseTypes, Var2, Result);
            {$IFNDEF NOINT64}btS64: b := var1^.ts64 = GetInt64(FUseTypes, Var2, Result); {$ENDIF}
            btSingle: b := var1^.tsingle = GetReal(FUseTypes, Var2, Result);
            btDouble: b := var1^.tdouble = GetReal(FUseTypes, Var2, Result);
            btExtended: b := var1^.textended = GetReal(FUseTypes, Var2, Result);
            btEnum: b := var1^.ts32 = GetInt(FUseTypes, Var2, Result);
          else
            b := False;
          end;
          SetBoolean(b);
        end;
    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
    MakeError('', ecTypeMismatch, '')^.Position := Pos;
end;

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

  for l := 0 to FAvailableTypes.Count - 1 do
  begin
    if (PIFPSType(FAvailableTypes.GetItem(l)).NameHash = h) and
      (PIFPSType(FAvailableTypes.GetItem(l)).Name = s) then
    begin
      Result := True;
      exit;
    end;
  end;

  for l := 0 to FProcs.Count - 1 do
  begin
    x := FProcs.GetItem(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;
  for l := 0 to FVars.Count - 1 do
  begin
    if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
      (PIFPSVar(FVars.GetItem(l))^.Name = s) then
    begin
      Result := True;
      exit;
    end;
  end;
  for l := 0 to FConstants.Count -1 do
  begin
    if (PIFPSConstant(FConstants.GetItem(l))^.NameHash = h) and
      (PIFPSConstant(FConstants.GetItem(l))^.Name = s) then
    begin
      Result := TRue;
      exit;
    end;
  end;
  Result := False;
end;


function TIFPSPascalCompiler.ReadType(const Name: string; FParser: TIfPascalParser): Cardinal; // Cardinal(-1) = Invalid
var
  TypeNo: Cardinal;
  h, l: Longint;
  fieldname,s: string;
  RecSubVals: TIfList;
  rvv: PIFPSRecordFieldTypeDef;
  p, p2: PIFPSType;
  function ATNUT(C: Cardinal): Cardinal;
  var
    i: Longint;
    P: PIFPSType;
  begin
    p := FAvailableTypes.GetItem(C);
    for i := 0 to FUsedTypes.Count -1 do
    begin
      if FUsedTypes.GetItem(I) = P then
      begin
        Result := I;
        exit;
      end;
    end;
    result := Cardinal(-1);
  end;
  procedure ClearRecSubVals;
  var
    I: Longint;
  begin
    for I := 0 to RecSubVals.Count - 1 do
      TIFPSRecordFieldTypeDef(RecSubVals.GetItem(I)).Free;
    RecSubVals.Free;
  end;

  procedure MakeRealFieldOffsets;
  var
    I: Longint;
    O: Cardinal;
    rvv: PIFPSRecordFieldTypeDef;
  begin
    O := 0;
    for I := 0 to RecSubVals.Count - 1 do
    begin
      rvv := RecSubVals.GetItem(I);
      rvv.RealFieldOffset := O;
      O := O + PIFPSType(FAvailableTypes.GetItem(rvv.FType)).TypeSize;
    end;
    p.TypeSize := O;
  end;
  function GetTypeCopy(i: Cardinal): Cardinal;
  begin
    if PIFPSType(FAvailableTypes.GetItem(I)).BaseType = btTypeCopy then
      Result := GetTypeCopy(TIFPSTypeLink(FAvailableTypes.GetItem(I)).LinkTypeNo)
    else
      Result := i;
  end;

  function AddProcedure: Cardinal;
  var
    IsFunction: Boolean;
    VNames, Decl: string;
    modifier: Char;
    VCType: Cardinal;
    x: PIFPSType;
//    xp: TIFPSProceduralType;
    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 := Cardinal(-1);
            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 := Cardinal(-1);
              if FParser = Self.FParser then
              MakeError('', ecIdentifierExpected, '');
              exit;
            end;
            VNames := VNames + FParser.GetToken + '|';
            FParser.Next;
          end;
          if FParser.CurrTokenId <> CSTI_Colon then
          begin
            Result := Cardinal(-1);
            if FParser = Self.FParser then
            MakeError('', ecColonExpected, '');
            exit;
          end;
          FParser.Next;
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            Result := Cardinal(-1);
            if FParser = Self.FParser then
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
          VCType := FindType(FParser.GetToken);
          if VCType = Cardinal(-1) then
          begin
            if FParser = Self.FParser then
            MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
            Result := Cardinal(-1);
            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 := Cardinal(-1);
            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 := Cardinal(-1);
          exit;
        end;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        Result := Cardinal(-1);
        if FParser = Self.FParser then
        MakeError('', ecIdentifierExpected, '');
        exit;
      end;
      VCType := FindType(FParser.GetToken);
      if VCType = Cardinal(-1) then
      begin
        if FParser = Self.FParser then
        MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
        Result := Cardinal(-1);
        exit;
      end;
      FParser.Next;
    end
    else
      VCType := Cardinal(-1);
    Decl := inttostr(VCType) + Decl;
    X := TIFPSProceduralType.Create;
    x.Name := Name;
    x.BaseType := btProcPtr;
    x.DeclarePosition := FParser.CurrTokenPos;
    x.TypeSize := 1;
    TIFPSProceduralType(x).ProcDef := Decl;
    FAvailableTypes.Add(X);
    Result := FAvailableTypes.Count -1;
  end; {AddProcedure}

begin
  if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
  begin
     Result := AddProcedure;
     Exit;
  end else if FParser.CurrTokenId = CSTI_OpenRound then
  begin
    FParser.Next;
    L := 0;
    P := TIFPSEnumType.Create;
    P.Name := Name;
    p.BaseType := btEnum;
    p.TypeSize := 1;
    p.DeclarePosition := FParser.CurrTokenPos;
    FAvailableTypes.Add(p);

    TypeNo := FAvailableTypes.Count -1;
    repeat
      if FParser.CurrTokenId <> CSTI_Identifier then
      begin
        if FParser = Self.FParser then
        MakeError('', ecIdentifierExpected, '');
        Result := Cardinal(-1);
        exit;
      end;
      s := FParser.GetToken;
      if IsDuplicate(s) then
      begin
        if FParser = Self.FParser then
        MakeError('', ecDuplicateIdentifier, s);
        Result := Cardinal(-1);
        Exit;
      end;
      AddConstant(s, TypeNo)^.Value.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 := Cardinal(-1);
        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 <> CSTII_Of then
    begin
      if FParser = Self.FParser then
      MakeError('', ecOfExpected, '');
      Result := Cardinal(-1);
      exit;
    end;
    FParser.Next;
    L := ReadType('', FParser);
    if L = -1 then
    begin
      if FParser = Self.FParser then
      MakeError('', ecUnknownIdentifier, '');
      Result := Cardinal(-1);
      exit;
    end;
    if Name = '' then
    begin
      TypeNo := ATNUT(l);
      if TypeNo <> Cardinal(-1) then
      begin
        for h := 0 to FUsedTypes.Count -1 do
        begin
          p := FUsedTypes.GetItem(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.GetItem(L) = P then
              begin
                Result := l;
                exit;
              end;
            end;
            if FParser = Self.FParser then
            MakeError('', ecInternalError, '0001C');
            Result := Cardinal(-1);
            Exit;
          end;
        end;
      end;
      for h := 0 to FAvailableTypes.Count -1 do
      begin
        p := FAvailableTypes.GetItem(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;
    p := TIFPSArrayType.Create;
    p.Name := Name;
    p.BaseType := btArray;
    p.TypeSize := 1;
    p.DeclarePosition := FParser.CurrTokenPos;
    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;
          if FParser = Self.FParser then
          MakeError('', ecIdentifierExpected, '');
          Result := Cardinal(-1);
          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.GetItem(l)).FieldNameHash = Longint(TypeNo)) and
            (PIFPSRecordFieldTypeDef(RecSubVals.GetItem(l)).FieldName = s) then
          begin
            if FParser = Self.FParser then
              MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
            ClearRecSubVals;
            Result := Cardinal(-1);
            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;
          Result := Cardinal(-1);
          exit;
        end;
        FParser.Next;
      until False;
      FParser.Next;
      l := ReadType('', FParser);
      if L = -1 then
      begin
        ClearRecSubVals;
        Result := Cardinal(-1);
        exit;
      end;
      P := FAvailableTypes.GetItem(L);
      if p.BaseType = BtTypeCopy then
        L := TIFPSTypeLink(p).LinkTypeNo;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        ClearRecSubVals;
        if FParser = Self.FParser then
        MakeError('', ecSemicolonExpected, '');
        Result := Cardinal(-1);
        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 := Name;
    p.BaseType := btRecord;
    p.DeclarePosition := FParser.CurrTokenPos;
    MakeRealFieldOffsets;
    for l := 0 to RecSubVals.Count -1 do
    begin
      rvv := RecSubVals.GetItem(l);
      with TIFPSRecordType(p).AddRecVal do
      begin
        FieldName := rvv.FieldName;
        RealFieldOffset := rvv.RealFieldOffset;
        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 := Cardinal(-1);
    for l := 0 to FAvailableTypes.Count - 1 do
    begin
      p2 := FAvailableTypes.GetItem(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 = Cardinal(-1) then
    begin
      Result := Cardinal(-1);
      if FParser = Self.FParser then
      MakeError('', ecUnknownType, FParser.OriginalToken);
      exit;
    end;
    if Name <> '' then
    begin
      p := TIFPSTypeLink.Create;
      p.Name := Name;
      p.BaseType := BtTypeCopy;
      p.DeclarePosition := FParser.CurrTokenPos;
      TIFPSTypeLink(p).LinkTypeNo := TypeNo;
      FAvailableTypes.Add(p);
      Result := FAvailableTypes.Count -1;
      Exit;
    end else
    begin
      Result := TypeNo;
      exit;
    end;
  end;
  Result := Cardinal(-1);
  if FParser = Self.FParser then
  MakeError('', ecIdentifierExpected, '');
  Exit;
end;


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

  function VarIsDuplicate(const 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 FAvailableTypes.Count - 1 do
    begin
      if (PIFPSType(FAvailableTypes.GetItem(l)).NameHash = h) and
        (PIFPSType(FAvailableTypes.GetItem(l)).Name = s) then
      begin
        Result := True;
        exit;
      end;
    end;

    for l := 0 to FProcs.Count - 1 do
    begin
      x := FProcs.GetItem(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.GetItem(l)).NameHash = h) and
          (PIFPSVar(proc.ProcVars.GetItem(l))^.Name = s) then
        begin
          Result := True;
          exit;
        end;
      end;
    end
    else
    begin
      for l := 0 to FVars.Count - 1 do
      begin
        if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
          (PIFPSVar(FVars.GetItem(l))^.Name = s) then
        begin
          Result := True;
          exit;
        end;
      end;
    end;
    v := VarName;
    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 (PIFPSConstant(FConstants.GetItem(l))^.NameHash = h) and
        (PIFPSConstant(FConstants.GetItem(l))^.Name = s) then
      begin
        Result := TRue;
        exit;
      end;
    end;
    Result := False;
  end;

begin
  Result := False;
  FParser.Next; // skip CSTII_Var
  if FParser.CurrTokenId <> CSTI_Identifier then
  begin
    MakeError('', ecIdentifierExpected, '');
    exit;
  end;
  repeat
    if VarIsDuplicate(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, Cardinal(-1), 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(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, Cardinal(-1), 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 = Cardinal(-1) 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
        New(v);
        v^.Used := False;
        v^.Name := s;
        v^.NameHash := MakeHash(v^.Name);
        v^.DeclarePosition := FParser.CurrTokenPos;
        
        v^.FType := VarType;
        FVars.Add(v);
      end
      else
      begin
        vp := TIFPSProcVar.Create;
        vp.Name := s;
        vp.aType := VarType;
        vp.DeclarePosition := FParser.CurrTokenPos;
        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 Name: string): TIFPSInternalProcedure;
begin
  Result := TIFPSInternalProcedure.Create;
  Result.Decl := '-1';
  Result.Name := Name;
  Result.DeclarePosition := FParser.CurrTokenPos;
  FProcs.Add(Result);
end;

function TIFPSPascalCompiler.ProcessLabel(Proc: TIFPSInternalProcedure): Boolean;
var
  CurrLabel: string;
  function IsProcDuplic(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) 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.GetItem(I)).NameHash = h) and (PIFPSProcVar(Proc.ProcVars.GetItem(I)).Name = s) then
        begin
          Result := True;
          exit;
        end;
      end;
      for i := 0 to Proc.FLabels.Count -1 do
      begin
        u := Proc.FLabels.GetItem(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;
begin
  FParser.Next;
  while true do
  begin
    if FParser.CurrTokenId <> CSTI_Identifier then
    begin
      MakeError('', ecIdentifierExpected, '');
      Result := False;
      exit;
    end;
    CurrLabel := FParser.GetToken;
    if IsDuplicate(CurrLabel) or IsProcDuplic(CurrLabel) then
    begin
      MakeError('', ecDuplicateIdentifier, '');
      Result := False;
      exit;
    end;
    FParser.Next;
    Proc.FLabels.Add(#$FF#$FF#$FF#$FF+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; TokenPos: Cardinal);
begin
  WriteDebugData(#4 + mi2s(ProcNo) + mi2s(Length(Proc.Data)) + mi2s(TokenPos));
end;
procedure TIFPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TIFPSInternalProcedure);
var
  I: Longint;
  s, d: string;
begin
  s := #2 + 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 + mi2s(ProcNo);
  for I := 0 to Proc.ProcVars.Count - 1 do
  begin
    s := s + PIFPSProcVar(Proc.ProcVars.GetItem(I)).Name + #1;
  end;
  s := s + #0;
  WriteDebugData(s);
end;



function TIFPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean): Boolean;
var
  FunctionType: TFuncType;
  FunctionName: string;
  FunctionParamNames: string;
  FunctionTempType: Cardinal;
  ParamNo: Cardinal;
  FunctionDecl: string;
  modifier: Char;
  Func: TIFPSInternalProcedure;
  F2: TIFPSProcedure;
  EPos: Cardinal;
  pp: TIFPSRegProc;
  pp2: TIFPSExternalProcedure;
  FuncNo, I: Longint;
  procedure CheckVars(Func: TIFPSInternalProcedure);
  var
    i: Integer;
    p: PIFPSProcVar;
  begin
    for i := 0 to Func.ProcVars.Count -1 do
    begin
      p := Func.ProcVars.GetItem(I);
      if not p.Used then
      begin
        MakeHint('', ehVariableNotUsed, p.Name)^.Position := p.DeclarePosition;
      end;
    end;
    if (not Func.ResultUsed) and (Fw(Func.Decl) <> '-1') then
    begin
      MakeHint('', ehVariableNotUsed, 'RESULT')^.Position := Func.DeclarePosition;
    end;
  end;

  function IsDuplic(const s: string): Boolean;
  var
    i: Longint;
    u: string;
  begin
    if s = 'RESULT' then
      Result := True
    else if FunctionName = s then
      Result := True
    else if IsDuplicate(s) 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.GetItem(I)).Name then
        begin
          Result := True;
          exit;
        end;
      end;
      for i := 0 to Func.FLabels.Count -1 do
      begin
        u := Func.FLabels.GetItem(i);
        delete(u, 1, 4);
        if u = s then
        begin
          Result := True;
          exit;
        end;
      end;
      Result := False;
    end;
  end;
  procedure WriteProcVars(t: TIfList);
  var
    l: Longint;
    v: PIFPSProcVar;
  begin
    for l := 0 to t.Count - 1 do
    begin
      v := t.GetItem(l);
      Func.Data := Func.Data  + chr(cm_pt)+ mi2s(v.AType);
    end;
  end;

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;
  FunctionName := FParser.GetToken;
  FuncNo := -1;
  for i := 0 to FProcs.Count -1 do
  begin
    f2 := FProcs.GetItem(i);
    if (f2.ClassType = TIFPSInternalProcedure) and (TIFPSInternalProcedure(f2).Name = FunctionName) and (TIFPSInternalProcedure(f2).Forwarded) then
    begin
      Func := FProcs.GetItem(i);
      FuncNo := i;
      Break;
    end;
  end;
  if (Func = nil) and IsDuplicate(FunctionName) 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 IsDuplic(FParser.GetToken) 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 IsDuplic(FParser.GetToken) 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 = Cardinal(-1) 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 = Cardinal(-1) 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;
    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(FunctionName);
    Func.Forwarded := True;
    Func.DeclarePosition := EPos;
    Func.Decl := FunctionDecl;
    Result := True;
    exit;
  end;
  if (Func = nil) then
  begin
    Func := NewProc(FunctionName);
    Func.Decl := FunctionDecl;
    Func.DeclarePosition := EPos;
    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.ProcVars);
  if not ProcessSub(tProcBegin, FuncNo, Func) then
  begin
    exit;
  end;
  CheckVars(Func);
  ProcessLabelForwards(Func);
  Result := True;
end;

function TIFPSPascalCompiler.DoTypeBlock(FParser: TIfPascalParser): Boolean;
var
  VName: string;
begin
  Result := False;
  FParser.Next;
  if FParser.CurrTokenId <> CSTI_Identifier then
  begin
    MakeError('', ecIdentifierExpected, '');
    exit;
  end;
  repeat
    VName := FParser.GetToken;
    if IsDuplicate(VName) 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(VName, FParser) = Cardinal(-1) 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;


function TIFPSPascalCompiler.ProcessSub(FType: TSubOptType; ProcNo: Cardinal; proc: TIFPSInternalProcedure): Boolean;


  procedure Debug_WriteLineEx(TokenPos: Cardinal);
  var
    b: Boolean;
  begin
    if @FOnWriteLine <> nil then begin
      b := FOnWriteLine(Self, TokenPos);
    end else
      b := true;
    if b then Debug_SavePosition(ProcNo, proc, TokenPos);
  end;

  procedure Debug_WriteLine;
  begin
    Debug_WriteLineEx(FParser.CurrTokenPos);
  end;

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

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

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

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

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

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

      function ChrToStr(s: string): {$IFNDEF NOWIDESTRING}widechar{$ELSE}char{$ENDIF};
      var
        w: Longint;
      begin
        Delete(s, 1, 1); {First char : #}
        w := StrToInt(s);
        Result := {$IFNDEF NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w);
        {$IFNDEF 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 NOWIDESTRING}
  var
    w: widestring;
    s: string;
  begin
    w := ParseString;
    if wchar then
    begin
      New(Result);
      if Length(w) = 1 then
      begin
        InitializeVariant(Result, GetType(btwidechar), btwidechar);
        Result^.twidechar := w[1];
      end else begin
        InitializeVariant(Result, GetType(btwidestring), btwidestring);
        tbtwidestring(Result^.twidestring) := w;
       end;
    end else begin
      s := w;
      New(Result);
      if Length(s) = 1 then
      begin
        InitializeVariant(Result, GetType(btchar), btchar);
        Result^.tchar := s[1];
      end else begin
        InitializeVariant(Result, GetType(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(Result, GetType(btchar), btchar);
      Result^.tchar := s[1];
    end else begin
      InitializeVariant(Result, GetType(btstring), btstring);
      tbtstring(Result^.tstring) := s;
    end;
  end;
  {$ENDIF}


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

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

  procedure WriteVariant(p: PIfRVariant);
  var
    px: PIFPSType;
  begin
    WriteLong(p^.FType);
    case p.BaseType of
    {$IFNDEF 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);
    btString:
      begin
        WriteLong(Length(tbtString(p^.tstring)));
        WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
      end;
    btenum:
      begin
        px := FUsedTypes.GetItem(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 NOINT64}
    bts64: WriteData(p^.ts64, 8);
    {$ENDIF}
    end;
  end;

  function GetParamType(I: Longint): Cardinal;
  var
    u, n: string;
  begin
    u := Proc.Decl;
    Inc(I);
    n := GRFW(u);
    if (I = 0) and (n <> '-1') then
    begin
      Result := StrToIntDef(n, -1);
      exit;
    end
    else if n <> '-1' then
      Inc(I);
    while I < 0 do
    begin
      GRFW(u);
      GRFW(u);
      Inc(I);
    end;
    GRFW(u);
    Result := StrToIntDef(GRFW(u), -1);
  end;
  function GetRecordTypeNo(x: PIFPSValue): Cardinal;
  var
    rr: PIFRecField;
  begin
    rr := x^.RecField.GetItem(x^.RecField.Count - 1);
    if rr^.FKind = 3 then
      rr := x^.RecField.GetItem(x^.RecField.Count - 2);
    Result := rr^.FType;
  end;
{$IFDEF DEBUG}
  var
    rdebug: array of Pointer;
{$ENDIF}
  function AllocStackReg(FType: Cardinal): PIFPSValue;
  var
    x: PIFPSProcVar;
  begin
    x := TIFPSProcVar.Create;
    x.DeclarePosition := FParser.CurrTokenPos;
    x.Name := '';
    x.AType := FType;
    Proc.ProcVars.Add(x);
    New(Result);
    Result^.FType := CVAL_AllocatedStackReg;
    Result^.DPos := FParser.CurrTokenPos;
    Result^.Address := IFPSAddrStackStart + Proc.ProcVars.Count;
    Result^.RecField := nil;
    Result^.Modifiers := 0;
    WriteCommand(Cm_Pt);
    WriteLong(FType);
    {$IFDEF DEBUG}SetLength(rdebug, length(rdebug)+1);rdebug[length(rdebug)-1] := Result; {$ENDIF}
  end;

  function AllocStackReg2(FType: Cardinal): PIFPSValue;
  var
    x: PIFPSProcVar;
  begin
    x := TIFPSProcVar.Create;
    x.DeclarePosition := FParser.CurrTokenPos;
    x.Name := '';
    x.AType := FType;
    Proc.ProcVars.Add(x);
    New(Result);
    Result^.FType := CVAL_AllocatedStackReg;
    Result^.RecField := nil;
    Result^.Modifiers := 0;
    Result^.Address := IFPSAddrStackStart + Proc.ProcVars.Count;
    {$IFDEF DEBUG}SetLength(rdebug, length(rdebug)+1);rdebug[length(rdebug)-1] := Result; {$ENDIF}
  end;
  function WriteCalculation(InData, OutReg: PIFPSValue): Boolean; forward;

  procedure DisposeStackReg(p: PIFPSValue);
  begin
    {$IFDEF DEBUG}
    if (rdebug[length(rdebug)-1] <> p) then
    begin
      asm int 3; end;
    end;
    SetLength(rdebug, length(rdebug)-1);
    {$ENDIF}

    TIFPSProcVar(Proc.ProcVars.GetItem(p^.Address - IFPSAddrStackStart - 1)).Free;
    Proc.ProcVars.Delete(Proc.ProcVars.Count - 1);
    DisposePValue(p);
    WriteCommand(CM_PO);
  end;
  function GetTypeNo(p: PIFPSValue): Cardinal; forward;

  function WriteOutRec(x: PIFPSValue; AllowData: Boolean): Boolean; forward;
  procedure AfterWriteOutRec(var x: PIFPSValue); forward;
  function FindProc(const Name: string): Cardinal; forward;
  function checkCompatType2(p1, p2: PIFPSType): 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.GetItem(TIFPSArrayType(p1).ArrayTypeNo), FUsedTypes.GetItem(TIFPSArrayType(p2).ArrayTypeNo))) or
      ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
      {$IFNDEF 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))
      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: PIFPSValue): Boolean;
  var
    p1, P2: PIFPSType;
  begin
    if (v1^.Modifiers and 4) <> 0 then
    begin
      Result := True;
      exit;
    end;
    p1 := FUsedTypes.GetItem(GetTypeNo(V1));
    P2 := FUsedTypes.GetItem(GetTypeNo(v2));
    Result := CheckCompatType2(p1, p2);
  end;

  function ProcessFunction(ResModifiers: Byte; ProcNo: Cardinal; InData: TIfList;
    ResultRegister:
    PIFPSValue): Boolean; forward;
  function ProcessVarFunction(ResModifiers: Byte; ProcNo: PIFPSValue; InData: TIfList;
    ResultRegister:
    PIFPSValue): Boolean; forward;

  function MakeNil(NilPos: Cardinal;ivar: PIFPSValue): Boolean;
  var
    Procno: Cardinal;
    PF: PIFPSType;
    Par: TIfList;
    pp: PParam;
  begin
    Pf := FUsedTypes.GetItem(GetTypeNo(IVar));
    if (pf.BaseType <> btClass) or (not TIFPSClassType(pf).ClassHelper.SetNil(GetTypeno(IVar), ProcNo)) or ((Ivar.FType <> CVAL_Addr)and(Ivar.FType <> CVAL_AllocatedStackReg)) then
    begin
      MakeError('', ecTypeMismatch, '')^.Position := nilPos;
      Result := False;
      exit;
    end;
    ivar.FType := CVAL_PushAddr;
    ivar.Modifiers := ivar.modifiers or 128;
    Par := TIfList.Create;
    new(pp);
    pp^.InReg := ivar;
    pp^.OutReg := nil;
    pp^.FType := GetTypeNo(ivar);
    pp^.OutRegPos := NilPos;
    par.add(pp);
    Result := ProcessFunction(0, ProcNo, Par, nil);
    Dispose(pp);
    Par.Free;
    ivar.Modifiers := ivar.modifiers and not 128;
  end;

  function PreWriteOutRec(var X: PIFPSValue; FArrType: Cardinal): Boolean;
  var
    rr: PIFRecField;
    tmpp,
      tmpc: PIFPSValue;
    i: Longint;
  begin
    Result := True;
    if x^.FType = CVAL_NIL then
    begin
      if FArrType = Cardinal(-1) then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := False;
        Exit;
      end;
      tmpp := AllocStackReg(FArrType);
      if not MakeNil(x^.DPos, tmpp) then
      begin
        DisposeStackReg(tmpp);
        Result := False;
        exit;
      end;
      tmpp^.FType := CVAL_ArrayAllocatedStackRec;
      x := tmpp;
    end else
    if x^.FType = CVAL_Array then
    begin
      if FArrType = Cardinal(-1) then
      begin
        MakeError('', ecTypeMismatch, '');
        Result := False;
        Exit;
      end;
      tmpp := AllocStackReg(FArrType);
      tmpp^.FType := CVAL_ArrayAllocatedStackRec;
      tmpc := AllocStackReg(GetType(bts32));
      WriteCommand(CM_A);
      WriteOutrec(tmpc, False);
      WriteByte(1);
      WriteLong(GetType(bts32));
      WriteLong(x^.ArrayItems.Count);
      WriteCommand(CM_PV);
      WriteOutrec(tmpp, False);
      WriteCommand(CM_C);
      WriteLong(FindProc('SETARRAYLENGTH'));
      WriteCommand(CM_PO);
      DisposeStackReg(tmpc);
      new(tmpc);
      tmpc^.FType := CVAL_Addr;
      tmpc^.Modifiers := 0;
      tmpc^.DPos := tmpp^.DPos;
      tmpc^.Address := tmpp^.Address;
      tmpc^.RecField := TIFList.Create;
      new(rr);
      rr^.FKind := 1;
      rr^.FType := TIFPSArrayType(FUsedTypes.GetItem(FArrType)).ArrayTypeNo;
      tmpc^.RecField.Add(rr);
      for i := 0 to x^.ArrayItems.Count -1 do
      begin
        rr^.ArrayFieldNo := i;
        if not WriteCalculation(x^.ArrayItems.GetItem(i), tmpc) then
        begin
          DisposePValue(tmpc);
          DisposeStackReg(tmpp);
          Result := False;
          Exit;
        end;
      end;
      x := tmpp;
    end else if (x^.FType = CVAL_Eval) then
    begin
      tmpp := AllocStackReg(x^.frestype);
      WriteCalculation(x, tmpp);
      if x^.Modifiers = 1 then
      begin
        if (at2ut(FBooleanType) = x^.frestype) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end else
      if x^.Modifiers = 2 then
      begin
        WriteCommand(cm_vm);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end;
      tmpp^.DPos := cardinal(x);
      x := tmpp;
      x^.FType := CVAL_AllocatedStackReg + 1;
    end else if (x^.FType = CVAL_Proc) or (x^.FType = CVAL_VarProc) then
    begin
      if x^.FType = CVAL_VarProc then
      begin
        tmpp := AllocStackReg(StrToIntDef(Fw(TIFPSProceduralType(FUsedTypes.GetItem(GetTypeNo(x^._ProcNo))).ProcDef), -1));
      end else if TIFPSProcedure(FProcs.GetItem(x^.ProcNo)).ClassType = TIFPSInternalProcedure then
        tmpp := AllocStackReg(StrToIntDef(Fw(TIFPSInternalProcedure(FProcs.GetItem(x^.ProcNo)).Decl), -1))
      else
        tmpp := AllocStackReg(StrToIntDef(Fw(TIFPSExternalProcedure(FPRocs.GetItem(x^.ProcNo)).RegProc.Decl), -1));
      WriteCalculation(x, tmpp);
      if x^.Modifiers = 1 then
      begin
        if (at2ut(FBooleanType) = GetTypeNo(tmpp)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end else
      if x^.Modifiers = 2 then
      begin
        WriteCommand(cm_vm);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end;
      tmpp^.DPos := cardinal(x);
      x := tmpp;
      x^.FType := CVAL_AllocatedStackReg + 1;
   end else
    if ((x^.FType = CVAL_Addr) or (x^.FType = CVAL_PushAddr)) and (x^.RecField <> nil) then
    begin
      if x^.RecField.Count = 1 then
      begin
        rr := x^.RecField.GetItem(0);
        if rr^.FKind < 2 then
          exit; // there is no need pre-calculate anything
        if rr^.ReadArrayFieldNoFrom^.FType = CVAL_Addr then
          exit;
      end; //if
      rr := x^.RecField.GetItem(x^.RecField.Count-1);
      if rr^.FKind = 3 then
      begin
        Inc(rr^.FType); 
        exit;
      end;

      tmpp := AllocStackReg(GetType(btPointer));
      WriteCommand(cm_sp);
      WriteOutRec(tmpp, True);
      WriteByte(0);
      WriteLong(x^.Address);

      for i := 0 to x^.RecField.Count - 1 do
      begin
        rr := x^.RecField.GetItem(I);
        case rr^.FKind of
          0, 1:
            begin
              WriteCommand(cm_sp);
              WriteOutRec(tmpp, false);
              WriteByte(2);
              WriteLong(tmpp^.Address);
              WriteLong(rr^.RecFieldNo);
            end; // case 0,1
          2:
            begin
              tmpc := AllocStackReg(GetType(btU32));
              if not WriteCalculation(rr^.ReadArrayFieldNoFrom, tmpc) then
              begin
                DisposeStackReg(tmpc);
                DisposeStackReg(tmpp);
                Result := False;
                exit;
              end; //if
              WriteCommand(cm_sp);
              WriteOutRec(tmpp, false);
              WriteByte(3);
              WriteData(tmpp^.Address, 4);
              WriteData(tmpc^.Address, 4);
              DisposeStackReg(tmpc);
            end; // case 2
        end; // case
        //Dispose(rr);
      end; // for
      if x^.Modifiers = 1 then
      begin
        if (at2ut(FBooleanType) = GetTypeNo(tmpp)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end else
      if x^.Modifiers = 2 then
      begin
        WriteCommand(cm_vm);
        WriteByte(0);
        WriteLong(Tmpp^.Address);
      end;
      new(rr);
      rr^.FKind := 3;
      rr^.ResultRec := tmpp;
      rr^.FType := 1;
      x^.RecField.Add(rr);
    end else if (x^.Modifiers and 3) <> 0 then
    begin
      if x^.FType = CVAL_Addr then
      begin
        tmpp := AllocStackReg(GetTypeNo(x));
        tmpp^.FType := CVAL_AllocatedStackReg + 1;
        WriteCommand(CM_A);
        WriteByte(0);
        WriteLong(tmpp^.Address);
        WriteByte(0);
        WriteLong(x^.Address);
        if x^.Modifiers = 1 then
        begin
        if (at2ut(FBooleanType) = GetTypeNo(x)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
          WriteByte(0);
          WriteLong(Tmpp^.Address);
        end else
        if x^.Modifiers = 2 then
        begin
          WriteCommand(cm_vm);
          WriteByte(0);
          WriteLong(Tmpp^.Address);
        end;
        tmpp^.DPos := cardinal(x);
        x := tmpp;
      end else if x^.FType = CVAL_PushAddr then
      begin
        if x^.Modifiers = 1 then
        begin
        if (at2ut(FBooleanType) = GetTypeNo(x)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
          WriteByte(0);
          WriteLong(x^.Address);
        end else
        if x^.Modifiers = 2 then
        begin
          WriteCommand(cm_vm);
          WriteByte(0);
          WriteLong(x^.Address);
        end;
      end;
    end;
  end;

  procedure AfterWriteOutRec(var x: PIFPSValue);
  var
    rr: PIFRecField;
    p: Pointer;
  begin
    if x^.FType = CVAL_ArrayAllocatedStackRec then
    begin
      DisposeStackReg(x);
    end else
    if x^.FType = CVAL_AllocatedStackReg +1 then
    begin
      p := Pointer(x^.DPos);
      DisposeStackReg(x);
      x := p;
    end else if ((x^.FType = CVAL_Addr) or (x^.FType = CVAL_PushAddr)) and (x^.RecField <> nil) then
    begin
      rr := x^.RecField.GetItem(x^.Recfield.Count-1);
      if (rr^.FKind = 3) then
      begin
        Dec(rr^.FType);
        if rr^.FType = 0 then
        begin
          DisposeStackReg(rr^.ResultRec);
          Dispose(Rr);
          x^.RecField.Delete(x^.Recfield.Count-1);
        end;
      end;
    end;
  end; //afterwriteoutrec

  function WriteOutRec(x: PIFPSValue; AllowData: Boolean): Boolean;
  var
    rr: PIFRecField;
  begin
    Result := True;
    case x^.FType of
      CVAL_ArrayAllocatedStackRec, CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg, CVAL_AllocatedStackReg + 1:
        begin
          if x^.RecField = nil then
          begin
            WriteByte(0);
            WriteData(x^.Address, 4);
          end
          else
          begin
            rr := x^.RecField.GetItem(x^.RecField.Count -1);
            case rr^.FKind of
              0, 1:
                begin
                  WriteByte(2);
                  WriteLong(x^.Address);
                  WriteLong(rr^.RecFieldNo);
                end;
              2:
                begin
                  WriteByte(3);
                  WriteLong(x^.Address);
                  WriteLong(rr^.ReadArrayFieldNoFrom^.Address);
                end;
              3:
                begin
                  WriteByte(0);
                  WriteLong(rr^.ResultRec^.Address);
                end;
            end;
          end;
        end;
      CVAL_Data:
        if AllowData then
        begin
          WriteByte(1);
          WriteVariant(x^.FData)
        end
        else
        begin
          Result := False;
          exit;
        end;
    else
      Result := False;
    end;
  end;

  function GetTypeNo(p: PIFPSValue): Cardinal;
  var
    n: TIFPSProcedure;
  begin
    if (p^.Modifiers and 8) <> 0 then
    begin
      Result := p^.FNewTypeNo;
      exit;
    end;
    if (p^.RecField <> nil) and (p^.FType = CVAL_Addr) then
    begin
      Result := GetRecordTypeNo(p);
    end
    else
      case p^.FType of
        CVAL_Cast:
        begin
          Result := p^.NewTypeNo;
        end;
        CVAL_Array:
        begin
          Result := at2ut(FindType('TVariantArray'));
        end;
        CVAL_ArrayAllocatedStackRec, CVAL_Addr, CVAL_AllocatedStackReg, CVAL_PushAddr:
          begin
            if p^.Address < IFPSAddrNegativeStackStart then
            begin
              if p^.Address < FVars.Count then
              begin
                Result := PIFPSVar(FVars.GetItem(p^.Address))^.FType;
              end
              else
                Result := Cardinal(-1);
            end
            else
            begin
              if p^.Address < IFPSAddrStackStart then
              begin
                Result := GetParamType(p^.Address - IFPSAddrStackStart);
              end
              else
                Result := PIFPSProcVar(Proc.ProcVars.GetItem(p^.Address - 1 -
                  IFPSAddrStackStart)).AType;
            end;
          end;
        CVAL_Data: Result := p^.FData^.FType;
        CVAL_VarProc:
          begin
            Result := StrToIntDef(Fw(TIFPSProceduralType(FUsedTypes.GetItem(GetTypeNo(p^._ProcNo))).ProcDef), -1);
          end;
        CVAL_Proc:
          begin
            n := TIFPSProcedure(FProcs.GetItem(p^.ProcNo));

            if n.ClassType = TIFPSInternalProcedure then
              Result := StrToIntDef(Fw(TIFPSInternalProcedure(n).Decl), -1)
            else
              Result := StrToIntDef(Fw(TIFPSExternalProcedure(n).RegProc.Decl), -1);
          end;
        CVAL_Eval: Result := p^.frestype;
      else
        Result := Cardinal(-1);
      end;
  end;

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

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

  begin
    h := MakeHash(Name);
    for l := 0 to FProcs.Count - 1 do
    begin
      x := FProcs.GetItem(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.GetItem(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 := Cardinal(-1);
  end; {findfunc}

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

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

  function GetIdentifier(const FType: Byte): PIFPSValue;
    {
      FType:
        0 = Anything
        1 = Only variables
        2 = Not constants
    }
  var
    Temp: PIFPSValue;
    l, h: Longint;
    s, u: string;
    t: PIFPSConstant;
    Temp1: Cardinal;

    procedure CheckProcCall(var x: PIFPSValue);
    begin
      if FParser.CurrTokenId = CSTI_Dereference then
      begin
        if PIFPSType(FUsedTypes.GetItem(GetTypeNo(x))).BaseType <> btProcPtr then
        begin
          MakeError('', ecTypeMismatch, '');
          DisposePValue(x);
          x := nil;
          Exit;
        end;
        FParser.Next;
        x := ReadVarParameters(x);
      end;
    end;

    procedure CheckFurther(var x: PIFPSValue);
    var
      t: Cardinal;
      rr: PIFRecField;
      LastRecType, I, LL: Longint;
      u: PIFPSType;
      Param: PParam;
      NewRecFields: TIfList;
      tmp, tmp3: PIFPSValue;
      tmp2: Boolean;

      function FindSubR(const n: string; FType: PIFPSType): 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 := Cardinal(-1);
      end;

    begin
      if (x^.FType <> CVAL_Addr) and (x^.FType <> CVAL_PushAddr) and (x^.FType <> CVAL_AllocatedStackReg) then
        Exit;
      x.RecField := nil;
      t := GetTypeNo(x);
      u := FUsedTypes.GetItem(t);
      if u.BaseType = btClass then exit;
      while True do
      begin
        if FParser.CurrTokenId = CSTI_OpenBlock then
        begin
          if (u.BaseType = btString) and (x^.FType = CVAL_Addr) then
          begin
            x^.FType := CVAL_PushAddr;
             FParser.Next;
            tmp := Calc(CSTI_CloseBlock);
            if tmp = nil then
            begin
              DisposePValue(x);
              x := nil;
              exit;
            end;
            if not IsIntType(PIFPSType(FUSedTypes.GetItem(GetTypeNo(tmp))).BaseType) then
            begin
              MakeError('', ecTypeMismatch, '');
              DisposePValue(tmp);
              DisposePValue(x);
              x := nil;
              exit;
            end;
            FParser.Next;
            if FParser.CurrTokenId = CSTI_Assignment then
            begin
              l := FindProc('STRSET');
              if l = -1 then
              begin
                MakeError('', ecUnknownIdentifier, 'StrGet');
                DisposePValue(tmp);
                DisposePValue(x);
                x := nil;
                exit;
              end;
              New(tmp3);
              tmp3^.FType :=CVAL_Proc;
              tmp3^.Modifiers := 0;
              tmp3^.DPos := FParser.CurrTokenPos;
              tmp3^.ProcNo := L;
              tmp3^.Parameters := TIfList.Create;
              new(Param);
              tmp3^.Parameters.Add(Param);
              new(Param);
              param^.InReg := tmp;
              Param^.FType := GetTypeNo(tmp);
              Param^.OutReg := nil;
              Param^.OutRegPos := tmp^.DPos;
              tmp3^.Parameters.Add(Param);
              new(Param);
              param^.InReg := x;
              Param^.FType := GetTypeNo(x);
              Param^.OutReg := nil;
              Param^.OutRegPos := tmp^.DPos;
              tmp3^.Parameters.Add(Param);
              Param := tmp3^.Parameters.GetItem(0);
              x := tmp3;
              FParser.Next;
              tmp := Calc(CSTI_SemiColon);
              if tmp = nil then
              begin
                Param := x^.Parameters.GetItem(0);
                x^.Parameters.Delete(0);
                Dispose(Param);
                DisposePValue(x);
                x := nil;
                exit;
              end;
              if PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp))).BaseType <> btChar then
              begin
                Param := x^.Parameters.GetItem(0);
                x^.Parameters.Delete(0);
                Dispose(Param);
                MakeError('', ecTypeMismatch, '');
                DisposePValue(Tmp);
                x^.Parameters.Delete(0);
                DisposePValue(x);
                x := nil;
                exit;
              end;
              Param^.InReg := tmp;
              Param^.OutReg := nil;
              param^.FType := GetTypeNo(tmp);
              Param^.OutRegPos := tmp^.DPos;
            end else begin
              l := FindProc('STRGET');
              if l = -1 then
              begin
                MakeError('', ecUnknownIdentifier, 'StrGet');
                DisposePValue(tmp);
                DisposePValue(x);
                x := nil;
                exit;
              end;
              New(tmp3);
              tmp3^.FType :=CVAL_Proc;
              tmp3^.Modifiers := 0;
              tmp3^.DPos := FParser.CurrTokenPos;
              tmp3^.ProcNo := L;
              tmp3^.Parameters := TIfList.Create;
              new(Param);
              param^.InReg := x;
              Param^.FType := GetTypeNo(x);
              Param^.OutReg := nil;
              Param^.OutRegPos := tmp^.DPos;
              tmp3^.Parameters.Add(Param);
              new(Param);
              param^.InReg := tmp;
              Param^.FType := GetTypeNo(tmp);
              Param^.OutReg := nil;
              Param^.OutRegPos := tmp^.DPos;
              tmp3^.Parameters.Add(Param);
              x := tmp3;
            end;
            Break;
          end else if u.BaseType = btArray then
          begin
            FParser.Next;
            tmp := calc(CSTI_CloseBlock);
            if tmp = nil then
            begin
              DisposePValue(x);
              x := nil;
              exit;
            end;
            if not IsIntType(PIFPSType(FUSedTypes.GetItem(GetTypeNo(tmp))).BaseType) then
            begin
              MakeError('', ecTypeMismatch, '');
              DisposePValue(tmp);
              DisposePValue(x);
              x := nil;
              exit;
            end;
            if tmp^.FType = CVAL_Data then
            begin
              if x.RecField = nil then
                x.RecField := TIfList.Create;
              new(rr);
              rr^.FKind := 1;
              rr^.ArrayFieldNo := GetUInt(FUsedTypes, tmp^.FData, tmp2);
              DisposePValue(tmp);
              rr^.FType := TIFPSArrayType(u).ArrayTypeNo;
              u := FUsedTypes.GetItem(rr^.FType);
              x^.RecField.Add(rr);
            end
            else
            begin
              if x.RecField = nil then
                x.RecField := TIfList.Create;
              new(rr);
              rr^.FKind := 2;
              rr^.ReadArrayFieldNoFrom := tmp;
              rr^.FType := TIFPSArrayType(u).ArrayTypeNo;
              u := FUsedTypes.GetItem(rr^.FType);
              x^.RecField.Add(rr);
            end;
            if FParser.CurrTokenId <> CSTI_CloseBlock then
            begin
              MakeError('', ecCloseBlockExpected, '');
              DisposePValue(x);
              x := nil;
              exit;
            end;
            Fparser.Next;
          end else begin
            MakeError('', ecSemicolonExpected, '');
            DisposePValue(x);
            x := nil;
            exit;
          end;
        end
        else if FParser.CurrTokenId = CSTI_Period then
        begin
          FParser.Next;
          if u.BaseType = btRecord then
          begin
            t := FindSubR(FParser.GetToken, u);
            if t = Cardinal(-1) then
            begin
              MakeError('', ecUnknownIdentifier, '');
              DisposePValue(x);
              x := nil;
              exit;
            end;
            FParser.Next;
            if x.RecField = nil then
              x.RecField := TIfList.Create;
            new(rr);
            rr^.FKind := 0;
            rr^.FType := TIFPSRecordType(u).RecVal(t).FType;
            rr^.RecFieldNo := t;
            u := FUsedTypes.GetItem(rr^.FType);
            x^.RecField.Add(rr);
          end
          else
          begin
            DisposePValue(x);
            MakeError('', ecSemicolonExpected, '');
            x := nil;
            exit;
          end;
        end
        else
          break;
      end;
      if x^.RecField = nil then
        exit;
      LL := -1;
      NewRecFields := TIfList.Create;
      if x^.FType = 0 then
      begin
        if x^.Address < IFPSAddrNegativeStackStart then
          LastRecType := PIFPSVar(FVars.GetItem(x^.Address))^.FType
        else if x^.Address < IFPSAddrStackStart then
        begin
          LastRecType := GetParamType(Longint(x^.Address - IFPSAddrStackStart));
        end
        else
          LastRecType := PIFPSProcVar(Proc.ProcVars.GetItem(x^.Address - 1 - IFPSAddrStackStart)).AType;
        i := 0;
        u := FUsedTypes.GetItem(LastRecType);

        while i < Longint(x^.RecField.Count) do
        begin
          rr := x^.RecField.GetItem(I);
          case rr^.FKind of
            0:
              begin
                if LL = -1 then
                  inc(ll);
                LastRecType := rr^.FType;

                LL := LL + Longint(TIFPSRecordType(u).RecVal(rr^.RecFieldNo).RealFieldOffset);
                u := FUsedTypes.GetItem(LastRecType);
                dispose(rr);
              end;
            1:
              begin
                if LL <> -1 then
                begin
                  new(rr);
                  rr^.FKind := 0;
                  rr^.RecFieldNo := LL;
                  rr^.FType := LastRecType;
                  newRecFields.Add(Rr);
                  rr := x^.RecField.GetItem(I);
                end;
                u := FUsedTypes.GetItem(rr^.FType);
                newRecFields.Add(rr);
                LL := -1;
              end;
            2:
              begin
                if LL <> -1 then
                begin
                  new(rr);
                  rr^.FKind := 0;
                  rr^.FType := LastRecType;
                  rr^.RecFieldNo := LL;
                  newRecFields.Add(Rr);
                  rr := x^.RecField.GetItem(I);
                end;
                u := FUsedTypes.GetItem(rr^.FType);
                newRecFields.Add(rr);
                LL := -1;
              end;

          end;
          inc(i);
        end;
        if LL <> -1 then
        begin
          new(rr);
          rr^.FKind := 0;
          rr^.RecFieldNo := LL;
          rr^.FType := LastRecType;
          newRecFields.Add(Rr);
        end;
        x^.RecField.Free;
        x^.RecField := NewRecFields;
      end;
    end;
    function ReadPropertyParameters(Params: TIfList; ParamTypes: string): Boolean;
    var
      CurrParamType: Cardinal;
      Temp: PIFPSValue;
      P: PParam;
    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;
        New(P);
        p^.InReg := Temp;
        p^.OutReg := nil;
        p^.FType := CurrParamType;
        p^.OutRegPos := FParser.CurrTokenPos;
        Params.Add(p);
        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 CheckClass(var P: PIFPSValue; const VarType: TIFPSVariableType; VarNo: Cardinal);
    var
      Idx, FTypeNo: Cardinal;
      FType: PIFPSType;
      TempP: PIFPSValue;
      Param: PParam;
      s: string;

      pinfo: string;

    begin
      FTypeNo := GetTypeNo(p);
      if FTypeNo = Cardinal(-1) then Exit;
      FType := FUsedTypes.GetItem(FTypeNo);
      if FType.BaseType <> btClass then Exit;
      while FParser.CurrTokenID = CSTI_Period do
      begin
        FParser.Next;
        if FParser.CurrTokenID <> CSTI_Identifier then
        begin
          MakeError('', ecIdentifierExpected, '');
          DisposePValue(p);
          P := nil;
          Exit;
        end;
        s := FParser.GetToken;
        if TIFPSClassType(FType).ClassHelper.Func_Find(s, Idx) then
        begin
          FParser.Next;
          VarNo := Cardinal(-1);
          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
          if VarNo <> Cardinal(-1) then
          begin
            if pinfo = '' then
              pinfo := s
            else
              pinfo := pinfo + '.' + s;
            if @FOnUseVariable <> nil then
              FOnUseVariable(Self, VarType, VarNo, ProcNo, FParser.CurrTokenPos, PInfo);
          end;
          FParser.Next;
          TIFPSClassType(FType).ClassHelper.Property_GetHeader(Idx, s);
          TempP := P;
          New(P);
          P^.FType := CVAL_Proc;
          p^.Modifiers := 0;
          p^.DPos := FParser.CurrTokenPos;
          P^.Parameters := TIfList.Create;
          new(param);
          Param^.InReg := TempP;
          Param^.OutReg := nil;
          Param^.FType := GetTypeNo(TempP);
          P^.Parameters.Add(Param);
          if pos(' ', s) <> 0 then
          begin
            if not ReadPropertyParameters(P^.Parameters, s) then
            begin
              DisposePValue(P);
              P := nil;
              exit;
            end;
          end; // if
          if FParser.CurrTokenId = CSTI_Assignment then
          begin
            FParser.Next;
            TempP := Calc(CSTI_SemiColon);
            if TempP = nil then
            begin
              DisposePValue(P);
              p := nil;
              exit;
            end;
            new(param);
            Param^.InReg := tempp;
            Param^.OutReg := nil;
            Param^.FType := at2ut(StrToIntDef(fw(s), -1));
            P^.Parameters.Add(Param);
            if not TIFPSClassType(FType).ClassHelper.Property_Set(Idx, p^.ProcNo) then
            begin
              MakeError('', ecReadOnlyProperty, '');
              DisposePValue(p);
              p := nil;
              exit;
            end;
            Exit;
          end else begin
            if not TIFPSClassType(FType).ClassHelper.Property_Get(Idx, p^.ProcNo) then
            begin
              MakeError('', ecWriteOnlyProperty, '');
              DisposePValue(p);
              p := nil;
              exit;
            end;
          end; // if FParser.CurrTokenId = CSTI_Assign
        end else
        begin
          MakeError('', ecUnknownIdentifier, s);
          DisposePValue(p);
          P := nil;
          Exit;
        end;
        FTypeNo := GetTypeNo(p);
        FType := FUsedTypes.GetItem(FTypeNo);
        if (FType = nil) or (FType.BaseType <> btClass) then Exit;
      end; {while}
    end;
    function CheckClassType(const TypeNo, ParserPos: Cardinal): PIFPSValue;
    var
      FType, FType2: PIFPSType;
      ProcNo, Idx: Cardinal;
      PP: PParam;
      Temp: PIFPSValue;
    begin
      FType := FAvailableTypes.GetItem(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
          DisposePValue(temp);
          MakeError('', ecCloseRoundExpected, '');
          Result := nil;
          exit;
        end;
        FType2 := FUsedTypes.GetItem(GetTypeNo(Temp));
        if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
        begin
          if not TIFPSClassType(FType2).ClassHelper.CastToType(GetTypeNo(Temp), AT2UT(TypeNo), ProcNo) then
          begin
            DisposePValue(Temp);
            MakeError('', ecTypeMismatch, '');
            Result := nil;
            exit;
          end;
          New(Result);
          Result^.FType := CVAL_Proc;
          Result^.Modifiers := 8;
          Result^.FNewTypeNo := at2ut(TypeNo);
          Result^.DPos := FParser.CurrTokenPos;
          Result^.Parameters := TIfList.Create;
          Result^.ProcNo := ProcNo;
          New(pp);
          pp^.InReg := Temp;
          pp^.OutReg := nil;
          pp^.FType := GetTypeNo(Temp);
          Result^.Parameters.Add(pp);
          New(pp);
          pp^.OutReg := nil;
          pp^.FType := GetType(btu32);
          New(pp^.InReg);
          pp^.InReg^.FType := CVAL_Data;
          pp^.InReg^.Modifiers := 0;
          pp^.InReg^.DPos := FParser.CurrTokenPos;
          New(pp^.InReg^.FData);
          pp^.InReg^.FData^.FType := pp^.FType;
          pp^.Inreg^.FData.BaseType:= PIFPSType(FUsedTypes.GetItem(pp^.FType)).BaseType;
          pp^.INreg^.FData^.tu32 := at2ut(TypeNo);
          Result^.Parameters.Add(pp);
          FParser.Next;
          Exit;
        end;
        if not checkCompatType2(FType, FType2) then
        begin
          DisposePValue(Temp);
          MakeError('', ecTypeMismatch, '');
          Result := nil;
          exit;
        end;
        FParser.Next;
        New(Result);
        Result^.FType := CVAL_Cast;
        Result^.Modifiers := 0;
        Result^.DPos := FParser.CurrTokenPos;
        Result^.Input := Temp;
        Result^.NewTypeNo := AT2UT(TypeNo);
        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);
      New(Temp);
      Temp^.FType := CVAL_Data;
      Temp^.Modifiers := 0;
      New(Temp^.FData);
      Temp^.FData^.FType := GetType(btU32);
      Temp^.FData.BaseType := btU32;
      temp^.FData^.tu32 := at2ut(TypeNo);
      Result := ReadParameters(ProcNo, Temp);
      if Result <> nil then
      begin
        Result^.Modifiers := Result^.Modifiers or 8;
        Result^.FNewTypeNo := AT2UT(TypeNo);
      end;
    end;

  var
    vt: TIFPSVariableType;
    vno: Cardinal;

  begin
    s := FParser.GetToken;
    h := MakeHash(s);
    u := proc.Decl;
    if s = 'RESULT' then
    begin
      if GRFW(u) = '-1' then
      begin
        Result := nil;
        MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
      end
      else
      begin
        Proc.ResultUse;
        New(Result);
        Result^.FType := CVAL_Addr;
        Result^.Modifiers := 0;
        Result^.Address := IFPSAddrStackStart - 1;
        Result^.DPos := FParser.CurrTokenPos;
        Result^.RecField := nil;
        vt := ivtParam;
        vno := 0;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result);
          if Result <> nil then CheckClass(Result, vt, vno);
          if Result <> nil then CheckProcCall(Result);
          vno := Cardinal(-1);
        until (Result = nil) or (Temp = Result);
      end;
      exit;
    end;
    if GRFW(u) <> '-1' then
      l := -2
    else
      l := -1;
    while Length(u) > 0 do
    begin
      if D1(GRFW(u)) = s then
      begin
        New(Result);
        Result^.FType := CVAL_Addr;
        Result^.Modifiers := 0;
        Result^.Address := IFPSAddrStackStart + Cardinal(l);
        Result^.RecField := nil;
        vt := ivtParam;
        vno := -1 - L;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        Result^.DPos := FParser.CurrTokenPos;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result);
          if Result <> nil then CheckClass(Result, vt, vno);
          if Result <> nil then CheckProcCall(Result);
          vno := Cardinal(-1);
        until (Result = nil) or (Temp = Result);
        exit;
      end;
      Dec(l);
      GRFW(u);
    end;

    for l := 0 to Proc.ProcVars.Count - 1 do
    begin
      if (PIFPSProcVar(Proc.ProcVars.GetItem(l)).NameHash = h) and
        (PIFPSProcVar(Proc.ProcVars.GetItem(l)).Name = s) then
      begin
        PIFPSProcVar(Proc.ProcVars.GetItem(l)).Use;
        vno := l;
        vt := ivtVariable;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, ProcNo, FParser.CurrTokenPos, '');
        New(Result);
        Result^.FType := CVAL_Addr;
        Result^.Modifiers := 0;
        Result^.Address := IFPSAddrStackStart + Cardinal(l) + 1;
        Result^.DPos := FParser.CurrTokenPos;
        Result^.RecField := nil;

        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result);
          if Result <> nil then CheckClass(Result, vt, vno);
          if Result <> nil then CheckProcCall(Result);
          vno := Cardinal(-1);
        until (Result = nil) or (Temp = Result);

        exit;
      end;
    end;

    for l := 0 to FVars.Count - 1 do
    begin
      if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
        (PIFPSVar(FVars.GetItem(l))^.Name = s) then
      begin
        PIFPSVar(FVars.GetItem(l))^.Used := True;
        New(Result);
        Result^.FType := CVAL_Addr;
        Result^.Modifiers := 0;
        Result^.Address := l;
        Result^.RecField := nil;
        Result^.DPos := FParser.CurrTokenPos;
        vt := ivtGlobal;
        vno := l;
        if @FOnUseVariable <> nil then
          FOnUseVariable(Self, vt, vno, ProcNo, FParser.CurrTokenPos, '');
        FParser.Next;
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result);
          if Result <> nil then CheckClass(Result, vt, vno);
          if Result <> nil then CheckProcCall(Result);
          vno := Cardinal(-1);
        until (Result = nil) or (Temp = Result);
        exit;
      end;
    end;
    Temp1 := FindType(FParser.GetToken);
    if Temp1 <> Cardinal(-1) then
    begin
      l := FParser.CurrTokenPos;
      if FType = 1 then
      begin
        Result := nil;
        MakeError('', ecVariableExpected, FParser.OriginalToken);
        exit;
      end;
      vt := ivtGlobal;
      vno := Cardinal(-1);
      FParser.Next;
      Result := CheckClassType(Temp1, l);
        repeat
          Temp := Result;
          if Result <> nil then CheckFurther(Result);
          if Result <> nil then CheckClass(Result, vt, vno);
          if Result <> nil then CheckProcCall(Result);
          vno := Cardinal(-1);
        until (Result = nil) or (Temp = Result);

      exit;
    end;
    Temp1 := FindProc(FParser.GetToken);
    if Temp1 <> Cardinal(-1) then
    begin
      l := FParser.CurrTokenPos;
      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^.DPos := l;
      vt := ivtGlobal;
      vno := Cardinal(-1);
      repeat
        Temp := Result;
        if Result <> nil then CheckFurther(Result);
        if Result <> nil then CheckClass(Result, vt, vno);
        if Result <> nil then CheckProcCall(Result);
        vno := Cardinal(-1);
      until (Result = nil) or (Temp = Result);
      exit;
    end;
    for l := 0 to FConstants.Count -1 do
    begin
      t := PIFPSConstant(FConstants.GetItem(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;
        new(result);
        Result^.FType := CVAL_Data;
        Result^.DPos := FParser.CurrTokenPos;
        Result^.Modifiers := 0;
        New(Result^.FData);
        InitializeVariant(Result^.FData, at2ut(t^.Value.FType), t^.Value.BaseType);
        CopyVariantContents(@t.Value, Result^.FData);
        exit;
      end;
    end;
    Result := nil;
    MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  end;
  function ReadVarParameters(ProcNoVar: PIFPSValue): PIFPSValue;
  var
    Decl: string;
    p: PParam;
    Tmp: PIFPSValue;
    FType: Cardinal;
    modifier: Char;

    function IsVarInCompatible(ft1, ft2: PIFPSType): 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.GetItem(GetTypeNo(ProcnoVar))).ProcDef;
    GRFW(Decl);
    New(Result);
    Result^.FType := CVAL_VarProc;
    Result^.Modifiers := 0;
    Result^._ProcNo := ProcNoVar;
    Result^._Parameters := TIfList.Create;
    if Length(Decl) = 0 then
    begin
      if FParser.CurrTokenId = CSTI_OpenRound then
      begin
        FParser.Next;
        if FParser.CurrTokenId <> CSTI_CloseRound then
        begin
          DisposePValue(Result);
          Result := nil;
          MakeError('', ecCloseRoundExpected, '');
          exit;
        end;
        FParser.Next;
      end;
    end
    else
    begin
      if FParser.CurrTokenId <> CSTI_OpenRound then
      begin
        DisposePValue(Result);
        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
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            MakeError('', ecIdentifierExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
          Tmp := GetIdentifier(1); // only variables
          if Tmp = nil then
          begin
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
          if ((FType = Cardinal(-1)) and (PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp))).BaseType = btArray)) then
          begin
            {nothing}
          end else if IsVarInCompatible(FUsedTypes.GetItem(FType), FUsedTypes.GetItem(GetTypeNo(Tmp))) then
          begin
            MakeError('', ecTypeMismatch, '');
            DisposePValue(Result);
            DisposePValue(Tmp);
            Result := nil;
            exit;
          end;
          Tmp^.FType := Tmp^.FType + CVAL_PushAddr;
        end;
        New(p);
        p^.InReg := Tmp;
        p^.OutReg := nil;
        p^.FType := FType;
        Result._Parameters.Add(p);
        if Length(Decl) = 0 then
        begin
          if FParser.CurrTokenId <> CSTI_CloseRound then
          begin
            MakeError('', ecCloseRoundExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Comma then
          begin
            MakeError('', ecCommaExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end; {else if}
      end; {for}
    end; {else if}
  end;

  function calc(endOn: TIfPasToken): PIFPSValue;
  var
    Items: TIfList;
    p: PCalc_Item;
    x: PParam;
    v, vc: PIFPSValue;
    Pt: PIFPSType;
    C: Byte;
    modifiers: byte;
    L: Cardinal;

    procedure Cleanup;
    var
      p: PCalc_Item;
      l: Longint;
    begin
      for l := 0 to Items.Count - 1 do
      begin
        p := Items.GetItem(l);
        if not p^.C then
        begin
          DisposePValue(p^.OutRec);
        end;
        Dispose(p);
      end;
      Items.Free;
    end;

    function SortItems: Boolean;
    var
      l: Longint;
      tt: Cardinal;
      p, p1, P2, ptemp: PCalc_Item;
      tempt: PIFPSType;
      pp: PParam;
      temps: string;

      function GetResultType(p1, P2: PIFPSValue; Cmd: Byte): Cardinal;
      var
        t1, t2: PIFPSType;
        tt1, tt2: Cardinal;
      begin
        tt1 := GetTypeNo(p1);
        t1 := FUsedTypes.GetItem(tt1);
        tt2 := GetTypeNo(P2);
        t2 := FUsedTypes.GetItem(tt2);
        if (t1 = nil) or (t2 = nil) then
        begin
          Result := Cardinal(-1);
          exit;
        end;
        case Cmd of
          0: {plus}
            begin
              if (t1.BaseType = btVariant) and (
                (t2.BaseType = btVariant) or
                (t2.BaseType = btString) or
                {$IFNDEF 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 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 = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btString) or (t2.BaseType = btChar)) then
                Result := GetType(btString)
              {$IFNDEF 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(btWideString)
              {$ENDIF}
              else
                Result := Cardinal(-1);
            end;
          1, 2, 3: { -  * / }
            begin
              if (t1.BaseType = btVariant) and (
                (t2.BaseType = btVariant) or
                (isIntRealType(t2.BaseType))) then
                Result := tt1
              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 := Cardinal(-1);
            end;
          7, 8, 9: {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^.FType = CVAL_Data) or (p2^.FType = CVAL_Data)) then
                begin
                  if cmd = 7 then {and}
                  begin
                    if p1^.FType = CVAL_Data then
                    begin
                      if (p1^.FData^.tu8 <> 0) then
                        MakeWarning('', ewIsNotNeeded, '"True and"')^.Position := p1^.DPos
                      else
                        MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False')^.Position := p1^.DPos
                    end else begin
                      if (p2^.FData^.tu8 <> 0) then
                        MakeWarning('', ewIsNotNeeded, '"and True"')^.Position := p2^.DPos
                      else
                        MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False')^.Position := p2^.DPos;
                    end;
                  end else if cmd = 8 then {or}
                  begin
                    if p1^.FType = CVAL_Data then
                    begin
                      if (p1^.FData^.tu8 <> 0) then
                        MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True')^.Position := p1^.DPos
                      else
                        MakeWarning('', ewIsNotNeeded, '"False or"')^.Position := p1^.DPos
                    end else begin
                      if (p2^.FData^.tu8 <> 0) then
                        MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True')^.Position := p2^.DPos
                      else
                        MakeWarning('', ewIsNotNeeded, '"or False"')^.Position := p2^.DPos;
                    end;
                  end;
                end;
              end else
                Result := Cardinal(-1);
            end;
          4, 5, 6: {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 := Cardinal(-1);
            end;
          10, 11, 12, 13: { >=, <=, >, <}
            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 := 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 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 NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar){$ENDIF}) and
              ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF 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 := Cardinal(-1);
            end;
          14, 15: {=, <>}
            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 := 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 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 NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar){$ENDIF}) and
              ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar){$ENDIF}) then
                Result := at2ut(FBooleanType)
              else if (t1.BaseType = btEnum) and (t1 = t2) then
                Result := at2ut(FBooleanType)
              else if (t1.BaseType = btVariant) or (t2.BaseType = btVariant) then
                Result := at2ut(FBooleanType)
              else Result := Cardinal(-1);
            end;
        else
          Result := Cardinal(-1);
        end;
      end;
      procedure ApplyModifiers(FData: PIFPSValue);
      begin
        if (FData^.FType = CVAL_Data) then
        begin
          if FData^.Modifiers = 1 then // not
          begin
            FData^.Modifiers := FData^.Modifiers and not 1;
            case FData^.FData.BaseType of
              btEnum: FData^.FData^.tu32 := tbtu32(FData^.FData^.tu32 = 0);
              btU8: FData^.FData^.tu8 := tbtu8(FData^.FData^.tu8 = 0);
              btS8: FData^.FData^.ts8:= tbts8(FData^.FData^.ts8 = 0);
              btU16: FData^.FData^.tu16:= tbtu16(FData^.FData^.tu16 = 0);
              btS16: FData^.FData^.ts16:= tbts16(FData^.FData^.ts16 = 0);
              btU32: FData^.FData^.tu32:= tbtu32(FData^.FData^.tu32 = 0);
              btS32: FData^.FData^.ts32:= tbts32(FData^.FData^.ts32 = 0);
              {$IFNDEF NOINT64}
              bts64: FData^.FData^.ts64 := tbts64(FData^.FData^.ts64 = 0);
              {$ENDIF}
            end;
          end else
          if FData^.Modifiers = 2 then // minus
          begin
            FData^.Modifiers := FData^.Modifiers and not 2;

            case FData^.FData.BaseType of
              btU8:
                begin
                  FData^.FData^.FType := GetType(bts8);
                  FData^.FData.BaseType := btS8;
                  FData^.FData^.ts8:= - FData^.FData^.ts8;
                end;
              btS8: FData^.FData^.ts8:= - FData^.FData^.ts8;
              btU16:
                begin
                  FData^.FData^.FType := GetType(bts16);
                  FData^.FData.BaseType := bts16;
                  FData^.FData^.ts16:= - FData^.FData^.ts16;
                end;
              btS16: FData^.FData^.ts16:= - FData^.FData^.ts16;
              btU32:
                begin
                  FData^.FData^.FType := GetType(bts32);
                  FData^.FData.BaseType := btS32;
                  FData^.FData^.ts32:= - FData^.FData^.ts32;
                end;
              btS32: FData^.FData^.ts32:= - FData^.FData^.ts32;
              {$IFNDEF NOINT64}
              bts64: FData^.FData^.ts64 := - FData^.FData^.ts64;
              {$ENDIF}
              btSingle: FData^.FData^.tsingle := - FData^.FData^.tsingle;
              btDouble: FData^.FData^.tdouble:= - FData^.FData^.tdouble;
              btExtended: FData^.FData^.textended := - FData^.FData^.textended;
            end;
          end;
        end;
      end;
    begin
      SortItems := False;
      if Items.Count = 1 then
      begin
        p1 := Items.GetItem(0);
        ApplyModifiers(p1^.OutRec);
        SortItems := True;
        exit;
      end;
      for l := 0 to (Longint(Items.Count) div 2) do
      begin
        p1 := Items.GetItem(l shl 1);
        if p1^.OutRec^.FType = CVAL_Data then
          ApplyModifiers(P1^.OutRec);
      end;
      l := 0;
      while l < Longint(Items.Count - 1) div 2 do
      begin
        p := Items.GetItem((l shl 1) + 1);
        p1 := Items.GetItem((l shl 1));
        P2 := Items.GetItem((l shl 1) + 2);
        case p^.calcCmd of
          2, 3, 4, 5, 6, 7: {*}
            begin
              if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
                CVAL_Data) then
              begin
                if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
                  p^.calcCmd, P2^.OutRec^.DPos) then
                begin
                  exit;
                end;
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
                DisposePValue(P2^.OutRec);
                Dispose(P2);
                Dispose(p);
              end
              else
              begin
                tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
                if tt = Cardinal(-1) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    P2^.OutRec^.DPos;
                  exit;
                end;
                New(ptemp);
                ptemp^.C := False;
                New(ptemp^.OutRec);
                ptemp^.OutRec^.Modifiers := 0;
                ptemp^.outrec^.DPos := p1^.OutRec^.DPos;
                ptemp^.OutRec^.FType := CVAL_Eval;
                ptemp^.OutRec^.SubItems := TIfList.Create;
                ptemp^.OutRec^.SubItems.Add(p1);
                ptemp^.OutRec^.SubItems.Add(p);
                ptemp^.OutRec^.SubItems.Add(P2);
                ptemp^.OutRec^.frestype := tt;
                Items.SetItem((l shl 1), ptemp);
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
              end;
            end;
        else
          Inc(l);
        end;
      end;
      l := 0;
      while l < Longint(Items.Count - 1) div 2 do
      begin
        p := Items.GetItem((l shl 1) + 1);
        p1 := Items.GetItem((l shl 1));
        P2 := Items.GetItem((l shl 1) + 2);
        case p^.calcCmd of
          0, 1, 8, 9:
            begin
              if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
                CVAL_Data) then
              begin
                if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
                  p^.calcCmd, P2^.OutRec^.DPos) then
                begin
                  exit;
                end;
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
                DisposePValue(P2^.OutRec);
                Dispose(P2);
                Dispose(p);
              end
              else
              begin
                tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
                if tt = Cardinal(-1) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    P2^.OutRec^.DPos;
                  exit;
                end;
                New(ptemp);
                ptemp^.C := False;
                New(ptemp^.OutRec);
                ptemp^.OutRec^.Modifiers := 0;
                ptemp^.outrec^.DPos := p1^.OutRec^.DPos;
                ptemp^.OutRec^.FType := CVAL_Eval;
                ptemp^.OutRec^.SubItems := TIfList.Create;
                ptemp^.OutRec^.SubItems.Add(p1);
                ptemp^.OutRec^.SubItems.Add(p);
                ptemp^.OutRec^.SubItems.Add(P2);
                ptemp^.OutRec^.frestype := tt;
                Items.SetItem((l shl 1), ptemp);
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
              end;
            end;
        else
          Inc(l);
        end;
      end;
      l := 0;
      while l < Longint(Items.Count - 1) div 2 do
      begin
        p := Items.GetItem((l shl 1) + 1);
        p1 := Items.GetItem((l shl 1));
        P2 := Items.GetItem((l shl 1) + 2);
        case p^.calcCmd of
          10, 11, 12, 13, 14, 15:
            begin
              if (p1^.OutRec^.FType <> CVAL_VarProcPtr) and (p2^.OutRec^.FType <> CVAL_VarProcPtr) and
              ((PIFPSType(FUsedTypes.GetItem(GetTypeNo(p1^.OutRec))).BaseType = btclass) or
              (PIFPSType(FUsedTypes.GetItem(GetTypeNo(p2^.OutRec))).BaseType = btclass)) and
              ((p^.CalcCmd = 14) or (p^.CalcCmd = 15)) then
              begin
                if p1^.OutRec^.FType = cval_nil then
                begin
                  ptemp := p1;
                  p1 := p2;
                  p2 := ptemp;
                end;
                tempt := FUsedTypes.GetItem(GetTypeNo(p1^.OutRec));
                if not TIFPSClassType(tempt).ClassHelper.CompareClass(GetTypeNo(p2^.OutRec), tt) then
                begin
                  exit;
                end;
                new(ptemp);
                ptemp^.C := False;
                new(ptemp^.outrec);
                with ptemp^.outrec^ do
                begin
                  FType := CVAL_Proc;
                  if p^.calcCmd = 14 then
                    Modifiers := 1
                  else
                    Modifiers := 0;
                  ProcNo := tt;
                  Parameters := TIfList.Create;
                  new(pp);
                  if TIFPSProcedure(FProcs.GetItem(tt)).ClassType = TIFPSInternalProcedure then
                    temps := TIFPSInternalProcedure(FProcs.GetItem(tt)).Decl
                  else
                    temps := TIFPSExternalProcedure(FProcs.GetItem(tt)).RegProc.Decl;
                  GRFW(temps);
                  pp^.InReg := p1^.OutRec;
                  pp^.OutReg := nil;
                  grfw(temps);
                  pp^.FType := StrToIntDef(grfw(temps), -1);
                  pp^.OutRegPos := p1^.OutRec^.DPos;
                  Parameters.add(pp);
                  new(pp);
                  pp^.InReg := p2^.OutRec;
                  pp^.OutReg := nil;
                  grfw(temps);
                  pp^.FType := StrToIntDef(grfw(temps), -1);
                  pp^.OutRegPos := p2^.OutRec^.DPos;
                  Parameters.add(pp);
                end;
                Items.SetItem((l shl 1), ptemp);
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
                Dispose(P2);
                dispose(p1);
                Dispose(p);
              end else 
              if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
                CVAL_Data) then
              begin
                if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
                  p^.calcCmd, P2^.OutRec^.DPos) then
                begin
                  exit;
                end;
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
                DisposePValue(P2^.OutRec);
                Dispose(P2);
                Dispose(p);
              end
              else
              begin
                tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
                if tt = Cardinal(-1) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    P2^.OutRec^.DPos;
                  exit;
                end;
                New(ptemp);
                ptemp^.C := False;
                New(ptemp^.OutRec);
                ptemp^.OutRec^.Modifiers := 0;
                ptemp^.outrec^.DPos := p1^.OutRec^.DPos;
                ptemp^.OutRec^.FType := CVAL_Eval;
                ptemp^.OutRec^.SubItems := TIfList.Create;
                ptemp^.OutRec^.SubItems.Add(p1);
                ptemp^.OutRec^.SubItems.Add(p);
                ptemp^.OutRec^.SubItems.Add(P2);
                ptemp^.OutRec^.frestype := tt;
                Items.SetItem((l shl 1), ptemp);
                Items.Delete((l shl 1) + 1);
                Items.Delete((l shl 1) + 1);
              end;
            end;
        else
          Inc(l);
        end;
      end;
      SortItems := True;
    end;
  begin
    Items := TIfList.Create;
    calc := nil;
    while True do
    begin
      modifiers := 0;
      if Items.Count and 1 = 0 then
      begin
        if fParser.CurrTokenID = CSTII_Not then
        begin
          FParser.Next;
          modifiers := 1;
        end else // only allow one of these two
        if fParser.CurrTokenID = CSTI_Minus then
        begin
          FParser.Next;
          modifiers := 2;
        end;
        case FParser.CurrTokenId of
          CSTI_AddressOf:
            begin
              if (Modifiers <> 0) then
              begin
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              FParser.Next;
              if FParser.CurrTokenId <> CSTI_Identifier then
              begin
                MakeError('', ecIdentifierExpected, '');
                Cleanup;
                Exit;
              end;
              L := FindProc(FParser.GetToken);
              if L = Cardinal(-1) then
              begin
                MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
                Cleanup;
                Exit;
              end;
              if TIFPSProcedure(FProcs.GetItem(l)).ClassType <> TIFPSInternalProcedure then
              begin
                MakeError('', ecTypeMismatch, FParser.OriginalToken);
                Cleanup;
                Exit;
              end;
              TIFPSInternalProcedure(FProcs.GetItem(L)).aExport := etExportDecl;
              FParser.Next;
              New(v);
              v^.FType := CVAL_VarProcPtr;
              v^.Modifiers := 0;
              v^.DPos := FParser.CurrTokenPos;
              v^.VProcNo := L;
              New(p);
              p^.C := False;
              p^.OutRec := v;
              Items.Add(p);
            end;
          CSTI_OpenBlock:
            begin
              if (Modifiers <> 0) then
              begin
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              New(v);
              v^.FType := CVAL_Array;
              v^.Modifiers := 0;
              v^.DPos := FParser.CurrTokenPos;
              v^.ArrayItems := TIfList.Create;
              New(p);
              p^.C := False;
              p^.OutRec := v;
              Items.Add(p);
              FParser.Next;
              while FParser.CurrTokenId <> CSTI_CloseBlock do
              begin
                vc := calc(CSTI_CloseBlock);
                if vc = nil  then
                begin
                  Cleanup;
                  exit;
                end; {if}
                if vc^.FType = CVAL_Array then
                begin
                  MakeError('', ecIdentifierExpected, '')^.Position := v^.DPos;
                  Cleanup;
                  Exit;
                end;
                v^.ArrayItems.Add(vc);
                if FParser.CurrTokenId = CSTI_Comma then
                begin
                  FParser.Next;
                  Continue;
                end;
              end; {while}
              FParser.Next;
            end; {csti_openblock}
          CSTI_EOF:
            begin
              MakeError('', ecUnexpectedEndOfFile, '');
              Cleanup;
              exit;
            end;
          CSTI_OpenRound:
            begin
              FParser.Next;
              v := calc(CSTI_CloseRound);
              if v = nil then
              begin
                Cleanup;
                exit;
              end;
              if FParser.CurrTokenId <> CSTI_CloseRound then
              begin
                DisposePValue(v);
                MakeError('', ecCloseRoundExpected, '');
                Cleanup;
                exit;
              end;
              if ((Modifiers and 1) <> 0) and (not IsIntBoolType(GetTypeNo(v))) or ((Modifiers and 2) <> 0) and (not IsRealType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(v))).BaseType)) then
              begin
                DisposePValue(v);
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;

              New(p);
              p^.C := False;
              if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
              begin
                v^.modifiers := v^.modifiers xor (modifiers and 1);
              end;
              if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
              begin
                v^.modifiers := v^.modifiers xor (modifiers and 2);
              end;
              p^.OutRec := v;
              Items.Add(p);

              FParser.Next;
            end;
          CSTII_Chr:
            begin
              if modifiers <> 0then
              begin
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              FParser.Next;
              if FParser.CurrTokenID <> CSTI_OpenRound then
              begin
                MakeError('', ecOpenRoundExpected, '');
                Cleanup;
                exit;
              end;
              FParser.Next;
              v := calc(CSTI_CloseRound);
              if v = nil then
              begin
                Cleanup;
                exit;
              end;
              if FParser.CurrTokenId <> CSTI_CloseRound then
              begin
                DisposePValue(v);
                MakeError('', ecCloseRoundExpected, '');
                Cleanup;
                exit;
              end;
              if not IsIntType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(v))).BaseType) then
              begin
                DisposePValue(v);
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              New(p);
              p^.c := False;
              New(p^.OutRec);
              p^.OutRec^.FType := CVAL_Cast;
              p^.OutRec^.Modifiers := 0;
              p^.OutRec^.DPos := FParser.CurrTokenPos;
              p^.OutRec^.Input := v;
              p^.OutRec^.NewTypeNo := GetType(btChar);
              Items.Add(p);
              FParser.Next;
            end;
          CSTII_Ord:
            begin
              FParser.Next;
              if FParser.CurrTokenID <> CSTI_OpenRound then
              begin
                MakeError('', ecOpenRoundExpected, '');
                Cleanup;
                exit;
              end;
              FParser.Next;
              v := calc(CSTI_CloseRound);
              if v = nil then
              begin
                Cleanup;
                exit;
              end;
              if FParser.CurrTokenId <> CSTI_CloseRound then
              begin
                DisposePValue(v);
                MakeError('', ecCloseRoundExpected, '');
                Cleanup;
                exit;
              end;
              Pt := FUsedTypes.GetItem(GetTypeNo(v));
              New(p);
              p^.c := False;
              if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
              begin
                v^.modifiers := v^.modifiers xor (modifiers and 1);
              end;
              if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
              begin
                v^.modifiers := v^.modifiers xor (modifiers and 2);
              end;
              New(p^.OutRec);
              p^.OutRec^.FType := CVAL_Cast;
              p^.OutRec^.Modifiers := 0;
              p^.OutRec^.DPos := FParser.CurrTokenPos;
              p^.OutRec^.Input := v;
              if (pt.BaseType = btChar) then
              begin
                p^.OutRec^.NewTypeNo := GetType(btU8);
              end else if (pt.BaseType = btEnum) then
              begin
                if TIFPSEnumType(pt).HighValue <= 256 then
                  p^.OutRec^.NewTypeNo := GetType(btU8)
                else if TIFPSEnumType(pt).HighValue <= 65536 then
                  p^.OutRec^.NewTypeNo := GetType(btU16)
                else
                  p^.OutRec^.NewTypeNo := GetType(btU32);
              end else
              begin
                Dispose(P^.OutRec);
                Dispose(p);
                DisposePValue(v);
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              Items.Add(p);
              FParser.Next;
            end;
         CSTI_String, CSTI_Char:
            begin
              if (Modifiers <> 0) then
              begin
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              New(v);
              v^.FType := CVAL_Data;
              v^.DPos := FParser.CurrTokenPos;
              v^.FData := ReadString;
              v^.Modifiers := modifiers;
              v^.RecField := nil;
              New(p);
              p^.C := False;
              p^.OutRec := v;
              Items.Add(p);

            end;
          CSTI_HexInt, CSTI_Integer:
            begin
              New(v);
              v^.FType := CVAL_Data;
              v^.DPos := FParser.CurrTokenPos;
              v^.FData := ReadInteger(FParser.GetToken);
              v^.Modifiers := modifiers;
              New(p);
              p^.C := False;
              p^.OutRec := v;
              Items.Add(p);

              FParser.Next;
            end;
          CSTI_Real:
            begin
              if ((Modifiers and 1) <> 0)  then
              begin
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              New(v);
              v^.FType := CVAL_Data;
              v^.DPos := FParser.CurrTokenPos;
              v^.FData := ReadReal(FParser.GetToken);
              v^.Modifiers := modifiers;
              New(p);
              p^.C := False;
              p^.OutRec := v;
              Items.Add(p);
              FParser.Next;
            end;
          CSTI_Identifier:
            begin
              if FParser.GetToken = 'LOW' then
                c := 1
              else
                c := 0;
              if (FParser.GetToken = 'HIGH') or (c <> 0) then
              begin
                FParser.Next;
                if FParser.CurrTokenId <> CSTI_OpenRound then
                begin
                  MakeError('', ecOpenRoundExpected, '');
                  Cleanup;
                  Exit;
                end;
                FParser.Next;
                L := FindType(FParser.GetToken);
                if L = Cardinal(-1) then
                begin
                  v := GetIdentifier(1);
                  if v = nil then
                  begin
                    Cleanup;
                    Exit;
                  end;
                  L := GetTypeNo(v);
                  DisposePValue(v);
                end else FParser.Next;
                pt := FAvailableTypes.GetItem(L);
                if pt.BaseType <> btEnum then
                begin
                  MakeError('', ecTypeMismatch, '');
                  Cleanup;
                  Exit;
                end;
                New(v);
                new(v^.FData);
                v^.FType := CVAL_Data;
                v^.DPos := FParser.CurrTokenPos;
                InitializeVariant(v^.FData, AT2UT(L), PIFPSType(FUsedTypes.GetItem(L)).BaseType);
                if c = 1 then
                  v^.FData^.tu32 := 0
                else
                  v^.FData^.tu32 := TIFPSEnumType(pt).HighValue;
                v^.Modifiers := modifiers;
                New(p);
                p^.C := False;
                p^.OutRec := v;
                Items.Add(p);
                if FParser.CurrTokenId <> CSTI_CloseRound then
                begin
                  MakeError('', ecCloseRoundExpected, '');
                  Cleanup;
                  Exit;
                end;
              end else if FParser.GetToken = 'ASSIGNED' then
              begin
                if (Modifiers and 2) <> 0 then
                begin
                  MakeError('', ecTypeMismatch, '');
                  cleanup;
                  exit;
                end;
                FParser.Next;
                if FParser.CurrTokenId <> CSTI_OpenRound then
                begin
                  MakeError('', ecOpenRoundExpected, '');
                  Cleanup;
                  Exit;
                end;
                FParser.Next;
                vc := calc(CSTI_CloseRound);
                if vc = nil then
                begin
                  Cleanup;
                  Exit;
                end;
                Pt := FUsedTypes.GetItem(GetTypeNo(vc));
                if pt = nil then
                begin
                  if vc^.FType <> CVAL_VarProcPtr then
                  begin
                    DisposePValue(vc);
                    MakeError('', ecTypeMismatch, '');
                    Cleanup;
                    exit;
                  end;
                end else
                if (pt.BaseType <> btProcPtr) and (pt.BaseType <> btClass) and (pt.BaseType <> btPChar) and (pt.BaseType <> btString) then
                begin
                  DisposePValue(vc);
                  MakeError('', ecTypeMismatch, '');
                  Cleanup;
                  exit;
                end;
                if FParser.CurrTokenId <> CSTI_CloseRound then
                begin
                  MakeError('', ecCloseRoundExpected, '');
                  Cleanup;
                  Exit;
                end;
                FParser.Next;
                if (vc^.FType =CVAL_VarProcPtr) then
                begin
                  new(v);
                  V^.FType := CVAL_Data;
                  v^.Modifiers := modifiers;
                  New(v^.FData);
                  v^.Fdata^.FType := at2ut(FBooleanType);
                  v^.FData.BaseType := PIFPSType(FAvailableTypes.GetItem(FBooleanType)).BaseType;
                  v^.FData^.tu32 := 1;
                  new(p);
                  p^.C := False;
                  p^.OutRec := v;
                  Items.Add(p);
                end else begin
                  new(v);
                  V^.FType := CVAL_Proc;
                  v^.Modifiers := modifiers;
                  v^.ProcNo := FindProc('!ASSIGNED');
                  V^.Parameters :=TIfList.Create;
                  new(x);
                  X^.InReg := vc;
                  x^.OutReg := nil;
                  x^.FType := GetTypeNo(vc);
                  X^.OutRegPos := FParser.CurrTokenPos;
                  v^.Parameters.Add(x);
                  new(p);
                  p^.C := False;
                  p^.OutRec := v;
                  Items.Add(p);
                end;
              end else if FParser.GetToken = 'NIL' then
              begin
                if modifiers <> 0 then
                begin
                  MakeError('', ecTypeMismatch, '');
                  cleanup;
                  exit;
                end;
                New(v);
                v^.FType := CVAL_Nil;
                v^.DPos := FParser.CurrTokenPos;
                v^.Modifiers := 0;
                New(p);
                p^.C := False;
                p^.OutRec := v;
                Items.Add(p);
                FParser.Next;
              end else begin
                v := GetIdentifier(0);
                if v = nil then
                begin
                  Cleanup;
                  exit;
                end
                else if (GetTypeNo(v) = Cardinal(-1)) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position := v^.DPos;
                  DisposePValue(v);
                  Cleanup;
                  Exit;
                end else
                begin
                  if ((Modifiers and 1) <> 0) and (not IsIntBoolType(GetTypeNo(v))) or ((Modifiers
                  and 2) <> 0) and (not IsIntRealType(PIFPSType(
                  FUsedTypes.GetItem(GetTypeNo(v))).BaseType))
                  then
                  begin
                    DisposePValue(v);
                    MakeError('', ecTypeMismatch, '');
                    Cleanup;
                    exit;
                  end;
                  v^.Modifiers := v^.modifiers or modifiers;
                  New(p);
                  p^.C := False;
                  p^.OutRec := v;
                  Items.Add(p);
                end;
              end;
            end;
        else
          begin
            MakeError('', ecSyntaxError, '');
            Cleanup;
            exit;
          end;
        end; {case}
      end
      else {Items.Count and 1 = 1}
      begin
        if FParser.CurrTokenId = endOn then
          break;
        C := 0;
        case FParser.CurrTokenId of
          CSTI_EOF:
            begin
              MakeError('', ecUnexpectedEndOfFile, '');
              Cleanup;
              exit;
            end;
          CSTI_CloseBlock,
            CSTII_To,
            CSTI_CloseRound,
            CSTI_Semicolon,
            CSTII_Else,
            CSTII_End,
            CSTII_Until,
            CSTI_Comma: break;
          CSTI_Plus: ;
          CSTI_Minus: C := 1;
          CSTI_Multiply: C := 2;
          CSTII_div, CSTI_Divide: C := 3;
          CSTII_mod: C := 4;
          CSTII_shl: C := 5;
          CSTII_shr: C := 6;
          CSTII_and: C := 7;
          CSTII_or: C := 8;
          CSTII_xor: C := 9;
          CSTI_GreaterEqual: C := 10;
          CSTI_LessEqual: C := 11;
          CSTI_Greater: C := 12;
          CSTI_Less: C := 13;
          CSTI_NotEqual: C := 14;
          CSTI_Equal: C := 15;
        else
          begin
            MakeError('', ecSyntaxError, '');
            Cleanup;
            exit;
          end;
        end; {case}
        New(p);
        p^.C := True;
        p^.calcCmd := C;
        Items.Add(p);
        FParser.Next;
      end;
    end;
    if not SortItems then
    begin
      Cleanup;
      exit;
    end;
    if Items.Count = 1 then      
    begin
      p := Items.GetItem(0);
      Result := p^.OutRec;
      Dispose(p);
      Items.Free;
    end
    else
    begin
      New(Result);
      Result^.FType := CVAL_Eval;
      Result^.DPos := 0;
      result^.Modifiers := 0;
      Result^.SubItems := Items;
    end;
  end;

  function ReadParameters(ProcNo: Cardinal; fSelf: PIFPSValue): PIFPSValue;
  var
    Decl: string;
    p: PParam;
    Tmp: PIFPSValue;
    FType: Cardinal;
    modifier: Char;
    PType: PIFPSType;

    function IsVarInCompatible(ft1, ft2: PIFPSType): 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.GetItem(ProcNo)).ClassType = TIFPSInternalProcedure then
      Decl := TIFPSInternalProcedure(FProcs.GetItem(ProcNo)).Decl
    else
      Decl := TIFPSExternalProcedure(FProcs.GetItem(ProcNo)).RegProc.Decl;
    GRFW(Decl);
    New(Result);
    Result^.FType := CVAL_Proc;
    Result^.DPos := FParser.CurrTokenPos;
    Result^.Modifiers := 0;
    Result^.ProcNo := ProcNo;
    Result^.Parameters := TIfList.Create;
    if FSelf <> nil then begin
      new(p);
      p^.InReg := fself;
      p^.OutReg := nil;
      p^.FType := GetTypeNo(fself);
      Result^.Parameters.Add(p);
    end;
    if Length(Decl) = 0 then
    begin
      if FParser.CurrTokenId = CSTI_OpenRound then
      begin
        FParser.Next;
        if FParser.CurrTokenId <> CSTI_CloseRound then
        begin
          DisposePValue(Result);
          Result := nil;
          MakeError('', ecCloseRoundExpected, '');
          exit;
        end;
        FParser.Next;
      end;
    end
    else
    begin
      if FParser.CurrTokenId <> CSTI_OpenRound then
      begin
        DisposePValue(Result);
        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
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Identifier then
          begin
            MakeError('', ecIdentifierExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
          Tmp := GetIdentifier(1); // only variables
          if Tmp = nil then
          begin
            DisposePValue(Result);
            Result := nil;
            exit;
          end;
          PType := PIFPSType(FUsedTypes.GetItem(FType));
          if (FType = Cardinal(-1)) or ((PType.BaseType = btArray) and (TIFPSArrayType(PType).ArrayTypeNo = cardinal(-1)) and (PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp))).BaseType = btArray)) then
          begin
            {nothing}
          end else if (PType.BaseType = btArray) and (PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp))).BaseType = btArray) then
          begin
            if TIFPSArrayType(FUsedTypes.GetItem(GetTypeNo(Tmp))).ArrayTypeNo <> TIFPSArrayType(FUsedTypes.GetItem(FType)).ArrayTypeNo then
            begin
              MakeError('', ecTypeMismatch, '');
              DisposePValue(Result);
              DisposePValue(Tmp);
              Result := nil;
              exit;
            end;
            {nothing}
          end else if IsVarInCompatible(FUsedTypes.GetItem(FType), FUsedTypes.GetItem(GetTypeNo(Tmp))) then
          begin
            MakeError('', ecTypeMismatch, '');
            DisposePValue(Result);
            DisposePValue(Tmp);
            Result := nil;
            exit;
          end;
          Tmp^.FType := Tmp^.FType + CVAL_PushAddr;
        end;
        New(p);
        p^.InReg := Tmp;
        p^.OutReg := nil;
        p^.FType := FType;
        Result.Parameters.Add(p);
        if Length(Decl) = 0 then
        begin
          if FParser.CurrTokenId <> CSTI_CloseRound then
          begin
            MakeError('', ecCloseRoundExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end
        else
        begin
          if FParser.CurrTokenId <> CSTI_Comma then
          begin
            MakeError('', ecCommaExpected, '');
            DisposePValue(Result);
            Result := nil;
            exit;
          end; {if}
          FParser.Next;
        end; {else if}
      end; {for}
    end; {else if}
  end;


  function WriteCalculation(InData, OutReg: PIFPSValue): Boolean;
  var
    l: Longint;
    tmpcalc, p, PT, pt2: PIFPSValue;
    bmodsave: byte;
    C: Byte;

    function CheckOutreg(Where, Outreg: PIFPSValue): Boolean;
    var
      i: Longint;
      P: PCalc_Item;
    begin
      case Where^.FType of
        CVAL_Cast:
          begin
            if CheckOutreg(Where^.Input, Outreg) then
            begin
              Result := True;
              exit;
            end;
          end;
        CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg:
          begin
            if SameReg(Where, OutReg) then
            begin
              Result := True;
              exit;
            end;
          end;
        CVAL_Eval:
          for i := 0 to Where.SubItems.Count -1 do
          begin
            p := Where.SubItems.GetItem(i);
            if not p^.C then
              if CheckOutreg(p^.OutRec, Outreg) then
              begin
                Result := True;
                Exit;
              end;
          end;
        CVAL_Proc, CVAL_VarProc:
          for i := 0 to Where^.Parameters.Count -1 do
          begin
            if CheckOutreg(PParam(Where^.Parameters.GetItem(i))^.InReg, Outreg) then
            begin
              Result := True;
              Exit;
            end;
          end;
        CVAL_ClassProcCall,
        CVAL_ClassMethodCall,
        CVAL_ClassPropertyCallSet,
        CVAL_ClassPropertyCallGet:
          begin
            if CheckOutreg(Where^.Self, Outreg) then
            begin
              Result := True;
              exit;
            end;
            for i := 0 to Where^.Params.Count -1 do
            begin
              if CheckOutreg(PParam(Where^.Params.GetItem(i))^.InReg, Outreg) then
              begin
                Result := True;
                Exit;
              end;
            end;

          end;
      end;
      Result := False;;
    end;
  begin
    if indata^.FType = CVAL_Cast then
    begin
      if GetTypeNo(OutReg) = Indata^.NewTypeNo then
      begin
        OutReg^.Modifiers := outreg^.modifiers or 4;
        Result := WriteCalculation(Indata^.Input, OutReg);
        OutReg^.Modifiers := outreg^.modifiers and not 4;
        Exit;
      end else begin
        p := AllocStackReg(Indata^.NewTypeNo);
        p^.DPos := InData^.DPos;
        p^.Modifiers := p^.modifiers or 4;
        if not WriteCalculation(Indata^.Input, p) then
        begin
          DisposeStackReg(p);
          Result := False;
          Exit;
        end;
        Result := WriteCalculation(p, outreg);
        DisposeStackReg(p);
        exit;
      end;
    end else
    if InData^.FType = CVAL_VarProcPtr then
    begin
      if not CheckCompatProc(GetTypeNo(OutReg), InData^.VProcNo) then
      begin
        MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
        Result := False;
        exit;
      end;
      New(p);
      p^.FType := CVAL_Data;
      p^.Modifiers := 0;
      p^.DPos := Indata^.DPos;
      New(p^.FData);
      InitializeVariant(p^.FData, GetTypeNo(OutReg), btu32);
      p^.FData^.tu32 := Indata^.VProcNo;
      WriteCommand(CM_A);
      WriteOutRec( OutReg, False);
      WriteOutRec(p, True);
      DisposePValue(p);
    end else
    if (InData^.FType = CVAL_Proc) or (InData^.FType = CVAL_VarProc) then
    begin
      if not CheckCompatType(OutReg, InData) then
      begin
        MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
        Result := False;
        exit;
      end;

      if InData^.FType = CVAL_VarProc then
      begin
        if not ProcessVarFunction(InData^.Modifiers, InData^._ProcNo, InData^._Parameters, OutReg) then
        begin
          Result := False;
          exit;
        end;
      end else begin
        if not ProcessFunction(InData^.Modifiers, InData^.ProcNo, InData^.Parameters, OutReg) then
        begin
          Result := False;
          exit;
        end;
      end;
      if Indata^.Modifiers = 1 then begin
        PreWriteOutRec(OutReg, Cardinal(-1));
        if (at2ut(FBooleanType) = GetTypeNo(OutReg)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
        WriteOutRec(OutReg, False);
        AfterWriteOutRec(OutReg);
      end else if Indata^.Modifiers = 2 then begin
        PreWriteOutRec(OutReg, Cardinal(-1));
        WriteCommand(cm_vm);
        WriteOutRec(OutReg, False);
        AfterWriteOutRec(OutReg);
      end;
    end
    else if InData^.FType = CVAL_Eval then
    begin
      if CheckOutreg(InData, OutReg) then
      begin
        tmpcalc := AllocStackReg(GetTypeNo(OutReg));
        if not WriteCalculation(InData, TmpCalc) then
        begin
          DisposeStackReg(tmpcalc);
          Result := False;
          exit;
        end;
        if not WriteCalculation(TmpCalc, OutReg) then
        begin
          DisposeStackReg(tmpcalc);
          Result := False;
          exit;
        end;
        DisposeStackReg(tmpcalc);
      end else begin
        bmodsave := Indata^.Modifiers and 15;
        p := PCalc_Item(InData^.SubItems.GetItem(0))^.OutRec;
        C := PCalc_Item(InData^.SubItems.GetItem(1))^.calcCmd;
        if not PreWriteOutRec(OutReg, Cardinal(-1)) then
        begin
          Result := False;
          exit;
        end;
        if c >= 10 then
        begin
          tmpcalc := p;
        end else begin
          if not WriteCalculation(p, OutReg) then
          begin
            Result := False;
            exit;
          end; {if}
          tmpcalc := nil;
        end;
        for l := 0 to ((InData^.SubItems.Count - 1) div 2) - 1 do
        begin
          p := PCalc_Item(InData^.SubItems.GetItem((l shl 1) + 2))^.OutRec;
          C := PCalc_Item(InData^.SubItems.GetItem((l shl 1) + 1))^.calcCmd;
          if C < 10 then
          begin
            if p^.FType = CVAL_Eval then
            begin
              PreWriteOutRec( OutReg, Cardinal(-1)); {error}
              PT := AllocStackReg(GetTypeNo(OutReg));
              if not WriteCalculation(p, PT) then
              begin
                DisposeStackReg(PT);
                Result := False;
                exit;
              end; {if}
              WriteCommand(CM_CA);
              WriteData(C, 1);
              if not WriteOutRec(OutReg, False) then
              begin
                MakeError('', ecInternalError, '00001');
                DisposeStackReg(pt);
                Result := False;
                exit;
              end; {if}
              if not WriteOutRec(PT, True) then
              begin
                MakeError('', ecInternalError, '00002');
                DisposeStackReg(pt);
                Result := False;
                exit;
              end; {if}
              AfterWriteOutRec(Pt);
              DisposeStackReg(PT);
              AfterWriteOutRec(OutReg);
            end
            else if (p^.FType = CVAL_Proc) or (P^.Ftype = CVAL_VarProc) or (p^.FType = CVAL_Cast) then
            begin
              PT := AllocStackReg(GetTypeNo(OutReg));
              if not WriteCalculation(p, Pt) then
              begin
                DisposeStackReg(Pt);
                Result := False;
                exit;
              end;
              PreWriteOutRec(OutReg, Cardinal(-1)); {error}
              PreWriteOutRec(pt, Cardinal(-1)); {error}
              WriteCommand(CM_CA);
              WriteData(C, 1);
              if not WriteOutRec(OutReg, False) then
              begin
                MakeError('', ecInternalError, '00005');
                Result := False;
                exit;
              end; {if}
              if not WriteOutRec(pt, True) then
              begin
                MakeError('', ecInternalError, '00006');
                Result := False;
                exit;
              end; {if}
              AfterWriteOutRec(p);
              AfterWriteOutRec(OutReg);
              DisposeStackReg(Pt);
            end else begin
              PreWriteOutRec(OutReg, Cardinal(-1)); {error}
              PreWriteOutRec(p, GetTypeNo(Outreg)); {error}
              WriteCommand(CM_CA);
              WriteData(C, 1);
              if not WriteOutRec(OutReg, False) then
              begin
                MakeError('', ecInternalError, '00005');
                Result := False;
                exit;
              end; {if}
              if not WriteOutRec(p, True) then
              begin
                MakeError('', ecInternalError, '00006');
                Result := False;
                exit;
              end; {if}
              AfterWriteOutRec(p);
              AfterWriteOutRec(OutReg);

            end; {else if}
          end
          else
          begin
            C := C - 10;
            if p^.FType = CVAL_Eval then
            begin

              PT := AllocStackReg(p^.frestype);
              if not WriteCalculation(p, PT) then
              begin
                DisposeStackReg(PT);
                Result := False;
                exit;
              end; {if}
              if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
              begin
                PT2 := AllocStackReg(at2ut(FBooleanType));
              end
              else
                PT2 := OutReg;
              PreWriteOutRec(OutReg, Cardinal(-1));
              if tmpcalc <> nil then PreWriteOutRec(Tmpcalc, Cardinal(-1));
              WriteCommand(CM_CO);
              WriteByte(C);
              if (pt2 = OutReg) then
              begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '00007');
                  Result := False;
                  exit;
                end; {if}
              end
              else
              begin
                if not WriteOutRec(pt2, False) then
                begin
                  MakeError('', ecInternalError, '00007');
                  Result := False;
                  exit;
                end; {if}
              end;
              if tmpcalc <> nil then
              begin
                if not WriteOutRec(tmpcalc, True) then
                begin
                  MakeError('', ecInternalError, '00008');
                  Result := False;
                  exit;
                end; {if}
              end else begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '00008');
                  Result := False;
                  exit;
                end; {if}
              end;
              if not WriteOutRec(PT, True) then
              begin
                MakeError('', ecInternalError, '00009');
                Result := False;
                exit;
              end; {if}
              if tmpcalc <> nil then begin
                AfterWriteOutRec(Tmpcalc);
                tmpcalc := nil;
              end;
              AfterWriteOutRec(OutReg);
              DisposeStackReg(PT);
              if pt2 <> OutReg then
              begin
                if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address <
                  IFPSAddrNegativeStackStart) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    OutReg^.DPos;
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end;
                PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address - 1 -
                  IFPSAddrStackStart)).AType := GetType(btS32);
                WriteCommand(Cm_ST); // set stack type
                WriteLong(PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address
                  - 1 - IFPSAddrStackStart)).AType);
                WriteLong(OutReg^.Address - IFPSAddrStackStart);
                WriteCommand(CM_A); // stack assignment
                WriteCommand(CVAL_Addr);
                WriteLong(OutReg^.Address);
                if not WriteOutRec(pt2, False) then
                begin
                  MakeError('', ecInternalError, '0000A');
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end;
                DisposeStackReg(pt2);
              end;

            end
            else if p^.FType = CVAL_Proc then
            begin
              if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
              begin
                PT2 := AllocStackReg(at2ut(FBooleanType));
              end
              else
                PT2 := OutReg;
              if TIFPSProcedure(FProcs.GetItem(p^.ProcNo)).ClassType = TIFPSInternalProcedure then
                PT := AllocStackReg(StrToIntDef(Fw(TIFPSInternalProcedure(FProcs.GetItem(p^.ProcNo)).Decl), -1))
              else
                PT := AllocStackReg(StrToIntDef(Fw(TIFPSExternalProcedure(FProcs.GetItem(p^.ProcNo)).RegProc.Decl), -1));
              if not ProcessFunction(p^.Modifiers, p^.ProcNo, p^.Parameters, PT) then
              begin
                Result := False;
                exit;
              end;
              pt^.Modifiers := p^.modifiers;
              WriteCalculation(pt, pt);
              pt^.Modifiers := 0;
              PreWriteOutRec(OutReg, Cardinal(-1));
              if tmpcalc <> nil then PreWriteOutRec(tmpcalc, Cardinal(-1));
              WriteCommand(CM_CO);
              WriteByte(C);
              if pt2 = Outreg then
              begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '0000B');
                  Result := False;
                  exit;
                end; {if}
              end
              else
              begin
                if not WriteOutRec(pt2, False) then
                begin
                  MakeError('', ecInternalError, '0000B');
                  Result := False;
                  exit;
                end; {if}
              end;
              if tmpcalc <> nil then
              begin
                if not WriteOutRec(tmpcalc, true) then
                begin
                  MakeError('', ecInternalError, '0000C');
                  Result := False;
                  exit;
                end; {if}
              end else begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '0000C');
                  Result := False;
                  exit;
                end; {if}
              end;
              if not WriteOutRec(PT, True) then
              begin
                MakeError('', ecInternalError, '0000D');
                Result := False;
                exit;
              end; {if}
              if TmpCalc <> nil then
              begin
                AfterWriteOutRec(TmpCalc);
                tmpcalc := nil;
              end;
              AfterWriteOutRec(OutReg);
              DisposeStackReg(PT);
              if pt2 <> OutReg then
              begin
                if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address <
                  IFPSAddrNegativeStackStart) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    InData^.DPos;
                  DisposeStackReg(pt2);
                  Result := False;
                  exit;
                end;
                PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address - 1 -
                  IFPSAddrStackStart)).AType := GetType(btS32);
                WriteCommand(Cm_ST); // set stack type
                WriteLong(PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address
                  - 1
                  - IFPSAddrStackStart)).AType);
                WriteLong(OutReg^.Address - IFPSAddrStackStart);

                WriteCommand(CM_A); // stack assignment
                WriteCommand(CVAL_Addr);
                WriteLong(OutReg^.Address);
                if not WriteOutRec(pt2, False) then
                begin
                  MakeError('', ecInternalError, '0000E');
                  DisposeStackReg(pt2);
                  Result := False;
                  exit;
                end; {if}
                DisposeStackReg(pt2);
              end;
            end
            else
            begin
              if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
              begin
                PT := AllocStackReg(at2ut(FBooleanType));
              end
              else
                PT := OutReg;
              PreWriteOutRec(OutReg, Cardinal(-1));
              PreWriteOutRec(P, GetTypeNo(Outreg));
              if TmpCalc <> nil then PreWriteOutRec(tmpcalc, Cardinal(-1));

              WriteCommand(CM_CO);
              WriteData(C, 1);
              if Pt = OutReg then
              begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '0000F');
                  Result := False;
                  exit;
                end; {if}
              end
              else
              begin
                if not WriteOutRec(PT, False) then
                begin
                  MakeError('', ecInternalError, '0000F');
                  Result := False;
                  exit;
                end; {if}
              end;
              if tmpcalc <> nil then
              begin
                if not WriteOutRec(tmpcalc, True) then
                begin
                  MakeError('', ecInternalError, '00010');
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end; {if}
              end else begin
                if not WriteOutRec(OutReg, False) then
                begin
                  MakeError('', ecInternalError, '00010');
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end; {if}
              end;
              if not WriteOutRec(p, True) then
              begin
                MakeError('', ecInternalError, '00011');
                DisposeStackReg(PT);
                Result := False;
                exit;
              end; {case}
              if TmpCalc <> nil then begin
                AfterWriteOutRec(tmpcalc);
                tmpcalc := nil;
              end;
              AfterWriteOutRec(P);
              AfterWriteOutRec(OutReg);
              if PT <> OutReg then
              begin
                if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address < IFPSAddrNegativeStackStart) then
                begin
                  MakeError('', ecTypeMismatch, '')^.Position :=
                    InData^.DPos;
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end;
                PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address - 1 -
                  IFPSAddrStackStart)).AType := GetType(btS32);
                WriteCommand(Cm_ST); // set stack type
                WriteLong(PIFPSProcVar(Proc.ProcVars.GetItem(OutReg^.Address
                  - 1
                  - IFPSAddrStackStart)).AType);
                WriteLong(OutReg^.Address - IFPSAddrStackStart);

                WriteCommand(CM_A); // stack assignment
                WriteCommand(CVAL_Addr);
                WriteLong(OutReg^.Address);
                if not WriteOutRec(PT, False) then
                begin
                  MakeError('', ecInternalError, '00012');
                  DisposeStackReg(PT);
                  Result := False;
                  exit;
                end; {if}
                DisposeStackReg(PT);
              end;
            end; {else if}
          end;
        end; {for}

        l := outreg^.modifiers;
        OutReg^.Modifiers := outreg^.Modifiers or bmodsave;
        WriteCalculation(OutReg, OutReg);
        outreg^.modifiers := l;
        AfterWriteOutRec(OutReg);
      end; {if}
    end
    else
    begin
      if not SameReg(OutReg, InData) then
      begin
        if (indata^.FType <> CVAL_NIL) and not CheckCompatType(OutReg, InData) then
        begin
          MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
          Result := False;
          exit;
        end;
        if not PreWriteOutRec(InData, GetTypeNo(Outreg)) then
        begin
          Result := False;
          exit;
        end;
        if not PreWriteOutRec(OutReg, Cardinal(-1)) then
        begin
          Result := False;
          Exit;
        end;
        WriteCommand(CM_A);
        if not WriteOutRec(OutReg, False) then
        begin
          MakeError('', ecInternalError, '00013');
          AfterWriteOutRec(OutReg);
          AfterWriteOutRec(InData);
          Result := False;
          exit;
        end; {if}
        if not WriteOutRec(InData, True) then
        begin
          MakeError('', ecInternalError, '00014');
          AfterWriteOutRec(OutReg);
          AfterWriteOutRec(InData);
          Result := False;
          exit;
        end; {if}
        AfterWriteOutRec(OutReg);
        AfterWriteOutRec(InData);
      end else if (InData^.Modifiers and 1) <> 0 then begin
        InData^.Modifiers := 0;
        PreWriteOutRec(InData, GetTypeNo(Outreg));
        if (at2ut(FBooleanType) = GetTypeNo(Indata)) then
          WriteCommand(cm_bn)
        else
          WriteCommand(cm_in);
        WriteOutRec(InData, False);
        AfterWriteOutRec(InData);
      end else if (InData^.Modifiers and 2) <> 0 then begin
        InData^.Modifiers := 0;
        PreWriteOutRec(InData, GetTypeNo(Outreg));
        WriteCommand(cm_vm);
        WriteOutRec(InData, False);
        AfterWriteOutRec(InData);
      end;
    end; {if}
    Result := True;
  end; {WriteCalculation}

  function ProcessFunction(ResModifiers: Byte; ProcNo: Cardinal; InData: TIfList;
    ResultRegister:
    PIFPSValue): Boolean;
  var
    res: string;
    Tmp: PParam;
    respointer, tmpreg, resreg: PIFPSValue;
    l: Longint;

    procedure CleanParams;
    var
      l: Longint;
      x: PIFPSValue;
    begin
      for l := 0 to InData.Count - 1 do
      begin
        x := PParam(InData.GetItem(l))^.OutReg;
        if x <> nil then
        begin
          DisposeStackReg(x);
        end;
      end;
      if resreg <> nil then
      begin
        if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(resreg) then
        begin
          ResultRegister^.Modifiers := ResModifiers;
          if not WriteCalculation(ResultRegister, resreg) then
          begin
            Result := False;
          end;

          DisposeStackReg(ResultRegister);
        end else DisposeStackReg(resreg);
      end;
    end;
  begin
    if TIFPSProcedure(FProcs.GetItem(ProcNo)).ClassType = TIFPSInternalProcedure then
      res := TIFPSInternalProcedure(FProcs.GetItem(ProcNo)).Decl
    else
      res := TIFPSExternalProcedure(FProcs.GetItem(ProcNo)).RegProc.Decl;
    if Pos(' ', res) > 0 then
      res := copy(res, 1, Pos(' ', res) - 1);
    Result := False;
    if (ResModifiers and 8 <> 0) then
    begin
      if (ResultRegister = nil) then
      begin
        MakeError('', ecNoResult, '');
        Exit;
      end else resreg := nil;
    end else
    if (res = '-1') and (ResultRegister <> nil) then
    begin
      MakeError('', ecNoResult, '');
      exit;
    end
    else if (res <> '-1')  then
    begin
      if (ResultRegister = nil) then
      begin
        resreg := AllocStackReg(StrToInt(res));
        ResultRegister := resreg;
      end else if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(ResultRegister) then
      begin
        resreg := ResultRegister;
        ResultRegister := AllocStackReg(StrToInt(res));
      end else resreg := nil;
    end
    else
      resreg := nil;

    for l := InData.Count - 1 downto 0 do
    begin
      Tmp := InData.GetItem(l);
      if (Tmp^.InReg^.FType = CVAL_PushAddr) then
      begin
        tmpreg := AllocStackReg(GetType(btPointer));
        PreWriteOutRec(Tmp^.InReg, Cardinal(-1));
        WriteCommand(cm_sp);
        WriteOutRec(tmpreg, False);
        WriteOutRec(Tmp^.InReg, False);
        AfterWriteOutRec(Tmp^.InReg);
        Tmp^.OutReg := tmpreg;
      end
      else
      begin
        Tmp^.OutReg := AllocStackReg(Tmp^.FType);
        if not WriteCalculation(Tmp^.InReg, Tmp^.OutReg) then
        begin
          CleanParams;
          exit;
        end;
      end;
      DisposePValue(Tmp^.InReg);
      Tmp^.InReg := nil;
    end; {for}
    if (res <> '-1') or (ResModifiers and 8 <> 0) then
    begin
      respointer := AllocStackReg(GetType(btPointer));
      if not PreWriteOutRec(ResultRegister, Cardinal(-1)) then
      begin
        CleanParams;
        DisposeStackReg(ResPointer);
        exit;
      end;
      Writecommand(cm_sp);
      if not WriteOutRec(ResPointer, False) then
      begin
        CleanParams;
        DisposeStackReg(ResPointer);
        exit;
      end;
      if not WriteOutRec(ResultRegister, False) then
      begin
        CleanParams;
        DisposeStackReg(ResPointer);
        exit;
      end;
      AfterWriteOutRec(ResultRegister);
    end else respointer := nil;
    WriteCommand(Cm_C);
    WriteLong(ProcNo);
    if ResPointer <> nil then
      DisposeStackReg(respointer);
    Result := True;
    CleanParams;
  end; {ProcessFunction}

  function ProcessVarFunction(ResModifiers: Byte; ProcNo: PIFPSValue; InData: TIfList;
    ResultRegister: PIFPSValue): Boolean;
  var
    res: string;
    Tmp: PParam;
    resreg: PIFPSValue;
    l: Longint;

    procedure CleanParams;
    var
      l: Longint;
      x: PIFPSValue;
    begin
      for l := 0 to InData.Count - 1 do
      begin
        x := PParam(InData.GetItem(l))^.OutReg;
        if x <> nil then
        begin
          DisposeStackReg(x);
        end;
      end;
      AfterWriteOutRec(ProcNo);
      if resreg <> nil then
      begin
        if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(resreg) then
        begin
          ResultRegister^.Modifiers := ResModifiers;
          WriteCalculation(ResultRegister, resreg);
          DisposeStackReg(ResultRegister);
        end else DisposeStackReg(resreg);
      end;
    end;
  begin
    res := TIFPSProceduralType(FUsedTypes.GetItem(GetTypeNo(ProcNo))).ProcDef;
    if Pos(' ', res) > 0 then
      res := copy(res, 1, Pos(' ', res) - 1);
    Result := False;
    if (res = '-1') and (ResultRegister <> nil) then
    begin
      MakeError('', ecNoResult, '');
      exit;
    end
    else if (res <> '-1')  then
    begin
      if (ResultRegister = nil) then
      begin
        resreg := AllocStackReg(StrToInt(res));
        ResultRegister := resreg;
      end else if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(ResultRegister) then
      begin
        resreg := ResultRegister;
        ResultRegister := AllocStackReg(StrToInt(res));
      end else resreg := nil;
    end
    else
      resreg := nil;

    PreWriteOutRec(ProcNo, Cardinal(-1));
    for l := InData.Count - 1 downto 0 do
    begin
      Tmp := InData.GetItem(l);
      if (Tmp^.InReg^.FType = CVAL_PushAddr) then
      begin
        Tmp^.OutReg := AllocStackReg2(Tmp^.FType);
        PreWriteOutRec(Tmp^.InReg, Cardinal(-1));
        WriteCommand(CM_PV);
        WriteOutRec(Tmp^.InReg, False);
        AfterWriteOutRec(Tmp^.InReg);
      end
      else
      begin
        Tmp^.OutReg := AllocStackReg(Tmp^.FType);
        if not WriteCalculation(Tmp^.InReg, Tmp^.OutReg) then
        begin
          CleanParams;
          exit;
        end;
      end;
      DisposePValue(Tmp^.InReg);
      Tmp^.InReg := nil;
    end; {for}
    if res <> '-1' then
    begin
      WriteCommand(CM_PV);
      if not WriteOutRec(ResultRegister, False) then
      begin
        CleanParams;
        MakeError('', ecInternalError, '00015');
        exit;
      end;
    end;
    WriteCommand(Cm_cv);
    WriteOutRec(ProcNo, True);
    if res <> '-1' then
      WriteCommand(CM_PO);
    Result := True;
    CleanParams;
  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 Proc.FLabels.Count -1 do
    begin
      s := Proc.FLabels.GetItem(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 Proc.FGotos.Count -1 do
    begin
      s := Proc.FGotos.GetItem(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.GetItem(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.GetItem(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
    SavedTokenPos: Cardinal;
    VVar: PIFPSValue;
    TempVar,
      InitialVal,
      finalVal: PIFPSValue;
    Backwards: Boolean;
    FPos, NPos, EPos, RPos: Longint;
    OldCO, OldBO: TIfList;
    I: Longint;
  begin
    Result := False;
    SavedTokenPos := FParser.CurrTokenPos;
    FParser.Next;
    if FParser.CurrTokenId <> CSTI_Identifier then
    begin
      MakeError('', ecIdentifierExpected, '');
      exit;
    end;
    VVar := GetIdentifier(1);
    if VVar = nil then
      exit;
    case PIFPSType(FUsedTypes.GetItem(GetTypeNo(VVar))).BaseType of
      btU8, btS8, btU16, btS16, btU32, btS32: ;
    else
      begin
        MakeError('', ecTypeMismatch, '');
        DisposePValue(VVar);
        exit;
      end;
    end;
    if FParser.CurrTokenId <> CSTI_Assignment then
    begin
      MakeError('', ecAssignmentExpected, '');
      DisposePValue(VVar);
      exit;
    end;
    FParser.Next;
    InitialVal := calc(CSTII_DownTo);
    if InitialVal = nil then
    begin
      DisposePValue(VVar);
      exit;
    end;
    if FParser.CurrTokenId = CSTII_To then
      Backwards := False
    else if FParser.CurrTokenId = CSTII_DownTo then
      Backwards := True
    else
    begin
      MakeError('', ecToExpected, '');
      DisposePValue(VVar);
      DisposePValue(InitialVal);
      exit;
    end;
    FParser.Next;
    finalVal := calc(CSTII_do);
    if finalVal = nil then
    begin
      DisposePValue(VVar);
      DisposePValue(InitialVal);
      exit;
    end;
    if FParser.CurrTokenId <> CSTII_do then
    begin
      MakeError('', ecDoExpected, '');
      DisposePValue(VVar);
      DisposePValue(InitialVal);
      DisposePValue(finalVal);
      exit;
    end;
    FParser.Next;
    if not WriteCalculation(InitialVal, VVar) then
    begin
      DisposePValue(VVar);
      DisposePValue(InitialVal);
      DisposePValue(finalVal);
      exit;
    end;
    DisposePValue(InitialVal);
    TempVar := AllocStackReg(at2ut(FBooleanType));
    Debug_WriteLineEx(SavedTokenPos);
    NPos := Length(Proc.Data);
    PreWriteOutRec(VVar, Cardinal(-1));
    PreWriteOutRec(finalVal, Cardinal(-1));
    WriteCommand(CM_CO);
    if Backwards then
    begin
      WriteByte(0); { >= }
    end
    else
    begin
      WriteByte(1); { <= }
    end;
    if not WriteOutRec(TempVar, False) then
    begin
      DisposeStackReg(TempVar);
      DisposePValue(VVar);
      DisposePValue(finalVal);
      exit;
    end;
    WriteOutRec(VVar, False);
    WriteOutRec(finalVal, True);
    AfterWriteOutRec(finalVal);
    AfterWriteOutRec(VVar);
    DisposePValue(finalVal);
    WriteCommand(Cm_CNG);
    EPos := Length(Proc.Data);
    WriteLong($12345678);
    WriteOutRec(TempVar, False);
    RPos := Length(Proc.Data);
    OldCO := FContinueOffsets;
    FContinueOffsets := TIfList.Create;
    OldBO := FBreakOffsets;
    FBreakOffsets := TIFList.Create;
    if not ProcessSub(tOneliner, ProcNo, proc) then
    begin
      DisposeStackReg(TempVar);
      DisposePValue(VVar);
      FBreakOffsets.Free;
      FContinueOffsets.Free;
      FContinueOffsets := OldCO;
      FBreakOffsets := OldBo;
      exit;
    end;
    New(InitialVal);  // ML
    InitialVal^.Modifiers := 0;
    InitialVal^.DPos := FParser.CurrTokenPos;
    InitialVal^.FType := CVAL_Data;
    New(InitialVal^.FData); // ML
    InitializeVariant(InitialVal^.FData, GetTypeNo(VVar), 0);
    InitialVal^.FData.BaseType := PIFPSType(FUsedTypes.GetItem(InitialVal^.FData^.FType)).BaseType;
    case InitialVal^.FData.BaseType of
      btU8, btS8: InitialVal^.FData^.tu8 := 1;
      btU16, btS16: InitialVal^.FData^.tu16 := 1;
      btU32, btS32: InitialVal^.FData^.tu32 := 1;
    else
      begin
        MakeError('', ecInternalError, '00019');
        DisposeStackReg(TempVar);
        DisposePValue(VVar);
        DisposePValue(InitialVal);
        FBreakOffsets.Free;
        FContinueOffsets.Free;
        FContinueOffsets := OldCO;
        FBreakOffsets := OldBo;
        exit;
      end;
    end;
    FPos := Length(Proc.Data);
    PreWriteOutRec(InitialVal, Cardinal(-1));
    PreWriteOutRec(VVar, Cardinal(-1));
    WriteCommand(CM_CA);
    if Backwards then
      WriteByte(1) {-}
    else
      WriteByte(0); {+}
    WriteOutRec(VVar, False);
    WriteOutRec(InitialVal, True);
    AfterWriteOutRec(VVar);
    AfterWriteOutRec(InitialVal);
    DisposePValue(InitialVal);
    WriteCommand(Cm_G);
    WriteLong(Longint(NPos - Length(Proc.Data) - 4));
    Longint((@Proc.Data[EPos + 1])^) := Length(Proc.Data) - RPos;
    for i := 0 to FBreakOffsets.Count -1 do
    begin
      EPos := Cardinal(FBreakOffsets.GetItem(I));
      Longint((@Proc.Data[EPos - 3])^) := Length(Proc.Data) - Longint(EPos);
    end;
    for i := 0 to FContinueOffsets.Count -1 do
    begin
      EPos := Cardinal(FContinueOffsets.GetItem(I));
      Longint((@Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
    end;
    FBreakOffsets.Free;
    FContinueOffsets.Free;
    FContinueOffsets := OldCO;
    FBreakOffsets := OldBo;
    DisposeStackReg(TempVar);
    DisposePValue(VVar);
    if HasInvalidJumps(RPos, Length(Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessFor}

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

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

  function ProcessIf: Boolean;
  var
    vout, vin: PIFPSValue;
    SPos, EPos: Cardinal;
  begin
    Result := False;
    Debug_WriteLine;
    FParser.Next;
    vout := calc(CSTII_Then);
    if vout = nil then
      exit;
    if FParser.CurrTokenId <> CSTII_Then then
    begin
      DisposePValue(vout);
      MakeError('', ecThenExpected, '');
      exit;
    end;
    vin := AllocStackReg(at2ut(FBooleanType));
    if not WriteCalculation(vout, vin) then
    begin
      DisposePValue(vout);
      DisposeStackReg(vin);
      exit;
    end;
    DisposePValue(vout);
    WriteCommand(cm_sf);
    if not WriteOutRec(vin, False) then
    begin
      MakeError('', ecInternalError, '00018');
      DisposeStackReg(vin);
      exit;
    end;
    WriteByte(1);
    DisposeStackReg(vin);
    WriteCommand(cm_fg);
    WriteLong($12345678);
    SPos := Length(Proc.Data);
    FParser.Next; // skip then
    if not ProcessSub(tifOneliner, Procno, proc) then
    begin
      exit;
    end;
    if FParser.CurrTokenId = CSTII_Else then
    begin
      WriteCommand(Cm_G);
      WriteLong($12345678);
      EPos := Length(Proc.Data);
      Longint((@Proc.Data[SPos - 3])^) := Length(Proc.Data) -
        Longint(SPos);
      FParser.Next;
      if not ProcessSub(tOneliner, ProcNo, proc) then
      begin
        exit;
      end;
      Longint((@Proc.Data[EPos - 3])^) := Length(Proc.Data) - Longint(EPos);
    end
    else
    begin
      Longint((@Proc.Data[SPos - 3])^) := Length(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 Proc.FLabels.Count -1 do
    begin
      s := Proc.FLabels.GetItem(I);
      delete(s, 1, 4);
      if Longint((@s[1])^) = h then
      begin
        delete(s, 1, 4);
        if s = FParser.GetToken then
        begin
          s := Proc.FLabels.GetItem(I);
          Cardinal((@s[1])^) := Length(Proc.Data);
          Proc.FLabels.SetItem(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: PIFPSValue;
  begin
    Result := False;
    Debug_WriteLine;
    vin := GetIdentifier(2);
    if vin <> nil then
    begin
      if vin^.FType < CVAL_Proc then
      begin // assignment needed
        if FParser.CurrTokenId <> CSTI_Assignment then
        begin
          MakeError('', ecAssignmentExpected, '');
          DisposePValue(vin);
          exit;
        end;
        FParser.Next;
        vout := calc(CSTI_Semicolon);
        if vout = nil then
        begin
          DisposePValue(vin);
          exit;
        end;
        if not WriteCalculation(vout, vin) then
        begin
          DisposePValue(vin);
          DisposePValue(vout);
          exit;
        end;
        DisposePValue(vin);
        DisposePValue(vout);
      end
      else if vin^.FType = CVAL_VarProc then
      begin
        Result := ProcessVarFunction(0, Vin^._ProcNo, vin^._Parameters, nil);
        DisposePValue(vin);
        Exit;
      end else
      begin
        Result := ProcessFunction(0, vin^.ProcNo, vin^.Parameters, nil);
        DisposePValue(vin);
        exit;
      end;
    end
    else
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessIdentifier}

  function ProcessCase: Boolean;
  var
    TempRec, CV, Val, CalcItem: PIFPSValue;
    p: PCalc_Item;
    SPos, CurrP: Cardinal;
    I: Longint;
    EndReloc: TIfList;
  begin
    Debug_WriteLine;
    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, '');
      DisposePValue(Val);
      ProcessCase := False;
      exit;
    end; {if}
    FParser.Next;
    TempRec := AllocStackReg(GetTypeNo(Val));
    if not WriteCalculation(Val, TempRec) then
    begin
      DisposeStackReg(TempRec);
      DisposePValue(Val);
      ProcessCase := False;
      exit;
    end; {if}
    DisposePValue(Val);
    EndReloc := TIfList.Create;
    CalcItem := AllocStackReg(at2ut(FBooleanType));
    SPos := Length(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, '');
        DisposeStackReg(CalcItem);
        DisposeStackReg(TempRec);
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end; {if}
      FParser.Next;
      New(cv);
      cv^.DPos := FParser.CurrTokenPos;
      cv^.FType := CVAL_Eval;
      cv^.SubItems:= TIfList.Create;
      cv^.Modifiers := 0;
      new(p);
      p^.C := False;
      p^.OutRec := Val;
      cv^.SubItems.Add(p);
      new(p);
      p^.C := True;
      p^.calcCmd := 15;
      cv^.SubItems.Add(p);
      new(p);
      p^.C := False;
      p^.OutRec := TempRec;
      cv^.SubItems.Add(p);
      if not WriteCalculation(CV, CalcItem) then
      begin
        DisposeStackReg(CalcItem);
        DisposePValue(CV);
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end;
      Cv.SubItems.Delete(2);
      Dispose(p);
      DisposePValue(CV);
      WriteByte(Cm_CNG);
      WriteLong($12345678);
      CurrP := Length(Proc.Data);
      WriteOutRec(CalcItem, False);
      if not ProcessSub(tifOneliner, Procno, proc) then
      begin
        DisposeStackReg(CalcItem);
        DisposeStackReg(TempRec);
        EndReloc.Free;
        ProcessCase := False;
        exit;
      end;
      WriteByte(Cm_G);
      WriteLong($12345678);
      EndReloc.Add(Pointer(Length(Proc.Data)));
      Cardinal((@Proc.Data[CurrP - 3])^) := Cardinal(Length(Proc.Data)) - CurrP - 5;
      if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
      if FParser.CurrTokenID = CSTII_Else then
      begin
        FParser.Next;
        if not ProcessSub(tOneliner, Procno, proc) then
        begin
          DisposeStackReg(CalcItem);
          DisposeStackReg(TempRec);
          EndReloc.Free;
          ProcessCase := False;
          exit;
        end;
        if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
        if FParser.CurrtokenId <> CSTII_End then
        begin
          MakeError('', ecEndExpected, '');
          DisposeStackReg(CalcItem);
          DisposeStackReg(TempRec);
          EndReloc.Free;
          ProcessCase := False;
          exit;
        end;
      end;
    until FParser.CurrTokenID = CSTII_End;
    FParser.Next;
    for i := 0 to EndReloc.Count -1 do
    begin
      Cardinal((@Proc.Data[Cardinal(EndReloc.GetItem(I))- 3])^) := Cardinal(Length(Proc.Data)) - Cardinal(EndReloc.GetItem(I));
    end;
    DisposeStackReg(CalcItem);
    DisposeStackReg(TempRec);
    EndReloc.Free;
    if HasInvalidJumps(SPos, Length(Proc.Data)) then
    begin
      Result := False;
      exit;
    end;
    Result := True;
  end; {ProcessCase}
  function ProcessGoto: Boolean;
  var
    I, H: Longint;
    s: string;
  begin
    Debug_WriteLine;
    FParser.Next;
    h := MakeHash(FParser.GetToken);
    for i := 0 to Proc.FLabels.Count -1 do
    begin
      s := Proc.FLabels.GetItem(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);
          Proc.FGotos.Add(mi2s(length(Proc.Data))+mi2s(i));
          Result := True;
          exit;
        end;
      end;
    end;
    MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
    Result := False;
  end; {ProcessGoto}
  function ProcessTry: Boolean;
  var
    FStartOffset: Cardinal;
  begin
    FParser.Next;
    WriteCommand(cm_puexh);
    FStartOffset := Length(Proc.Data) + 1;
    WriteLong(Cardinal(-1));
    WriteLong(Cardinal(-1));
    WriteLong(Cardinal(-1));
    WriteLong(Cardinal(-1));
    if ProcessSub(tTry, ProcNo, Proc) then
    begin
      WriteCommand(cm_poexh);
      WriteByte(0);
      if FParser.CurrTokenID = CSTII_Except then
      begin
        FParser.Next;
        Cardinal((@Proc.Data[FStartOffset + 4])^) := Cardinal(Length(Proc.Data)) - FStartOffset - 15;
        if ProcessSub(tTryEnd, ProcNo, Proc) then
        begin
          WriteCommand(cm_poexh);
          writeByte(2);
          if FParser.CurrTokenId = CSTII_Finally then
          begin
            Cardinal((@Proc.Data[FStartOffset + 8])^) := Cardinal(Length(Proc.Data)) - FStartOffset - 15;
            FParser.Next;
            if ProcessSub(tTryEnd, ProcNo, Proc) then
            begin
              if FParser.CurrTokenId = CSTII_End then
              begin
                WriteCommand(cm_poexh);
                writeByte(3);
              end else begin
                MakeError('', ecEndExpected, '');
                Result := False;
                exit;
              end;
            end else begin Result := False; exit; end;
          end else if FParser.CurrTokenID <> CSTII_End then
          begin
            MakeError('', ecEndExpected, '');
            Result := False;
            exit;
          end;
          FParser.Next;
        end else begin Result := False; exit; end;
      end else if FParser.CurrTokenId = CSTII_Finally then
      begin
        FParser.Next;
        Cardinal((@Proc.Data[FStartOffset])^) := Cardinal(Length(Proc.Data)) - FStartOffset - 15;
        if ProcessSub(tTryEnd, ProcNo, Proc) then
        begin
          WriteCommand(cm_poexh);
          writeByte(1);
          if FParser.CurrTokenId = CSTII_Except then
          begin
            Cardinal((@Proc.Data[FStartOffset + 4])^) := Cardinal(Length(Proc.Data)) - FStartOffset - 15;
            FParser.Next;
            if ProcessSub(tTryEnd, ProcNo, Proc) then
            begin
              if FParser.CurrTokenId = CSTII_End then
              begin
                WriteCommand(cm_poexh);
                writeByte(2);
              end else begin
                MakeError('', ecEndExpected, '');
                Result := False;
                exit;
              end;
            end else begin Result := False; exit; end;
          end else if FParser.CurrTokenID <> CSTII_End then
          begin
            MakeError('', ecEndExpected, '');
            Result := False;
            exit;
          end;
          FParser.Next;
        end else begin Result := False; exit; end;
      end;
    end else begin Result := False; exit; end;
    Cardinal((@Proc.Data[FStartOffset + 12])^) := Cardinal(Length(Proc.Data)) - FStartOffset - 15;
    Result := True;
  end; {ProcessTry}
begin
  ProcessSub := False;
  if (FType = tProcBegin) or (FType = tMainBegin) or (FType = tSubBegin) then
  begin
    FParser.Next; // skip CSTII_Begin
  end;
  while True do
  begin
    case FParser.CurrTokenId of
      CSTII_break:
        begin
          if FBreakOffsets = nil then
          begin
            MakeError('', ecNotInLoop, '');
            exit;
          end;
          WriteCommand(Cm_G);
          WriteLong($12345678);
          FBreakOffsets.Add(Pointer(Length(Proc.Data)));
          FParser.Next;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Continue:
        begin
          if FBreakOffsets = nil then
          begin
            MakeError('', ecNotInLoop, '');
            exit;
          end;
          WriteCommand(Cm_G);
          WriteLong($12345678);
          FContinueOffsets.Add(Pointer(Length(Proc.Data)));
          FParser.Next;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Goto:
        begin
          if not ProcessGoto then
            Exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Try:
        begin
          if not ProcessTry then
            Exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Finally, CSTII_Except:
        begin
          if (FType = tTry) or (FType = tTryEnd) then
            Break
          else
            begin
              MakeError('', ecEndExpected, '');
              Exit;
            end;
        end;
      CSTII_Begin:
        begin
          if not ProcessSub(tSubBegin, ProcNo, proc) then
            Exit;
          FParser.Next; // skip END
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTI_Semicolon:
        begin
          FParser.Next;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_until:
        begin
          Debug_WriteLine;
          if FType = tRepeat then
          begin
            break;
          end
          else
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Else:
        begin
          if FType = tifOneliner then
            break
          else
          begin
            MakeError('', ecIdentifierExpected, '');
            exit;
          end;
        end;
      CSTII_repeat:
        begin
          if not ProcessRepeat then
            exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_For:
        begin
          if not ProcessFor then
            exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_While:
        begin
          if not ProcessWhile then
            exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_Exit:
        begin
          Debug_WriteLine;
          WriteCommand(Cm_R);
          FParser.Next;
        end;
      CSTII_Case:
        begin
          if not ProcessCase then
            exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTII_If:
        begin
          if not ProcessIf then
            exit;
          if (FType = tifOneliner) or (FType = TOneLiner) then
            break;
        end;
      CSTI_Identifier:
        begin
          case ProcessLabel of
            0: Exit;
            1: ;
            else
            begin
              if not ProcessIdentifier then
                exit;
              if (FType = tifOneliner) or (FType = TOneLiner) then
                break;
            end;
          end; {case}
        end;
      CSTII_End:
        begin
          if (FType = tTryEnd) or (FType = tMainBegin) or (FType = tSubBegin) or (FType =
            tifOneliner) or (FType = tProcBegin) or (FType = 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 (FType = tMainBegin) or (FType = tProcBegin) then
  begin
    Debug_WriteLine;
    WriteCommand(Cm_R);
    FParser.Next; // skip end
    if (FType = tMainBegin) and (FParser.CurrTokenId <> CSTI_Period) then
    begin
      MakeError('', ecPeriodExpected, '');
      exit;
    end;
    if (FType = 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.GetItem(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.GetItem(I);
    s2 := Proc.FLabels.GetItem(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 FreeAll;
  var
    I: Longint;
    PT: PIFPSType;
    pc: PIFPSConstant;
    pv: PIFPSVar;
  begin
    for I := 0 to FRegProcs.Count - 1 do
      TObject(FRegProcs.GetItem(I)).Free;
    FRegProcs.Free;
    for i := 0 to FConstants.Count -1 do
    begin
      pc := FConstants.GetItem(I);
      FinalizeVariant(pc^.Value);
      Dispose(pc);
    end;
    Fconstants.Free;
    for I := 0 to FVars.Count - 1 do
    begin
      pv := FVars.GetItem(I);
      Dispose(pv);
    end;
    FVars.Free;
    for I := 0 to FProcs.Count - 1 do
      TIFPSProcedure(FProcs.GetItem(I)).Free;
    FProcs.Free;
    FProcs := nil;
    for I := 0 to FAvailableTypes.Count - 1 do
    begin
      PT := FAvailableTypes.GetItem(I);
      pt.Free;
    end;
    FAvailableTypes.Free;
    FUsedTypes.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;
      Tmp: Cardinal;
      x: PIFPSType;
//      xxp: PIFPSProceduralType;
      FExportName: string;
      procedure WriteTypeNo(TypeNo: Cardinal);
      var
        e: PIFPSType;
        i: Integer;
      begin
        e := FUsedTypes.GetItem(TypeNo);
        if e.BaseType = btRecord then
        begin
          for i := 0 to TIFPSRecordType(e).RecValCount -1 do
          begin
            WriteTypeNo(TIFPSRecordType(e).RecVal(i).FType);
          end;
        end else
          WriteData(TypeNo, 4);
      end;
    begin
      for l := 0 to FUsedTypes.Count - 1 do
      begin
        x := FUsedTypes.GetItem(l);
        if x.FExportName then
          FExportName := x.Name
        else
          FExportName := '';
        if x.BaseType = btClass then
        begin
          x := GetTypeCopyLink(FAvailableTypes.GetItem(TIFPSClassType(x).ClassHelper.SelfType));
        end;
        if (x.BaseType = btEnum) then begin
          if TIFPSEnumType(x).HighValue <= 256 then
            x.BaseType := btU8
          else if TIFPSEnumType(x).HighValue <= 65536 then
            x.BaseType := btU16
          else
            x.BaseType := btU32;
        end;
        if FExportName <> '' then
        begin
          WriteByte(x.BaseType + 128);
        end
        else
          WriteByte(X.BaseType);
        if x.BaseType = btArray then
        begin
          WriteLong(Longint(TIFPSArrayType(x).ArrayTypeNo));
        end
        else if x.BaseType = btRecord then
        begin
          n := TIFPSRecordType(x).RecValCount;
          if n <> 0 then
            N := TIFPSRecordType(x).TypeSize;
          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: PIFPSVar;
    begin
      for l := 0 to FVars.Count - 1 do
      begin
        x := FVars.GetItem(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.GetItem(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.GetItem(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.GetItem(l)).ClassType = TIFPSInternalProcedure) and
          (TIFPSInternalProcedure(FProcs.GetItem(l)).Name = IFPSMainProcName) then
        begin
          Result := l;
          exit;
        end;
      end;
      Result := Cardinal(-1);
    end;
    procedure CreateDebugData;
    var
      I: Longint;
      p: TIFPSProcedure;
      pv: PIFPSVar;
      s: string;
    begin
      s := #0;
      for I := 0 to FProcs.Count - 1 do
      begin
        p := FProcs.GetItem(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.GetItem(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.GetItem(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;
    CValue: PIFRVariant;
    Cp: PIFPSConstant;
  begin
    FParser.Next;
    repeat
      if FParser.CurrTokenID <> CSTI_Identifier then
      begin
        MakeError('', ecIdentifierExpected, '');
        Result := False;
        Exit;
      end;
      CName := FParser.GetToken;
      if IsDuplicate(CName) 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(CSTI_SemiColon);
      if CValue = nil then
      begin
        Result := False;
        Exit;
      end;
      if FParser.CurrTokenID <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        Result := False;
        exit;
      end;
      New(cp);
      cp^.NameHash := MakeHash(CName);
      cp^.Name := CName;
      InitializeVariant(@cp^.Value, CValue^.FType, PIFPSType(FAvailableTypes.GetItem(CValue^.FType)).BaseType);
      CopyVariantContents(cvalue, @cp^.Value);
      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;
    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.GetItem(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;
    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;
  DefineStandardTypes;
  FLastProgramName := '';
  if @FOnUses <> nil then
  begin
    try
      if not OnUses(Self, 'SYSTEM') then
      begin
        FreeAll;
        exit;
      end;
    except
      on e: Exception do
      begin
        MakeError('', ecCustomError, e.Message);
        FreeAll;
        exit;
      end;
    end;
  end;
  Position := csStart;
  Proc := NewProc(IFPSMainProcName);
  repeat
    if FParser.CurrTokenId = CSTI_EOF then
    begin
      if FAllowNoEnd then
        Break
      else
      begin
        MakeError('', ecUnexpectedEndOfFile, '');
        FreeAll;
        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, '');
        FreeAll;
        exit;
      end;
      FLastProgramName := FParser.GetToken;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        FreeAll;
        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, '');
        FreeAll;
        exit;
      end;
      FLastProgramName := FParser.GetToken;
      FParser.Next;
      if FParser.CurrTokenId <> CSTI_Semicolon then
      begin
        MakeError('', ecSemicolonExpected, '');
        FreeAll;
        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
        FreeAll;
        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
          FreeAll;
          exit;
        end;
      end else begin
        Position := csUses;
        if not ProcessFunction(False) then
        begin
          FreeAll;
          exit;
        end;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Label) then
    begin
      Position := csUses;
      if not ProcessLabel(TIFPSInternalProcedure(Proc)) then
      begin
        FreeAll;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Var) then
    begin
      Position := csUses;
      if not DoVarBlock(nil) then
      begin
        FreeAll;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Const) then
    begin
      Position := csUses;
      if not DoConstBlock then
      begin
        FreeAll;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Type) then
    begin
      Position := csUses;
      if not DoTypeBlock(FParser) then
      begin
        FreeAll;
        exit;
      end;
    end
    else if (FParser.CurrTokenId = CSTII_Begin) then
    begin
      if ProcessSub(tMainBegin, 0, TIFPSInternalProcedure(Proc)) then
      begin
        break;
      end
      else
      begin
        FreeAll;
        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, '');
        FreeAll;
        exit;
      end;
      break;
    end else 
    begin
      MakeError('', ecBeginExpected, '');
      FreeAll;
      exit;
    end;
  until False;
  if not ProcessLabelForwards(TIFPSInternalProcedure(Proc)) then
  begin
    FreeAll;
    exit;
  end;
  for i := 0 to FProcs.Count -1 do
  begin
    Proc := FProcs.GetItem(i);
    if (Proc.ClassType = TIFPSInternalProcedure) and (TIFPSInternalProcedure(Proc).Forwarded) then
    begin
      MakeError('', ecUnsatisfiedForward, TIFPSInternalProcedure(Proc).Name).Position := TIFPSInternalProcedure(Proc).DeclarePosition;
      FreeAll;
      Exit;
    end;
  end;
  if not CheckExports then
  begin
    FreeAll;
    exit;
  end;
  for i := 0 to FVars.Count -1 do
  begin
    if not PIFPSVar(FVars.GetItem(I))^.Used then
    begin
      MakeHint('', ehVariableNotUsed, PIFPSVar(FVars.GetItem(I))^.Name)^.Position := PIFPSVar(FVars.GetItem(I))^.DeclarePosition;
    end;
  end;
  MakeOutput;
  FreeAll;
  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):
  PIFPSPascalCompilerMessage;
begin
  Result := FMessages.GetItem(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 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 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 PIFPSType(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 PIFPSType(r).BaseType = btArray then
  begin

    if TIFPSArrayType(r).FArrayTypeNo <> Cardinal(-1) then
      TIFPSArrayType(r).FArrayTypeNo := AT2UT(TIFPSArrayType(r).FArrayTypeNo);
  end;
end;


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

function TIFPSPascalCompiler.AddConstant(const Name: string; FType: Cardinal): PIFPSConstant;
var
  pc: PIFPSConstant;
begin
  if FProcs = nil then begin Result := nil; exit;end;
  FType := GetTypeCopyLinkInt(FType);
  if FType = Cardinal(-1) then begin Result := nil; exit; end;
  new(pc);
  pc^.Name := FastUppercase(name);
  pc^.NameHash := makehash(pc^.name);
  InitializeVariant(@pc^.Value, FType, PIFPSType(FAvailableTypes.GetItem(FType)).BaseType);
  FConstants.Add(pc);
  result := pc;
end;

type
  PConstantVal = ^TConstantVal;
  TConstantVal = record
    b: Boolean;
    case boolean  of
    true: (Rec: PIfRVariant; DeclPos: Cardinal; Modifiers: Byte);
    false: (c: byte);
  end;

function TIFPSPascalCompiler.ReadConstant(StopOn: TIfPasToken): PIfRVariant;
var
  Items: TIfList;
  tmp: PConstantVal;
  Val: PIfRVariant;
  c,
  modifiers: byte;

    function GetType(BaseType: TIFPSBaseType): Cardinal;
    var
      l: Longint;
      x: PIFPSType;
    begin
      for l := 0 to FAvailableTypes.Count - 1 do
      begin
        if PIFPSType(FAvailableTypes.GetItem(l)).BaseType = BaseType then
        begin
          Result := l;
          exit;
        end;
      end;
      x := TIFPSType.Create;
      x.Name := '';
      x.BaseType := BaseType;
      x.TypeSize := 1;
      x.DeclarePosition := Cardinal(-1);
      FAvailableTypes.Add(x);
      FUsedTypes.Add(x);
      Result := FUsedTypes.Count - 1;
    end;

  procedure Cleanup;
  var
    p: PConstantVal;
    l: Longint;
  begin
    for l := 0 to Items.Count - 1 do
    begin
      p := Items.GetItem(l);
      if not p^.b then
      begin
        DisposeVariant(p^.Rec);
      end;
      Dispose(p);
    end;
    Items.Free;
  end;

  function SortItems: Boolean;
  var
    l: Longint;
    p, p1, P2: PConstantVal;
  begin
    SortItems := False;
    if Items.Count = 1 then
    begin
      p1 := Items.GetItem(0);

      if (p1^.Rec^.FType = CVAL_Data) then
      begin

        if p1^.Modifiers = 1 then // not
        begin
          case p1^.Rec.BaseType of
            btU8: p1^.Rec^.tu8 := tbtu8(p1^.Rec^.tu8 = 0);
            btS8: p1^.Rec^.ts8 := tbts8(p1^.Rec^.ts8 = 0);
            btU16: p1^.Rec^.tu16 := tbtu16(p1^.Rec^.tu16 = 0);
            btS16: p1^.Rec^.ts16 := tbts16(p1^.Rec^.ts16 = 0);
            btU32: p1^.Rec^.tu32 := tbtu32(p1^.Rec^.tu32 = 0);
            btS32: p1^.Rec^.ts32 := tbts32(p1^.Rec^.ts32 = 0);
            {$IFNDEF NOINT64}
            btS64: p1^.Rec^.ts64 := tbts64(p1^.Rec^.ts64 = 0);
            {$ENDIF}
          end;
        end else
        if p1^.Modifiers = 2 then // minus
        begin
          case p1^.Rec.BaseType of
            btU8: p1^.Rec^.tu8 := - p1^.Rec^.tu8;
            btS8: p1^.Rec^.ts8 := - p1^.Rec^.ts8;
            btU16: p1^.Rec^.tu16 := - p1^.Rec^.tu16;
            btS16: p1^.Rec^.ts16 := - p1^.Rec^.ts16;
            btU32: p1^.Rec^.tu32 := - p1^.Rec^.tu32;
            btS32: p1^.Rec^.ts32 := - p1^.Rec^.ts32;
            {$IFNDEF NOINT64}
            btS64: p1^.Rec^.ts64 := - p1^.Rec^.ts64;
            {$ENDIF}
            btSingle: p1^.Rec^.tsingle := - p1^.Rec^.tsingle;
            btDouble: p1^.Rec^.tdouble := - p1^.Rec^.tdouble;
            btExtended: p1^.Rec^.textended := - p1^.Rec^.textended;
          end;
        end;
      end;
      SortItems := True;
      exit;
    end;
    l := 0;
    while l < Longint(Items.Count - 1) div 2 do
    begin
      p := Items.GetItem((l shl 1) + 1);
      p1 := Items.GetItem((l shl 1));
      P2 := Items.GetItem((l shl 1) + 2);
      case p^.c of
        2, 3, 4, 5, 6, 7: {*}
          begin
            if not PreCalc(FAvailableTypes, p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
            begin
              exit;
            end;
            Items.Delete((l shl 1) + 1);
            Items.Delete((l shl 1) + 1);
            DisposeVariant(p2^.Rec);
            Dispose(P2);
            Dispose(p);
          end;
      else
        Inc(l);
      end;
    end;
    l := 0;
    while l < Longint(Items.Count - 1) div 2 do
    begin
      p := Items.GetItem((l shl 1) + 1);
      p1 := Items.GetItem((l shl 1));
      P2 := Items.GetItem((l shl 1) + 2);
      case p^.c of
        0, 1, 8, 9:
          begin
            if not PreCalc(FAvailableTypes,p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
            begin
              exit;
            end;
            Items.Delete((l shl 1) + 1);
            Items.Delete((l shl 1) + 1);
            DisposeVariant(p2^.Rec);
            Dispose(P2);
            Dispose(p);
          end;
      else
        Inc(l);
      end;
    end;
    l := 0;
    while l < Longint(Items.Count - 1) div 2 do
    begin
      p := Items.GetItem((l shl 1) + 1);
      p1 := Items.GetItem((l shl 1));
      P2 := Items.GetItem((l shl 1) + 2);
      case p^.c of
        10, 11, 12, 13, 14, 15:
          begin
            if not PreCalc(FAvailableTypes,p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
            begin
              exit;
            end;
            Items.Delete((l shl 1) + 1);
            Items.Delete((l shl 1) + 1);
            DisposeVariant(p2^.Rec);
            Dispose(P2);
            Dispose(p);
          end;
      else
        Inc(l);
      end;
    end;
    SortItems := True;
  end;
  function ReadReal(const s: string): PIfRVariant;
  var
    C: Integer;
  begin
    New(Result);
    InitializeVariant(Result, GetType(btExtended), btExtended);
    System.Val(s, Result^.textended, C);
  end;
  function ReadInteger(const s: string): PIfRVariant;
  {$IFNDEF NOINT64}
  var
    R: Int64;
  begin
    r := StrToInt64Def(s, 0);
    New(Result);
    if (r >= High(Longint)) or (r <= Low(Longint))then
    begin
      InitializeVariant(Result, GetType(bts32), bts32);
      Result^.ts32 := r;
    end else
    begin
      InitializeVariant(Result, GetType(bts64), bts64);
      Result^.ts64 := r;
    end;
  end;
  {$ELSE}
  var
    r: Longint;
  begin
    r := StrToIntDef(s, 0);
    New(Result);
    InitializeVariant(Result, GetType(bts32), bts32);
    Result^.ts32 := r;
  end;
  {$ENDIF}
  function ReadString: PIfRVariant;
  {$IFNDEF NOWIDESTRING}var wchar: Boolean;{$ENDIF}

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

      function ChrToStr(s: string): {$IFNDEF NOWIDESTRING}widechar{$ELSE}char{$ENDIF};
      var
        w: Longint;
      begin
        Delete(s, 1, 1); {First char : #}
        w := StrToInt(s);
        Result := {$IFNDEF NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w);
        {$IFNDEF 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 NOWIDESTRING}
  var
    w: widestring;
    s: string;
  begin
    w := ParseString;
    if wchar then
    begin
      New(Result);
      if Length(w) = 1 then
      begin
        InitializeVariant(Result, GetType(btwidechar), btWideChar);
        Result^.twidechar := w[1];
      end else begin
        InitializeVariant(Result, GetType(btwidestring), btWidestring);
        tbtwidestring(result^.twidestring) := w;
      end;
    end else begin
      s := w;
      New(Result);
      if Length(s) = 1 then
      begin
        InitializeVariant(Result, GetType(btChar), btChar);
        Result^.tchar := s[1];
      end else begin
        InitializeVariant(Result, GetType(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(Result, GetType(btChar), btChar);
      Result^.tchar := s[1];
    end else begin
      InitializeVariant(Result, GetType(btstring), btstring);
      tbtstring(Result^.tstring) := s;
    end;
  end;
  {$ENDIF}
  function GetConstantIdentifier: PIfRVariant;
  var
    s: string;
    sh: Longint;
    i: Longint;
    p: PIFPSConstant;
  begin
    s := FParser.GetToken;
    sh := MakeHash(s);
    for i := FConstants.Count -1 downto 0 do
    begin
      p := FConstants.GetItem(I);
      if (p^.NameHash = sh) and (p^.Name = s) then
      begin
        New(Result);
        InitializeVariant(Result, p^.Value.FType, p^.Value.BaseType);
        CopyVariantContents(@P^.Value, Result);
        FParser.Next;
        exit;
      end;
    end;
    MakeError('', ecUnknownIdentifier, '');
    Result := nil;

  end;
begin
  Items := TIfList.Create;
  ReadConstant := nil;
  while True do
  begin
    modifiers := 0;
    if Items.Count and 1 = 0 then
    begin
      if fParser.CurrTokenID = CSTII_Not then
      begin
        FParser.Next;
        modifiers := 1;
      end else // only allow one of these two
      if fParser.CurrTokenID = CSTI_Minus then
      begin
        FParser.Next;
        modifiers := 2;
      end;
      case FParser.CurrTokenId of
        CSTI_EOF:
          begin
            MakeError('', ecUnexpectedEndOfFile, '');
            Cleanup;
            exit;
          end;
        CSTI_OpenRound:
          begin
            FParser.Next;

            val := ReadConstant(CSTI_CloseRound);
            if val = nil then
            begin
              Cleanup;
              exit;
            end;
            if FParser.CurrTokenId <> CSTI_CloseRound then
            begin
              MakeError('', ecCloseRoundExpected, '');
              Cleanup;
              exit;
            end;
            if ((Modifiers and 1) <> 0) and (not IsIntType(PIFPSType(FUsedTypes.GetItem(val^.FType)).BaseType)) or ((Modifiers and 2) <> 0) and (not IsRealType(PIFPSType(FUsedTypes.GetItem(val^.FType)).BaseType)) then
            begin
              DisposeVariant(val);
              MakeError('', ecTypeMismatch, '');
              Cleanup;
              exit;
            end;
            new(tmp);
            tmp^.b := False;
            tmp^.Rec := Val;
            tmp^.DeclPos := FParser.CurrTokenPos;
            tmp^.Modifiers := modifiers;
            Items.Add(tmp);
            FParser.Next;
          end;
        CSTI_Char, CSTI_String:
          begin
            if (Modifiers <> 0) then
            begin
              MakeError('', ecTypeMismatch, '');
              Cleanup;
              exit;
            end;
            val := ReadString;
            new(tmp);
            tmp^.b := False;
            tmp^.Rec := Val;
            tmp^.DeclPos := FParser.CurrTokenPos;
            tmp^.Modifiers := modifiers;
            Items.Add(tmp);
          end;
        CSTI_HexInt, CSTI_Integer:
          begin
            Val := ReadInteger(FParser.GetToken);
            new(tmp);
            tmp^.b := False;
            tmp^.Rec := Val;
            tmp^.DeclPos := FParser.CurrTokenPos;
            tmp^.Modifiers := modifiers;
            Items.Add(tmp);
            FParser.Next;
          end;
        CSTI_Real:
          begin
            if ((Modifiers and 1) <> 0)  then
            begin
              MakeError('', ecTypeMismatch, '');
              Cleanup;
              exit;
            end;
            Val := ReadReal(FParser.GetToken);
            new(tmp);
            tmp^.b := False;
            tmp^.Rec := Val;
            tmp^.DeclPos := FParser.CurrTokenPos;
            tmp^.Modifiers := modifiers;
            Items.Add(tmp);
            FParser.Next;
          end;
        CSTI_Identifier:
          begin
            val := GetConstantIdentifier;
            if val = nil then
            begin
              Cleanup;
              exit;
            end
            else
            begin
              if ((Modifiers and 1) <> 0) and (not IsIntType(PIFPSType(FUsedTypes.GetItem(val^.FType)).BaseType)) or ((Modifiers  and 2) <> 0) and (not IsIntRealType(PIFPSType(FUsedTypes.GetItem(val^.FType)).BaseType))
              then
              begin
                DisposeVariant(val);
                MakeError('', ecTypeMismatch, '');
                Cleanup;
                exit;
              end;
              new(tmp);
              tmp^.b := False;
              tmp^.Rec := Val;
              tmp^.DeclPos := FParser.CurrTokenPos;
              tmp^.Modifiers := modifiers;
              Items.Add(tmp);
            end;
          end;
      else
        begin
          MakeError('', ecSyntaxError, '');
          Cleanup;
          exit;
        end;
      end; {case}
    end
    else {Items.Count and 1 = 1}
    begin
      if FParser.CurrTokenId = StopOn then
        break;
      C := 0;
      case FParser.CurrTokenId of
        CSTI_EOF:
          begin
            MakeError('', ecUnexpectedEndOfFile, '');
            Cleanup;
            exit;
          end;
        CSTI_CloseBlock,
          CSTII_To,
          CSTI_CloseRound,
          CSTI_Semicolon,
          CSTII_Else,
          CSTII_End,
          CSTI_Comma: break;
        CSTI_Plus: ;
        CSTI_Minus: C := 1;
        CSTI_Multiply: C := 2;
        CSTI_Divide: C := 3;
        CSTII_mod: C := 4;
        CSTII_shl: C := 5;
        CSTII_shr: C := 6;
        CSTII_and: C := 7;
        CSTII_or: C := 8;
        CSTII_xor: C := 9;
        CSTI_GreaterEqual: C := 10;
        CSTI_LessEqual: C := 11;
        CSTI_Greater: C := 12;
        CSTI_Less: C := 13;
        CSTI_NotEqual: C := 14;
        CSTI_Equal: C := 15;
      else
        begin
          MakeError('', ecSyntaxError, '');
          Cleanup;
          exit;
        end;
      end; {case}
      new(tmp);
      tmp^.b := True;
      tmp^.c := C;
      Items.Add(tmp);
      FParser.Next;
    end;
  end;
  if not SortItems then
  begin
    Cleanup;
    exit;
  end;
  if Items.Count = 1 then
  begin
    tmp := Items.GetItem(0);
    Result := tmp^.Rec;
    Dispose(tmp);
    Items.Free;
  end
  else
  begin
    MakeError('', ecInternalError, '0001B');
    Cleanup;
    Exit;
  end;
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 begin Result := Cardinal(-1);exit;end;
  Proc := TIFPSInternalProcedure.Create;
  FProcs.Add(Proc);
  Result := FProcs.Count - 1;
end;

function TIFPSPascalCompiler.GetAvailableType(No: Cardinal): PIFPSType;
begin
  if FProcs = nil then begin Result := nil; exit;end;
  Result := FAvailableTypes.GetItem(No);
end;

function TIFPSPascalCompiler.GetAvailableTypeCount: Cardinal;
begin
  if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  Result := FAvailableTypes.Count;
end;


function TIFPSPascalCompiler.GetUsedType(No: Cardinal): PIFPSType;
begin
  if FProcs = nil then begin Result := nil; exit;end;
  Result := FUsedTypes.GetItem(No);
end;

function TIFPSPascalCompiler.GetUsedTypeCount: Cardinal;
begin
  if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  Result := FUsedTypes.Count;
end;

function TIFPSPascalCompiler.UseAvailableType(No: Cardinal): Cardinal;
var
  I: Longint;
  p: PIFPSType;
begin
  if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  p := FAvailableTypes.GetItem(No);
  if p = nil then
  begin
    Result := Cardinal(-1);
    Exit;
  end;

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

function TIFPSPascalCompiler.AddUsedFunction2(var Proc: TIFPSExternalProcedure): Cardinal;
begin
  if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  Proc := TIFPSExternalProcedure.Create;
  FProcs.Add(Proc);
  Result := FProcs.Count -1;
end;

function TIFPSPascalCompiler.AddVariable(const Name: string; FType: Cardinal): PIFPSVar;
var
  P: PIFPSVar;
begin
  if FProcs = nil then begin Result := nil; exit;end;
  if FType = Cardinal(-1) then begin Result := nil; exit; end;
  New(p);
  p^.Name := Fastuppercase(Name);
  p^.Namehash := MakeHash(p^.Name);
  p^.FType := AT2UT(FType);
  p^.Used := False;
  p^.DeclarePosition := 0;
  FVars.Add(p);
  Result := P;
end;


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

function TIFPSPascalCompiler.AddConstantN(const Name,
  FType: string): PIFPSConstant;
var
  L: Cardinal;
begin
  L := FindType(FType);
  if l = Cardinal(-1) then
    Result := nil
  else
    Result := AddConstant(Name, L);
end;

function TIFPSPascalCompiler.AddTypeCopy(const Name: string;
  TypeNo: Cardinal): PIFPSType;
var
  b: PIFPSType;
begin
  b := FAvailableTypes.GetItem(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): PIFPSType;
var
  L: Cardinal;
begin
  L := FindType(FType);
  if L = Cardinal(-1) then
    Result := nil
  else
    Result := AddTypeCopy(Name, L);
end;


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

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

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

function TIFPSPascalCompiler.AddTypeS(const Name, Decl: string): PIFPSType;
var
  Parser: TIfPascalParser;
begin
  Parser := TIfPascalParser.Create;
  Parser.SetText(Decl);
  Result := FAvailableTypes.GetItem(ReadType(FastUppercase(Name), Parser));
  Parser.Free;
end;


function TIFPSPascalCompiler.CheckCompatProc(FTypeNo,
  ProcNo: Cardinal): Boolean;
var
  s1,s2: string;
  P: PIFPSType;

  function c(const e1,e2: string): Boolean;
  begin
    Result := (Length(e1) = 0) or (Length(e2) = 0) or (e1[1] <> e2[1]);  
  end;
begin
  P := FUsedTypes.GetItem(FTypeNo);
  if p.BaseType <> btProcPtr then begin
    Result := False;
    Exit;
  end;

  S1 := TIFPSProceduralType(p).ProcDef;

  if TIFPSProcedure(FProcs.GetItem(ProcNo)).ClassType = TIFPSInternalProcedure then
    s2 := TIFPSInternalProcedure(FProcs.GetItem(ProcNo)).Decl
  else
    s2 := TIFPSExternalProcedure(FProcs.GetItem(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: PIFPSType;
begin
  if FTypeNo = at2ut(FBooleanType) then begin Result := True; exit;end;
  f := FUsedTypes.GetItem(FTypeNo);
  
  case f.BaseType of
    btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF NOINT64}, btS64{$ENDIF}: Result := True;
  else
    Result := False;
  end;
end;

function TIFPSPascalCompiler.AddExportVariableN(const Name,
  FType: string): PIFPSVar;
begin
  Result := AddVariableN(Name, FType);
  if Result <> nil then
    Result^.exportname := FastUppercase(Name);
end;

function TIFPSPascalCompiler.AddUsedExportVariableN(const Name,
  FType: string): PIFPSVar;
begin
  Result := AddUsedVariableN(Name, FType);
  if Result <> nil then
    Result^.exportname := FastUppercase(Name);
end;

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

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

{ TIFPSExternalClass }
function TIFPSExternalClass.SetNil(TypeNo: Cardinal; 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);
begin
  inherited Create;
  Self.SE := se;
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 := Cardinal(-1);
end;

function TIFPSExternalClass.CastToType(TypeNo, 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;

{ 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.GetItem(i)).Free;
  FRecordSubVals.Free;
  inherited Destroy;
end;

function TIFPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
begin
  Result := FRecordSubVals.GetItem(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.GetItem(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;



{

Internal error counter: 0001D (increase and then use)

}
end.