home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d456 / CAJSCRPT.ZIP / ifps3 / ifpscomp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-08-26  |  277.2 KB  |  9,319 lines
  1. {ifpscomp is the compiler part of the script engine}
  2. unit ifpscomp;
  3. {
  4.  
  5. Innerfuse Pascal Script III
  6. Copyright (C) 2000-2002 by Carlo Kok (ck@carlo-kok.com)
  7.  
  8. Features:
  9.  
  10.   - Constants
  11.   - Variables
  12.   - Procedures/Functions
  13.   - Procedural Variables
  14.   - If, While, Repeat, For, Case
  15.   - Break/Continue
  16.   - External/Integer Procedures/Functions
  17.   - Arrays, Records
  18.   - Ability to create compiled code that can be used later
  19.   - Debugging Support
  20.   - Importing Delphi Funtions and classes
  21.  
  22. }
  23. {$I ifps3_def.inc}
  24. interface
  25. uses
  26.   SysUtils, ifps3utl, ifps3common;
  27. const
  28.   {Internal constant: used when a value must be read from an address}
  29.   CVAL_Addr = 0;
  30.   {Internal constant: used when a value is plain data}
  31.   CVAL_Data = 1;
  32.   {Internal constant: used when a value must be read from an address and pushed}
  33.   CVAL_PushAddr = 2;
  34.   {Internal constant: used for function calls}
  35.   CVAL_Proc = 3;
  36.   {Internal constant: used when there are sub calculations}
  37.   CVAL_Eval = 4;
  38.   {Internal constant: same as address except that it has to be freed otherwise}
  39.   CVAL_AllocatedStackReg = 5;
  40.   {Internal constant: A method call}
  41.   CVAL_ClassProcCall = 7;
  42.   {Internal contant: A method call}
  43.   CVAL_ClassMethodCall = 8;
  44.   {Internal constant: Property set method}
  45.   CVAL_ClassPropertyCallSet = 9;
  46.   {Internal constant: Property get method}
  47.   CVAL_ClassPropertyCallGet = 10;
  48.   {Internal Constant: Procedural Call with variable procedure number}
  49.   CVAL_VarProc = 11;
  50.   {Internal Constant: Procedural Pointer}
  51.   CVAL_VarProcPtr = 12;
  52.   {Internal Constant: Array}
  53.   CVAL_Array = 13;
  54.   {Internal Constant: ArrayAllocatedStackRec same as @link(CVAL_AllocatedStackReg)}
  55.   CVAL_ArrayAllocatedStackRec = 14;
  56.   {Internal Constant: Nil}
  57.   CVAL_Nil = 15;
  58.   {Internal Constant; Casting}
  59.   CVAL_Cast = 16;
  60.  
  61. type
  62.   TIFPSPascalCompiler = class;
  63.   {Internal type used to store the current block type}
  64.   TSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd);
  65.  
  66.   {TIFPSExternalClass is used when external classes need to be called}
  67.   TIFPSExternalClass = class;
  68.  
  69.   PIFPSRegProc = ^TIFPSRegProc;
  70.   {TIFPSRegProc is used to store the registered procs}
  71.   TIFPSRegProc = record
  72.     NameHash: Longint;
  73.     Name, Decl: string;
  74.     FExportName: Boolean;
  75.     ImportDecl: string; // used for dlls
  76.   end;
  77.   {The compile time variant}
  78.   PIfRVariant = ^TIfRVariant;
  79.   {The compile time variant}
  80.   TIfRVariant = record
  81.     FType: Cardinal;
  82.     Value: string;
  83.   end;
  84.   {PIFPSRecordType is is used to store records}
  85.   PIFPSRecordType = ^TIFPSRecordType;
  86.   {TIFPSRecordType is is used to store records}
  87.   TIFPSRecordType = record
  88.     FieldNameHash: Longint;
  89.     FieldName: string;
  90.     RealFieldOffset: Cardinal;
  91.     FType: Cardinal;
  92.   end;
  93.   {PIFPSProceduralType is a pointer to @link(TIFPSProceduralType)}
  94.   PIFPSProceduralType = ^TIFPSProceduralType;
  95.   {TIFPSProceduralType contains information to store procedural variables}
  96.   TIFPSProceduralType = record
  97.     ProcDef: string;
  98.   end;
  99.   {PIFPSType is a pointer to a @link(TIFPSType) record}
  100.   PIFPSType = ^TIFPSType;
  101.   {TIFPSType contains a type definition}
  102.   TIFPSType = record
  103.     NameHash: Longint;
  104.     Name: string;
  105.     BaseType: TIFPSBaseType;
  106.     DeclarePosition: Cardinal;
  107.     Used: Boolean;
  108.     TypeSize: Cardinal;
  109.     RecordSubVals: TIfList;
  110.     FExport: Boolean;
  111.     case byte of
  112.       0: (Ext: Pointer);
  113.       1: (Ex: TIFPSExternalClass);
  114.   end;
  115.   {@link(TIFPSProcVar)
  116.   PIFPSProcVar is a pointer to a TIFPSProcVar record}
  117.   PIFPSProcVar = ^TIFPSProcVar;
  118.   {TIFPSProcVar is used to store procedural variables}
  119.   TIFPSProcVar = record
  120.     NameHash: Longint;
  121.     VarName: string;
  122.     VarType: Cardinal; // only for calculation types
  123.     Used, CurrentlyUsed: Boolean;
  124.     DeclarePosition: Cardinal;
  125.   end;
  126.   {PIFPSUsedRegProc is a pointer to an TIFPSUsedRegProc}
  127.   PIFPSUsedRegProc = ^TIFPSUsedRegProc;
  128.   {TIFPSUsedRegProc is used to store used registered procs}
  129.   TIFPSUsedRegProc = record
  130.     Internal: Boolean; { false }
  131.     RP: PIFPSRegProc;
  132.   end;
  133.   {PIFPSProcedure is a pointer to a TIFPSProcedure}
  134.   PIFPSProcedure = ^TIFPSProcedure;
  135.   {TIFPSProcdure is used to store information about a procedure}
  136.   TIFPSProcedure = record
  137.     Internal: Boolean; { true }
  138.     Forwarded: Boolean;
  139.     Data: string;
  140.     NameHash: Longint;
  141.     Decl, Name: string;
  142.     {Decl: [RESULTTYPE] [PARAM1NAME] [PARAM1TYPE] [PARAM2NAME] ... }
  143.     { @ = Normal Parameter  ! = Var parameter `}
  144.     ProcVars: TIfList;
  145.     Used: Boolean;
  146.     DeclarePosition: Cardinal;
  147.     OutputDeclPosition: Cardinal;
  148.     ResUsed: Boolean;
  149.     FExport: Byte; {1 = yes; 2 = also decl}
  150.     FLabels: TIfStringList; // mi2s(position)+mi2s(namehash)+name   [position=$FFFFFFFF means position unknown]
  151.     FGotos: TIfStringList;  // mi2s(position)+mi2s(destinationnamehash)+destinationname
  152.   end;
  153.   {PIFPSVar is a pointer to a TIFPSVar record}
  154.   PIFPSVar = ^TIFPSVar;
  155.   {TIFPSVar is used to store global variables}
  156.   TIFPSVar = record
  157.     NameHash: Longint;
  158.     Name: string;
  159.     FType: Cardinal;
  160.     Used: Boolean;
  161.     DeclarePosition: Cardinal;
  162.     exportname: string;
  163.   end;
  164.   {PIFPSContant is a pointer to a TIFPSConstant}
  165.   PIFPSConstant = ^TIFPSConstant;
  166.   {TIFPSContant contains a constant}
  167.   TIFPSConstant = record
  168.     NameHash: Longint;
  169.     Name: string;
  170.     Value: TIfRVariant;
  171.   end;
  172.   {Is used to store the type of a compiler error}
  173.   TIFPSPascalCompilerError = (
  174.     ecUnknownIdentifier,
  175.     ecIdentifierExpected,
  176.     ecCommentError,
  177.     ecStringError,
  178.     ecCharError,
  179.     ecSyntaxError,
  180.     ecUnexpectedEndOfFile,
  181.     ecSemicolonExpected,
  182.     ecBeginExpected,
  183.     ecPeriodExpected,
  184.     ecDuplicateIdentifier,
  185.     ecColonExpected,
  186.     ecUnknownType,
  187.     ecCloseRoundExpected,
  188.     ecTypeMismatch,
  189.     ecInternalError,
  190.     ecAssignmentExpected,
  191.     ecThenExpected,
  192.     ecDoExpected,
  193.     ecNoResult,
  194.     ecOpenRoundExpected,
  195.     ecCommaExpected,
  196.     ecToExpected,
  197.     ecIsExpected,
  198.     ecOfExpected,
  199.     ecCloseBlockExpected,
  200.     ecVariableExpected,
  201.     ecStringExpected,
  202.     ecEndExpected,
  203.     ecUnSetLabel,
  204.     ecNotInLoop,
  205.     ecInvalidJump,
  206.     ecOpenBlockExpected,
  207.     ecWriteOnlyProperty,
  208.     ecReadOnlyProperty,
  209.     ecClassTypeExpected,
  210.     ecCustomError,
  211.     ecDivideByZero,
  212.     ecMathError,
  213.     ecUnsatisfiedForward
  214.  
  215.     );
  216.   {Used to store the type of a hint}
  217.   TIFPSPascalCompilerHint = (
  218.     ehVariableNotUsed, {param = variable name}
  219.     ehFunctionNotUsed, {param = function name}
  220.     ehCustomHint
  221.     );
  222.   {Is used to store the type of a warning}
  223.   TIFPSPascalCompilerWarning = (
  224.     ewCalculationAlwaysEvaluatesTo,
  225.     ewIsNotNeeded,
  226.     ewCustomWarning
  227.   );
  228.   {Is used to store the type of the messages}
  229.   TIFPSPascalCompilerMessageType = (ptWarning, ptError, ptHint);
  230.   {Contains a pointer to an TIFPSPascalCompilerMessages record}
  231.   PIFPSPascalCompilerMessage = ^TIFPSPascalCompilerMessage;
  232.   {Contains compiler messages}
  233.   TIFPSPascalCompilerMessage = packed record
  234.  
  235.     ModuleName: string;
  236.     Param: string;
  237.     Position: Cardinal;
  238.     MessageType: TIFPSPascalCompilerMessageType;
  239.     case TIFPSPascalCompilerMessageType of
  240.       ptError: (Error: TIFPSPascalCompilerError);
  241.       ptWarning: (Warning: TIFPSPascalCompilerWarning);
  242.       ptHint: (Hint: TIFPSPascalCompilerHint);
  243.   end;
  244.  
  245.   {See TIFPSPascalCompiler.OnUseVariable}
  246.   TIFPSOnUseVariable = procedure (Sender: TIFPSPascalCompiler; VarType: TIFPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal);
  247.   {See TIFPSPascalCompiler.OnUses}
  248.   TIFPSOnUses = function(Sender: TIFPSPascalCompiler; const Name: string): Boolean;
  249.   {See TIFPSPascalCompiler.OnExportCheck}
  250.   TIFPSOnExportCheck = function(Sender: TIFPSPascalCompiler; Proc: PIFPSProcedure; const ProcDecl: string): Boolean;
  251.   {See TIFPSPascalCompiler.OnWriteLine}
  252.   TIFPSOnWriteLineEvent = function (Sender: TIFPSPascalCompiler; Position: Cardinal): Boolean;
  253.   {See TIFPSPascalCompiler.OnExternalProc}
  254.   TIFPSOnExternalProc = function (Sender: TIFPSPascalCompiler; const Name, Decl, FExternal: string): PIFPSRegProc;
  255.   TIFPSPascalCompiler = class
  256.   protected
  257.     FID: Pointer;
  258.     FOnExportCheck: TIFPSOnExportCheck;
  259.     FBooleanType: Cardinal;
  260.     FRegProcs: TIfList;
  261.     FConstants: TIFList;
  262.     FProcs: TIfList;
  263.     FAvailableTypes: TIfList;
  264.     FUsedTypes: TIfList;
  265.     FVars: TIfList;
  266.     FOutput: string;
  267.     FParser: TIfPascalParser;
  268.     FMessages: TIfList;
  269.     FOnUses: TIFPSOnUses;
  270.     FIsUnit: Boolean;
  271.     FAllowNoBegin: Boolean;
  272.     FAllowNoEnd: Boolean;
  273.     FAllowUnit: Boolean;
  274.     FDebugOutput: string;
  275.     FOnExternalProc: TIFPSOnExternalProc;
  276.     FOnUseVariable: TIFPSOnUseVariable;
  277.     FOnWriteLine: TIFPSOnWriteLineEvent;
  278.     FContinueOffsets, FBreakOffsets: TIfList;
  279.     FAutoFreeList: TIfList;
  280.     function GetType(BaseType: TIFPSBaseType): Cardinal;
  281.     function GetMsgCount: Longint;
  282.     function MakeDecl(decl: string): string;
  283.     function MakeExportDecl(decl: string): string;
  284.     function GetMsg(l: Longint): PIFPSPascalCompilerMessage;
  285.     procedure DefineStandardTypes;
  286.     procedure UpdateRecordFields(r: Pointer);
  287.     function GetTypeCopyLink(p: PIFPSType): PIFPSType;
  288.     function IsIntBoolType(FTypeNo: Cardinal): Boolean;
  289.     function GetUInt(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Cardinal;
  290.     function GetInt(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Longint;
  291.     function GetReal(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): Extended;
  292.     function GetString(FUseTypes: TIFList; Src: PIfRVariant; var s: Boolean): string;
  293.     function PreCalc(FUseTypes: TIFList; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
  294.       Var2: PIfRVariant; Cmd: Byte; Pos: Cardinal): Boolean;
  295.     function ReadConstant(StopOn: TIfPasToken): PIfRVariant;
  296.     procedure WriteDebugData(const s: string);
  297.     function ProcessFunction: Boolean;
  298.     function IsDuplicate(const s: string): Boolean;
  299.     function DoVarBlock(proc: PIFPSProcedure): Boolean;
  300.     function DoTypeBlock(FParser: TIfPascalParser): Boolean;
  301.     function ReadType(const Name: string; FParser: TIfPascalParser): Cardinal;
  302.     function NewProc(const Name: string): PIFPSProcedure;
  303.     function ProcessLabel(Proc: PIFPSProcedure): Boolean;
  304.     procedure Debug_SavePosition(ProcNo: Cardinal; Proc: PIFPSProcedure);
  305.     procedure Debug_WriteParams(ProcNo: Cardinal; Proc: PIFPSProcedure);
  306.     function ProcessSub(FType: TSubOptType; ProcNo: Cardinal;
  307.       proc: PIFPSProcedure): Boolean;
  308.     function ProcessLabelForwards(Proc: PIFPSProcedure): Boolean;
  309.  
  310.     procedure ReplaceTypes(var s: string);
  311.     function AT2UT(L: Cardinal): Cardinal;
  312.     function GetUsedType(No: Cardinal): PIFPSType;
  313.     function GetAvailableType(No: Cardinal): PIFPSType;
  314.     function GetUsedTypeCount: Cardinal;
  315.     function GetAvailableTypeCount: Cardinal;
  316.     function UseAvailableType(No: Cardinal): Cardinal;
  317.     function GetProc(No: Cardinal): PIFPSProcedure;
  318.     function GetProcCount: Cardinal;
  319.     function GetVariableCount: Cardinal;
  320.     function GetVariable(No: Cardinal): PIFPSVar;
  321.  
  322.     function AddUsedFunction(var Proc: PIFPSProcedure): Cardinal;
  323.     function AddUsedFunction2(var Proc: PIFPSUsedRegProc): Cardinal;
  324.     function CheckCompatProc(FTypeNo, ProcNo: Cardinal): Boolean;
  325.     procedure ParserError(Parser: TObject; Kind: TIFParserErrorKind; Position: Cardinal);
  326.   public
  327.     {Add an object to the auto-free list}
  328.     procedure AddToFreeList(Obj: TObject);
  329.     {Tag}
  330.     property ID: Pointer read FID write FID;
  331.     {Add an error the messages}
  332.     function MakeError(const Module: string; E: TIFPSPascalCompilerError; const
  333.       Param: string): PIFPSPascalCompilerMessage;
  334.     {Add a warning to the messages}
  335.     function MakeWarning(const Module: string; E: TIFPSPascalCompilerWarning;
  336.       const Param: string): PIFPSPascalCompilerMessage;
  337.     {Add a hint to the messages}
  338.     function MakeHint(const Module: string; E: TIFPSPascalCompilerHint;
  339.       const Param: string): PIFPSPascalCompilerMessage;
  340.     {Add a function}
  341.     function AddFunction(const Header: string): PIFPSRegProc;
  342.     {add a type}
  343.     function AddType(const Name: string; const BaseType: TIFPSBaseType): PIFPSType;
  344.     {Add a type declared in a string}
  345.     function AddTypeS(const Name, Decl: string): PIFPSType;
  346.     {Add a type copy type}
  347.     function AddTypeCopy(const Name: string; TypeNo: Cardinal): PIFPSType;
  348.     {Add a type copy type}
  349.     function AddTypeCopyN(const Name, FType: string): PIFPSType;
  350.     {Add a constant}
  351.     function AddConstant(const Name: string; FType: Cardinal): PIFPSConstant;
  352.     {Add a constant}
  353.     function AddConstantN(const Name, FType: string): PIFPSConstant;
  354.     {Add a variable}
  355.     function AddVariable(const Name: string; FType: Cardinal): PIFPSVar;
  356.     {Add a variable}
  357.     function AddVariableN(const Name, FType: string): PIFPSVar;
  358.     {Add an used variable}
  359.     function AddUsedVariable(const Name: string; FType: Cardinal): PIFPSVar;
  360.     {add an used variable (with named type)}
  361.     function AddUsedVariableN(const Name, FType: string): PIFPSVar;
  362.     {Add a variable and export it}
  363.     function AddExportVariableN(const Name, FType: string): PIFPSVar;
  364.     {Add an used variable and export it}
  365.     function AddUsedExportVariableN(const Name, FType: string): PIFPSVar;
  366.     {Search for a type}
  367.     function FindType(const Name: string): Cardinal;
  368.     {Compile a script (s)}
  369.     function Compile(const s: string): Boolean;
  370.     {Return the output}
  371.     function GetOutput(var s: string): Boolean;
  372.     {Return the debugger output}
  373.     function GetDebugOutput(var s: string): Boolean;
  374.     {Clear the current data}
  375.     procedure Clear;
  376.     {Create}
  377.     constructor Create;
  378.     {Destroy the current instance of the script compiler}
  379.     destructor Destroy; override;
  380.     {contains the number of messages}
  381.     property MsgCount: Longint read GetMsgCount;
  382.     {The messages/warnings/errors}
  383.     property Msg[l: Longint]: PIFPSPascalCompilerMessage read GetMsg;
  384.     {OnUses i scalled for each Uses and always first with 'SYSTEM' parameters}
  385.     property OnUses: TIFPSOnUses read FOnUses write FOnUses;
  386.     {OnExportCheck is called for each function to check if it needs to be exported and has the correct parameters}
  387.     property OnExportCheck: TIFPSOnExportCheck read FOnExportCheck write FOnExportCheck;
  388.     {OnWriteLine is called after each line}
  389.     property OnWriteLine: TIFPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
  390.     {OnExternalProc is called when an external token is found after a procedure header}
  391.     property OnExternalProc: TIFPSOnExternalProc read FOnExternalProc write FOnExternalProc;
  392.     {The OnUseVariant event is called when a variable is used by the script engine}
  393.     property OnUseVariable: TIFPSOnUseVariable read FOnUseVariable write FOnUseVariable;
  394.     {contains true if the current file is a unit}
  395.     property IsUnit: Boolean read FIsUnit;
  396.     {Allow no main begin/end}
  397.     property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
  398.     {Allow a unit instead of program}
  399.     property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
  400.     {Allow it to have no END on the script (only works when AllowNoBegin is true)}
  401.     property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
  402.   end;
  403.   {Pointer to @link(TIFPSValue) type}
  404.   PIFPSValue = ^TIFPSValue;
  405.   {Type containing types}
  406.   TIFPSValue = packed record
  407.     FType: Byte;
  408.     Modifiers: byte;
  409.     {
  410.       1 = not
  411.       2 = minus
  412.       4 = ignore types (casting)
  413.       8 = override type
  414.       128 = don't free
  415.     }
  416.     FNewTypeNo: Cardinal;
  417.     DPos: Cardinal;
  418.     case Byte of
  419.       CVAL_Nil: ();
  420.       CVAL_Addr: (Address: Cardinal; RecField: TIfList); {i/o}
  421.       CVAL_Data: (FData: PIfRVariant); {i}
  422.       CVAL_PushAddr: (Address_: Cardinal; RecField__: TIfList);
  423.       CVAL_Proc: (Parameters: TIfList; ProcNo: Cardinal);
  424.       CVAL_VarProc: (_Parameters: TIfList; _ProcNo: PIFPSValue);
  425.       CVAL_Eval: (SubItems: TIfList; frestype: Cardinal);
  426.       CVAL_ClassPropertyCallGet,
  427.       CVAL_ClassPropertyCallSet,
  428.       CVAL_ClassMethodCall,
  429.       CVAL_ClassProcCall: (Self: PIFPSValue; ClassProcNo: Cardinal; Params: TIfList);
  430.       CVAL_Array: (ArrayItems: TIfList);
  431.       CVAL_VarProcPtr: (VProcNo: Cardinal);
  432.       CVAL_Cast: (NewTypeNo: Cardinal; Input: PIFPSValue);
  433.   end;
  434.   {Internal type: PCalc_Item}
  435.   PCalc_Item = ^TCalc_Item;
  436.   {Internal type: TCalc_Item}
  437.   TCalc_Item = packed record
  438.     C: Boolean;
  439.     case Boolean of
  440.       False: (OutRec: PIFPSValue);
  441.       True: (calcCmd: Byte);
  442.   end;
  443.   {Internal type: PIFRecField}
  444.   PIFRecField = ^TIFRecField;
  445.   {Internal type: TIFRecField}
  446.   TIFRecField = packed record
  447.     FKind: Byte;
  448.     FType: Cardinal;
  449.     case Byte of
  450.       0: (RecFieldNo: Cardinal);
  451.       1: (ArrayFieldNo: Cardinal);
  452.       2: (ReadArrayFieldNoFrom: PIFPSValue);
  453.       3: (ResultRec: PIFPSValue);
  454.   end;
  455.   {TIFPSExternalClass is used when external classes need to be called}
  456.   TIFPSExternalClass = class
  457.   protected
  458.     SE: TIFPSPascalCompiler;
  459.   public
  460.     {The type used as a class}
  461.     function SelfType: Cardinal; virtual;
  462.     {Create}
  463.     constructor Create(Se: TIFPSPascalCompiler);
  464.     {Find a class function}
  465.     function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
  466.     {Call a class function}
  467.     function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  468.     {Find a function}
  469.     function Func_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
  470.     {Call a function}
  471.     function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  472.     {Find a variant}
  473.     function Property_Find(const Name: string; var Index: Cardinal): Boolean; virtual;
  474.     {Return the header of an variant}
  475.     function Property_GetHeader(Index: Cardinal; var s: string): Boolean; virtual;
  476.     {Get a variant value}
  477.     function Property_Get(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  478.     {Set a variant value}
  479.     function Property_Set(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  480.     {Check if the class is compatible}
  481.     function IsCompatibleWith(Cl: TIFPSExternalClass): Boolean; virtual;
  482.     {Returns the ProcNo for setting a class variable to nil}
  483.     function SetNil(TypeNo: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  484.     {Return the procno for casting}
  485.     function CastToType(TypeNo, IntoType: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  486.     {Return the procno for comparing two classes}
  487.     function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
  488.   end;
  489. {Convert a message to a string}
  490. function IFPSMessageToString(x: PIFPSPascalCompilerMessage): string;
  491. {Set the name of an exported variable}
  492. procedure SetVarExportName(P: PIFPSVar; const ExpName: string);
  493. {Transform a double to a string}
  494. function TransDoubleToStr(D: Double): string;
  495. {Transform a single to a string}
  496. function TransSingleToStr(D: Single): string;
  497. {Transform a extended to a string}
  498. function TransExtendedToStr(D: Extended): string;
  499. {Transform a longint to a string}
  500. function TransLongintToStr(D: Longint): string;
  501. {Transform a cardinal to a string}
  502. function TransCardinalToStr(D: Cardinal): string;
  503. {Transform a word to a string}
  504. function TransWordToStr(D: Word): string;
  505. {Transform a smallint to a string}
  506. function TransSmallIntToStr(D: SmallInt): string;
  507. {Transform a byte to a string}
  508. function TransByteToStr(D: Byte): string;
  509. {Transform a shortint to a string}
  510. function TransShortIntToStr(D: ShortInt): string;
  511.  
  512.  
  513. implementation
  514.  
  515. procedure SetVarExportName(P: PIFPSVar; const ExpName: string);
  516. begin
  517.   if p <> nil then
  518.     p^.exportname := ExpName;
  519. end;
  520. function TIFPSPascalCompiler.GetType(BaseType: TIFPSBaseType): Cardinal;
  521. var
  522.   l: Longint;
  523.   x: PIFPSType;
  524. begin
  525.   for l := 0 to FUsedTypes.Count - 1 do
  526.   begin
  527.     x := FUsedTypes.GetItem(l);
  528.     if (x^.BaseType = BaseType) and (x^.Ext = nil) then
  529.     begin
  530.       Result := l;
  531.       exit;
  532.     end;
  533.   end;
  534.   for l := 0 to FAvailableTypes.Count - 1 do
  535.   begin
  536.     x := FAvailableTypes.GetItem(l);
  537.     if (x^.BaseType = BaseType) and (x^.Ext = nil) then
  538.     begin
  539.       FUsedTypes.Add(x);
  540.       Result := FUsedTypes.Count - 1;
  541.       exit;
  542.     end;
  543.   end;
  544.   New(x);
  545.   x^.Name := '';
  546.   x^.NameHash := MakeHash(x^.Name);
  547.   x^.BaseType := BaseType;
  548.   x^.TypeSize := 1;
  549.   x^.DeclarePosition := Cardinal(-1);
  550.   x^.Ext := nil;
  551.   x^.Used := True;
  552.   FAvailableTypes.Add(x);
  553.   FUsedTypes.Add(x);
  554.   Result := FUsedTypes.Count - 1;
  555. end;
  556.  
  557. function TIFPSPascalCompiler.MakeDecl(decl: string): string;
  558. var
  559.   s: string;
  560.   c: char;
  561. begin
  562.   s := grfw(decl);
  563.   if s = '-1' then result := '0' else
  564.   result := PIFPSType(FUsedTypes.GetItem(StrToInt(s)))^.Name;
  565.  
  566.   while length(decl) > 0 do
  567.   begin
  568.     s := grfw(decl);
  569.     c := s[1];
  570.     s := PIFPSType(FUsedTypes.GetItem(StrToInt(grfw(decl))))^.Name;
  571.     result := result +' '+c+s;
  572.   end;
  573. end;
  574.  
  575.  
  576. { TIFPSPascalCompiler }
  577.  
  578. const
  579.   BtTypeCopy = 255;
  580.   btChar = 254;
  581.  
  582. function IFPSMessageToString(x: PIFPSPascalCompilerMessage): string;
  583. begin
  584.   case x^.MessageType of
  585.     ptError:
  586.       begin
  587.         case x^.Error of
  588.           ecUnknownIdentifier: Result := 'Unknown identifier ''' + x^.Param +
  589.             '''';
  590.           ecIdentifierExpected: Result := 'Identifier expected';
  591.           ecCommentError: Result := 'Comment error';
  592.           ecStringError: Result := 'String error';
  593.           ecCharError: Result := 'Char error';
  594.           ecSyntaxError: Result := 'Syntax error';
  595.           ecUnexpectedEndOfFile: Result := 'Unexpected end of file';
  596.           ecSemicolonExpected: Result := 'Semicolon ('';'') expected';
  597.           ecBeginExpected: Result := '''BEGIN'' expected';
  598.           ecPeriodExpected: Result := 'period (''.'') expected';
  599.           ecDuplicateIdentifier: Result := 'Duplicate identifier ''' + x^.Param + '''';
  600.           ecColonExpected: Result := 'colon ('':'') expected';
  601.           ecUnknownType: Result := 'Unknown type ''' + x^.Param + '''';
  602.           ecCloseRoundExpected: Result := 'Close round expected';
  603.           ecTypeMismatch: Result := 'Type mismatch';
  604.           ecInternalError: Result := 'Internal error (' + x^.Param + ')';
  605.           ecAssignmentExpected: Result := 'Assignment expected';
  606.           ecThenExpected: Result := '''THEN'' expected';
  607.           ecDoExpected: Result := '''DO'' expected';
  608.           ecNoResult: Result := 'No result';
  609.           ecOpenRoundExpected: Result := 'open round (''('')expected';
  610.           ecCommaExpected: Result := 'comma ('','') expected';
  611.           ecToExpected: Result := '''TO'' expected';
  612.           ecIsExpected: Result := 'is (''='') expected';
  613.           ecOfExpected: Result := '''OF'' expected';
  614.           ecCloseBlockExpected: Result := 'Close block('']'') expected';
  615.           ecVariableExpected: Result := 'Variable Expected';
  616.           ecStringExpected: result := 'String Expected';
  617.           ecEndExpected: Result := '''END'' expected';
  618.           ecUnSetLabel: Result := 'Label '''+x^.Param+''' not set';
  619.           ecNotInLoop: Result := 'Not in a loop';
  620.           ecInvalidJump: Result := 'Invalid jump';
  621.           ecOpenBlockExpected: Result := 'Open Block (''['') expected';
  622.           ecWriteOnlyProperty: Result := 'Write-only property';
  623.           ecReadOnlyProperty: Result := 'Read-only property';
  624.           ecClassTypeExpected: Result := 'Class type expected';
  625.           ecCustomError: Result := x^.Param;
  626.           ecDivideByZero: Result := 'Divide by Zero';
  627.           ecMathError:  Result := 'Math Error';
  628.           ecUnsatisfiedForward: Result := 'Unsatisfied Forward '+ X^.Param;
  629.         else
  630.           Result := 'Unknown error';
  631.         end;
  632.         Result := '[Error] ' + x^.ModuleName + ': ' + Result;
  633.       end;
  634.     ptHint:
  635.       begin
  636.         case x^.Hint of
  637.           ehVariableNotUsed: Result := 'Variable ''' + x^.Param + ''' never used';
  638.           ehFunctionNotUsed: Result := 'Function ''' + x^.Param + ''' never used';
  639.           ehCustomHint: Result := x^.Param;
  640.         else
  641.           Result := 'Unknown hint';
  642.         end;
  643.         Result := '[Hint] ' + x^.ModuleName + ': ' + Result;
  644.       end;
  645.     ptWarning:
  646.       begin
  647.         case x^.Warning of
  648.           ewCustomWarning: Result := x^.Param;
  649.           ewCalculationAlwaysEvaluatesTo: Result := 'Calculation always evaluates to '+x^.Param;
  650.           ewIsNotNeeded: Result := x^.Param +' is not needed';
  651.         end;
  652.         Result := '[Warning] ' + x^.ModuleName + ': ' + Result;
  653.       end;
  654.   else
  655.     Result := 'Unknown message';
  656.   end;
  657. end;
  658.  
  659. type
  660.   TFuncType = (ftProc, ftFunc);
  661.  
  662. function mi2s(i: Cardinal): string;
  663. begin
  664.   Result := #0#0#0#0;
  665.   Cardinal((@Result[1])^) := i;
  666. end;
  667.  
  668.  
  669.  
  670.  
  671. function TIFPSPascalCompiler.AddType(const Name: string; const BaseType: TIFPSBaseType): PIFPSType;
  672. begin
  673.   if FProcs = nil then begin Result := nil; exit;end;
  674.   New(Result);
  675.   Result^.Name := FastUppercase(Name);
  676.   Result^.NameHash := MakeHash(Result^.Name);
  677.   Result^.BaseType := BaseType;
  678.   Result^.Used := False;
  679.   Result^.TypeSize := 1;
  680.   Result^.DeclarePosition := Cardinal(-1);
  681.   Result^.RecordSubVals := nil;
  682.   Result^.FExport := False;
  683.   Result^.Ext := nil;
  684.   FAvailableTypes.Add(Result);
  685.  
  686. end;
  687.  
  688.  
  689. function TIFPSPascalCompiler.AddFunction(const Header: string): PIFPSRegProc;
  690.  
  691.   function FindType(const s: string): Cardinal;
  692.   var
  693.     h, l: Longint;
  694.   begin
  695.     h := MakeHash(s);
  696.     for l := 0 to FAvailableTypes.Count - 1 do
  697.     begin
  698.       if (PIFPSType(FAvailableTypes.GetItem(l))^.NameHash = h) and
  699.         (PIFPSType(FAvailableTypes.GetItem(l))^.Name = s) then
  700.       begin
  701.         Result := l;
  702.         exit;
  703.       end;
  704.     end;
  705.     Result := Cardinal(-1);
  706.   end;
  707. var
  708.   Parser: TIfPascalParser;
  709.   IsFunction: Boolean;
  710.   VNames, Name, Decl: string;
  711.   modifier: Char;
  712.   VCType: Cardinal;
  713.   x: PIFPSRegProc;
  714. begin
  715.   if FProcs = nil then begin Result := nil; exit;end;
  716.   Parser := TIfPascalParser.Create;
  717.   Parser.SetText(Header);
  718.   if Parser.CurrTokenId = CSTII_Function then
  719.     IsFunction := True
  720.   else if Parser.CurrTokenId = CSTII_Procedure then
  721.     IsFunction := False
  722.   else
  723.   begin
  724.     Parser.Free;
  725.     Result := nil;
  726.     exit;
  727.   end;
  728.   Decl := '';
  729.   Parser.Next;
  730.   if Parser.CurrTokenId <> CSTI_Identifier then
  731.   begin
  732.     Parser.Free;
  733.     Result := nil;
  734.     exit;
  735.   end; {if}
  736.   Name := Parser.GetToken;
  737.   Parser.Next;
  738.   if Parser.CurrTokenId = CSTI_OpenRound then
  739.   begin
  740.     Parser.Next;
  741.     if Parser.CurrTokenId <> CSTI_CloseRound then
  742.     begin
  743.       while True do
  744.       begin
  745.         if Parser.CurrTokenId = CSTII_Const then
  746.         begin
  747.           Modifier := '@';
  748.           Parser.Next;
  749.         end else
  750.         if Parser.CurrTokenId = CSTII_Var then
  751.         begin
  752.           modifier := '!';
  753.           Parser.Next;
  754.         end
  755.         else
  756.           modifier := '@';
  757.         if Parser.CurrTokenId <> CSTI_Identifier then
  758.         begin
  759.           Parser.Free;
  760.           Result := nil;
  761.           exit;
  762.         end;
  763.         VNames := Parser.GetToken + '|';
  764.         Parser.Next;
  765.         while Parser.CurrTokenId = CSTI_Comma do
  766.         begin
  767.           Parser.Next;
  768.           if Parser.CurrTokenId <> CSTI_Identifier then
  769.           begin
  770.             Parser.Free;
  771.             Result := nil;
  772.             exit;
  773.           end;
  774.           VNames := VNames + Parser.GetToken + '|';
  775.           Parser.Next;
  776.         end;
  777.         if Parser.CurrTokenId <> CSTI_Colon then
  778.         begin
  779.           Parser.Free;
  780.           Result := nil;
  781.           exit;
  782.         end;
  783.         Parser.Next;
  784.         VCType := FindType(Parser.GetToken);
  785.         if VCType = Cardinal(-1) then
  786.         begin
  787.           Parser.Free;
  788.           Result := nil;
  789.           exit;
  790.         end;
  791.         while Pos('|', VNames) > 0 do
  792.         begin
  793.           Decl := Decl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1)
  794.             +
  795.             ' ' + inttostr(VCType);
  796.           Delete(VNames, 1, Pos('|', VNames));
  797.         end;
  798.         Parser.Next;
  799.         if Parser.CurrTokenId = CSTI_CloseRound then
  800.           break;
  801.         if Parser.CurrTokenId <> CSTI_Semicolon then
  802.         begin
  803.           Parser.Free;
  804.           Result := nil;
  805.           exit;
  806.         end;
  807.         Parser.Next;
  808.       end; {while}
  809.     end; {if}
  810.     Parser.Next;
  811.   end; {if}
  812.   if IsFunction then
  813.   begin
  814.     if Parser.CurrTokenId <> CSTI_Colon then
  815.     begin
  816.       Parser.Free;
  817.       Result := nil;
  818.       exit;
  819.     end;
  820.  
  821.     Parser.Next;
  822.     VCType := FindType(Parser.GetToken);
  823.     if VCType = Cardinal(-1) then
  824.     begin
  825.       Parser.Free;
  826.       Result := nil;
  827.       exit;
  828.     end;
  829.   end
  830.   else
  831.     VCType := Cardinal(-1);
  832.   Decl := inttostr(VCType) + Decl;
  833.   Parser.Free;
  834.   New(x);
  835.   x^.Name := Name;
  836.   x^.NameHash := MakeHash(Name);
  837.   x^.FExportName := True;
  838.   x^.Decl := Decl;
  839.   Result := x;
  840.   FRegProcs.Add(x);
  841. end;
  842.  
  843. function TIFPSPascalCompiler.MakeHint(const Module: string; E: TIFPSPascalCompilerHint; const Param: string): PIFPSPascalCompilerMessage;
  844. var
  845.   n: PIFPSPascalCompilerMessage;
  846. begin
  847.   New(n);
  848.   n^.ModuleName := Module;
  849.   n^.Param := Param;
  850.   n^.Position := FParser.CurrTokenPos;
  851.   n^.MessageType := ptHint;
  852.   n^.Hint := E;
  853.   FMessages.Add(n);
  854.   Result := n;
  855. end;
  856. function TIFPSPascalCompiler.MakeError(const Module: string; E:
  857.   TIFPSPascalCompilerError; const Param: string): PIFPSPascalCompilerMessage;
  858. var
  859.   n: PIFPSPascalCompilerMessage;
  860. begin
  861.   New(n);
  862.   n^.ModuleName := Module;
  863.   n^.Param := Param;
  864.   n^.Position := FParser.CurrTokenPos;
  865.   n^.MessageType := ptError;
  866.   n^.Error := E;
  867.   FMessages.Add(n);
  868.   Result := n;
  869. end;
  870.  
  871. function TIFPSPascalCompiler.MakeWarning(const Module: string; E:
  872.   TIFPSPascalCompilerWarning; const Param: string): PIFPSPascalCompilerMessage;
  873. var
  874.   n: PIFPSPascalCompilerMessage;
  875. begin
  876.   New(n);
  877.   n^.ModuleName := Module;
  878.   n^.Param := Param;
  879.   n^.Position := FParser.CurrTokenPos;
  880.   n^.MessageType := ptWarning;
  881.   n^.Warning := E;
  882.   FMessages.Add(n);
  883.   Result := n;
  884. end;
  885.  
  886. procedure TIFPSPascalCompiler.Clear;
  887. var
  888.   l: Longint;
  889.   p: PIFPSPascalCompilerMessage;
  890. begin
  891.   FDebugOutput := '';
  892.   FOutput := '';
  893.   for l := 0 to FMessages.Count - 1 do
  894.   begin
  895.     p := FMessages.GetItem(l);
  896.     Dispose(p);
  897.   end;
  898.   FMessages.Clear;
  899.   for L := FAutoFreeList.Count -1 downto 0 do
  900.   begin
  901.     TObject(FAutoFreeList.GetItem(l)).Free;
  902.   end;
  903.   FAutoFreeList.Clear;
  904. end;
  905.  
  906.  
  907. procedure DisposeVariant(p: PIfRVariant);
  908. begin
  909.   if p <> nil then
  910.   begin
  911.     p^.Value := '';
  912.     Dispose(p);
  913.   end;
  914. end;
  915.  
  916. type
  917.   PParam = ^TParam;
  918.   TParam = record
  919.     InReg, OutReg: PIFPSValue;
  920.     FType: Cardinal;
  921.     OutRegPos: Cardinal;
  922.   end;
  923.  
  924. procedure DisposePValue(r: PIFPSValue); forward;
  925.  
  926. procedure FreeRecFields(List: TIfList);
  927. var
  928.   i: Longint;
  929.   p: PIFRecField;
  930. begin
  931.   if list = nil then
  932.     exit;
  933.   for i := List.Count - 1 downto 0 do
  934.   begin
  935.     p := List.GetItem(i);
  936.     if p^.FKind >= 2 then
  937.     begin
  938.       DisposePValue(p^.ReadArrayFieldNoFrom);
  939.     end;
  940.     Dispose(p);
  941.   end;
  942.   List.Free;
  943. end;
  944.  
  945. procedure DisposePValue(r: PIFPSValue);
  946. var
  947.   l: Longint;
  948.   p: PCalc_Item;
  949.   P2: PParam;
  950. begin
  951.   if (r <> nil) and ((r^.Modifiers and 128)= 0) then
  952.   begin
  953.     if (r^.FType = CVAL_Array) then
  954.     begin
  955.       for l := 0 to r.ArrayItems.Count -1 do
  956.       begin
  957.         DisposePValue(R.ArrayItems.GetItem(l));
  958.       end;
  959.       r.ArrayItems.Free;
  960.     end else
  961.     if (r^.FType = CVAL_AllocatedStackReg) or (r^.FType = CVAL_Addr) or (r^.FType = CVAL_PushAddr) then
  962.     begin
  963.       FreeRecFields(R^.RecField);
  964.     end
  965.     else if r.FType = CVAL_Data then
  966.       DisposeVariant(r^.FData)
  967.     else if r.FType = CVAL_Eval then
  968.     begin
  969.       for l := 0 to r.SubItems.Count - 1 do
  970.       begin
  971.         p := r.SubItems.GetItem(l);
  972.         if not p^.C then
  973.           DisposePValue(p^.OutRec);
  974.         Dispose(p);
  975.       end;
  976.       r^.SubItems.Free;
  977.     end
  978.     else if (r.FType = CVAL_Proc) or (r.FType = CVAL_varProc)then
  979.     begin
  980.       for l := 0 to r^.Parameters.Count - 1 do
  981.       begin
  982.         P2 := r^.Parameters.GetItem(l);
  983.         if P2^.InReg <> nil then
  984.           DisposePValue(P2^.InReg);
  985.         Dispose(P2);
  986.       end;
  987.       r.Parameters.Free;
  988.       if r.FType = CVAL_VarProc then
  989.         DisposePValue(r._ProcNo);
  990.     end else if (r.FType = CVAL_ClassPropertyCallGet) or (r.FType = CVAL_ClassPropertyCallSet) or (r.FType = CVAL_ClassMethodCall) or (r.FType = CVAL_ClassProcCall) then
  991.     begin
  992.       DisposePValue(r.Self);
  993.       for l := 0 to r^.Params.Count - 1 do
  994.       begin
  995.         P2 := r^.Params.GetItem(l);
  996.         if P2^.InReg <> nil then
  997.           DisposePValue(P2^.InReg);
  998.         Dispose(P2);
  999.       end;
  1000.     end;
  1001.     Dispose(r);
  1002.   end;
  1003. end;
  1004.  
  1005. function TIFPSPascalCompiler.GetTypeCopyLink(p: PIFPSType): PIFPSType;
  1006. begin
  1007.   if p^.BaseType = BtTypeCopy then begin
  1008.     if p^.Ext <> nil then
  1009.       Result := p^.Ext
  1010.     else
  1011.       Result := nil
  1012.   end else Result := p;
  1013. end;
  1014.  
  1015. function IsIntType(b: TIFPSBaseType): Boolean;
  1016. begin
  1017.   case b of
  1018.     btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF NOINT64}, btS64{$ENDIF}: Result := True;
  1019.   else
  1020.     Result := False;
  1021.   end;
  1022. end;
  1023.  
  1024. function IsRealType(b: TIFPSBaseType): Boolean;
  1025. begin
  1026.   case b of
  1027.     btSingle, btDouble, btExtended: Result := True;
  1028.   else
  1029.     Result := False;
  1030.   end;
  1031. end;
  1032.  
  1033. function IsIntRealType(b: TIFPSBaseType): Boolean;
  1034. begin
  1035.   case b of
  1036.     btSingle, btDouble, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF NOINT64}, btS64{$ENDIF}:
  1037.       Result := True;
  1038.   else
  1039.     Result := False;
  1040.   end;
  1041.  
  1042. end;
  1043.  
  1044. function DiffRec(p1, p2: PIFRecField): Boolean;
  1045. begin
  1046.   Result :=
  1047.     (p1^.FKind <> p2^.FKind) or
  1048.     (p1^.RecFieldNo <> p2^.RecFieldNo);
  1049. end;
  1050.  
  1051. function SameReg(x1, x2: PIFPSValue): Boolean;
  1052. var
  1053.   I: Longint;
  1054. begin
  1055.   if x1^.FType = x2^.FType then
  1056.   begin
  1057.     case x1^.FType of
  1058.       CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg, CVAL_AllocatedStackReg +1:
  1059.         begin
  1060.           if x1^.Address = x2^.Address then
  1061.           begin
  1062.             if (x1^.RecField = nil) and (x2^.RecField = nil) then
  1063.               Result := True
  1064.             else if (x1^.RecField <> nil) and (x2^.RecField <> nil) and
  1065.               (x1^.RecField.Count = x2^.RecField.Count) then
  1066.             begin
  1067.               for I := x1^.RecField.Count - 1 downto 0 do
  1068.               begin
  1069.                 if DiffRec(x1^.RecField.GetItem(I), x2^.RecField.GetItem(I))
  1070.                   then
  1071.                 begin
  1072.                   Result := False;
  1073.                   exit;
  1074.                 end;
  1075.               end;
  1076.               Result := True;
  1077.             end
  1078.             else
  1079.               Result := False;
  1080.           end
  1081.           else
  1082.             Result := False;
  1083.         end;
  1084.     else
  1085.       Result := False;
  1086.     end;
  1087.   end
  1088.   else
  1089.     Result := False;
  1090. end;
  1091.  
  1092. function D1(const s: string): string;
  1093. begin
  1094.   Result := copy(s, 2, Length(s) - 1);
  1095. end;
  1096.  
  1097. function TIFPSPascalCompiler.AT2UT(L: Cardinal): Cardinal;
  1098. var
  1099.   i: Longint;
  1100.   p: PIFPSType;
  1101. begin
  1102.   if L = Cardinal(-1) then begin Result := Cardinal(-1); exit; end;
  1103.   p := FAvailableTypes.GetItem(L);
  1104.   p := GetTypeCopyLink(p);
  1105.   if p^.Used then
  1106.   begin
  1107.     for i := 0 to FUsedTypes.Count - 1 do
  1108.     begin
  1109.       if FUSedTypes.GetItem(I) = P then
  1110.       begin
  1111.         Result := i;
  1112.         exit;
  1113.       end;
  1114.     end;
  1115.   end;
  1116.   UpdateRecordFields(p);
  1117.   p^.Used := True;
  1118.   FUsedTypes.Add(p);
  1119.   Result := FUsedTypes.Count - 1;
  1120. end;
  1121.  
  1122.  
  1123. procedure TIFPSPascalCompiler.ReplaceTypes(var s: string);
  1124. var
  1125.   NewS: string;
  1126.   ts: string;
  1127. begin
  1128.   ts := GRFW(s);
  1129.   if ts <> '-1' then
  1130.   begin
  1131.     NewS := IntToStr(AT2UT(StrToInt(ts)));
  1132.   end
  1133.   else
  1134.     NewS := '-1';
  1135.   while length(s) > 0 do
  1136.   begin
  1137.     NewS := NewS + ' ' + grfw(s);
  1138.     ts := grfw(s);
  1139.     NewS := NewS + ' ' + IntToStr(AT2UT(StrToInt(ts)));
  1140.   end;
  1141.   s := NewS;
  1142. end;
  1143.  
  1144.  
  1145. function TIFPSPascalCompiler.GetUInt(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): Cardinal;
  1146. begin
  1147.   case PIFPSType(FUseTypes.GetItem(Src^.FType))^.BaseType of
  1148.     btU8: Result := TbtU8((@Src^.Value[1])^);
  1149.     btS8: Result := TbtS8((@Src^.Value[1])^);
  1150.     btU16: Result := TbtU16((@Src^.Value[1])^);
  1151.     btS16: Result := TbtS16((@Src^.Value[1])^);
  1152.     btU32: Result := TbtU32((@Src^.Value[1])^);
  1153.     btS32: Result := TbtS32((@Src^.Value[1])^);
  1154.   else
  1155.     begin
  1156.       s := False;
  1157.       Result := 0;
  1158.     end;
  1159.   end;
  1160. end;
  1161.  
  1162. function TIFPSPascalCompiler.GetInt(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): Longint;
  1163. begin
  1164.   case PIFPSType(FUseTypes.GetItem(Src^.FType))^.BaseType of
  1165.     btU8: Result := TbtU8((@Src^.Value[1])^);
  1166.     btS8: Result := TbtS8((@Src^.Value[1])^);
  1167.     btU16: Result := TbtU16((@Src^.Value[1])^);
  1168.     btS16: Result := TbtS16((@Src^.Value[1])^);
  1169.     btU32: Result := TbtU32((@Src^.Value[1])^);
  1170.     btS32: Result := TbtS32((@Src^.Value[1])^);
  1171.   else
  1172.     begin
  1173.       s := False;
  1174.       Result := 0;
  1175.     end;
  1176.   end;
  1177. end;
  1178.  
  1179. function TIFPSPascalCompiler.GetReal(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): Extended;
  1180. begin
  1181.   case PIFPSType(FUseTypes.GetItem(Src^.FType))^.BaseType of
  1182.     btU8: Result := TbtU8((@Src^.Value[1])^);
  1183.     btS8: Result := TbtS8((@Src^.Value[1])^);
  1184.     btU16: Result := TbtU16((@Src^.Value[1])^);
  1185.     btS16: Result := TbtS16((@Src^.Value[1])^);
  1186.     btU32: Result := TbtU32((@Src^.Value[1])^);
  1187.     btS32: Result := TbtS32((@Src^.Value[1])^);
  1188.     btSingle: Result := TbtSingle((@Src^.Value[1])^);
  1189.     btDouble: Result := TbtDouble((@Src^.Value[1])^);
  1190.     btExtended: Result := TbtExtended((@Src^.Value[1])^);
  1191.   else
  1192.     begin
  1193.       s := False;
  1194.       Result := 0;
  1195.     end;
  1196.   end;
  1197. end;
  1198.  
  1199. function TIFPSPascalCompiler.GetString(FUseTypes: TIfList; Src: PIfRVariant; var s: Boolean): string;
  1200. begin
  1201.   case PIFPSType(FUseTypes.GetItem(Src^.FType))^.BaseType of
  1202.     btChar: Result := Src^.Value;
  1203.     btString: Result := Src^.Value;
  1204.   else
  1205.     begin
  1206.       s := False;
  1207.       Result := '';
  1208.     end;
  1209.   end;
  1210. end;
  1211.  
  1212. function TIFPSPascalCompiler.PreCalc(FUseTypes: TIfList; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: Byte; Pos: Cardinal): Boolean;
  1213.   { var1=dest, var2=src }
  1214. var
  1215.   b: Boolean;
  1216.  
  1217.   procedure SetBoolean(b: Boolean);
  1218.   begin
  1219.     if FUseTypes = FAvailableTypes then
  1220.       Var1^.FType := FBooleanType
  1221.     else
  1222.       Var1^.FType := at2ut(FBooleanType);
  1223.     var1^.Value := Chr(Ord(b));
  1224.   end;
  1225.   function ab(b: Longint): Longint;
  1226.   begin
  1227.     ab := Longint(b = 0);
  1228.   end;
  1229.  
  1230. begin
  1231.   Result := True;
  1232.   try
  1233.     case Cmd of
  1234.       0:
  1235.         begin { + }
  1236.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1237.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) +
  1238.               GetUInt(FUseTypes, Var2, Result);
  1239.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) +
  1240.               GetInt(FUseTypes,Var2, Result);
  1241.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) +
  1242.               GetUInt(FUseTypes, Var2, Result);
  1243.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) +
  1244.               GetInt(FUseTypes, Var2, Result);
  1245.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) +
  1246.               GetUInt(FUseTypes, Var2, Result);
  1247.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) +
  1248.               GetInt(FUseTypes, Var2, Result);
  1249.             btSingle: TbtSingle((@var1^.Value[1])^) :=
  1250.               TbtSingle((@var1^.Value[1])^) + GetReal(FUseTypes, Var2, Result);
  1251.             btDouble: TbtDouble((@var1^.Value[1])^) :=
  1252.               TbtDouble((@var1^.Value[1])^) + GetReal(FUseTypes, Var2, Result);
  1253.             btExtended: TbtExtended((@var1^.Value[1])^) :=
  1254.               TbtExtended((@var1^.Value[1])^) + GetReal(FUseTypes, Var2, Result);
  1255.             btString: var1^.Value := var1^.Value + GetString(FUseTypes, Var2, Result);
  1256.           end;
  1257.         end;
  1258.       1:
  1259.         begin { - }
  1260.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1261.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) -
  1262.               GetUInt(FUseTypes, Var2, Result);
  1263.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) -
  1264.               GetInt(FUseTypes, Var2, Result);
  1265.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) -
  1266.               GetUInt(FUseTypes, Var2, Result);
  1267.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) -
  1268.               GetInt(FUseTypes, Var2, Result);
  1269.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) -
  1270.               GetUInt(FUseTypes, Var2, Result);
  1271.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) -
  1272.               GetInt(FUseTypes, Var2, Result);
  1273.             btSingle: TbtSingle((@var1^.Value[1])^) :=
  1274.               TbtSingle((@var1^.Value[1])^) - GetReal(FUseTypes, Var2, Result);
  1275.             btDouble: TbtDouble((@var1^.Value[1])^) :=
  1276.               TbtDouble((@var1^.Value[1])^) - GetReal(FUseTypes,Var2, Result);
  1277.             btExtended: TbtExtended((@var1^.Value[1])^) :=
  1278.               TbtExtended((@var1^.Value[1])^) - GetReal(FUseTypes,Var2, Result);
  1279.           end;
  1280.         end;
  1281.       2:
  1282.         begin { * }
  1283.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1284.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) *
  1285.               GetUInt(FUseTypes, Var2, Result);
  1286.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) *
  1287.               GetInt(FUseTypes, Var2, Result);
  1288.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) *
  1289.               GetUInt(FUseTypes, Var2, Result);
  1290.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) *
  1291.               GetInt(FUseTypes, Var2, Result);
  1292.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) *
  1293.               GetUInt(FUseTypes, Var2, Result);
  1294.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) *
  1295.               GetInt(FUseTypes, Var2, Result);
  1296.             btSingle: TbtSingle((@var1^.Value[1])^) :=
  1297.               TbtSingle((@var1^.Value[1])^) * GetReal(FUseTypes,Var2, Result);
  1298.             btDouble: TbtDouble((@var1^.Value[1])^) :=
  1299.               TbtDouble((@var1^.Value[1])^) * GetReal(FUseTypes,Var2, Result);
  1300.             btExtended: TbtExtended((@var1^.Value[1])^) :=
  1301.               TbtExtended((@var1^.Value[1])^) * GetReal(FUseTypes, Var2, Result);
  1302.           end;
  1303.         end;
  1304.       3:
  1305.         begin { / }
  1306.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1307.             btU8:
  1308.                 TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) div
  1309.                   GetUInt(FUseTypes, Var2, Result);
  1310.             btS8:
  1311.                 TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) div
  1312.                   GetInt(FUseTypes, Var2, Result);
  1313.             btU16:
  1314.                 TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) div
  1315.                   GetUInt(FUseTypes, Var2, Result);
  1316.             btS16:
  1317.                 TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) div
  1318.                   GetInt(FUseTypes, Var2, Result);
  1319.             btU32:
  1320.                 TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) div
  1321.                   GetUInt(FUseTypes, Var2, Result);
  1322.             btS32:
  1323.                 TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) div
  1324.                   GetInt(FUseTypes, Var2, Result);
  1325.             btSingle:
  1326.                 TbtSingle((@var1^.Value[1])^) := TbtSingle((@var1^.Value[1])^)
  1327.                   / GetReal(FUseTypes, Var2, Result);
  1328.             btDouble:
  1329.                 TbtDouble((@var1^.Value[1])^) := TbtDouble((@var1^.Value[1])^)
  1330.                   / GetReal(FUseTypes, Var2, Result);
  1331.             btExtended:
  1332.                 TbtExtended((@var1^.Value[1])^) :=
  1333.                   TbtExtended((@var1^.Value[1])^) / GetReal(FUseTypes, Var2, Result);
  1334.           end;
  1335.         end;
  1336.       4:
  1337.         begin { MOD }
  1338.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1339.             btU8:
  1340.                 TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) mod
  1341.                   GetUInt(FUseTypes, Var2, Result);
  1342.             btS8:
  1343.                 TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) mod
  1344.                   GetInt(FUseTypes, Var2, Result);
  1345.             btU16:
  1346.                 TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) mod
  1347.                   GetUInt(FUseTypes, Var2, Result);
  1348.             btS16:
  1349.                 TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) mod
  1350.                   GetInt(FUseTypes, Var2, Result);
  1351.             btU32:
  1352.                 TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) mod
  1353.                   GetUInt(FUseTypes, Var2, Result);
  1354.             btS32:
  1355.                 TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) mod
  1356.                   GetInt(FUseTypes, Var2, Result);
  1357.           end;
  1358.         end;
  1359.       5:
  1360.         begin { SHL }
  1361.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1362.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) shl
  1363.               GetUInt(FUseTypes, Var2, Result);
  1364.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) shl
  1365.               GetInt(FUseTypes, Var2, Result);
  1366.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^)
  1367.               shl
  1368.                 GetUInt(FUseTypes, Var2, Result);
  1369.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^)
  1370.               shl
  1371.                 GetInt(FUseTypes, Var2, Result);
  1372.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^)
  1373.               shl
  1374.                 GetUInt(FUseTypes, Var2, Result);
  1375.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^)
  1376.               shl
  1377.                 GetInt(FUseTypes, Var2, Result);
  1378.           end;
  1379.         end;
  1380.       6:
  1381.         begin { SHR }
  1382.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1383.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) shr
  1384.               GetUInt(FUseTypes, Var2, Result);
  1385.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) shr
  1386.               GetInt(FUseTypes, Var2, Result);
  1387.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^)
  1388.               shr
  1389.                 GetUInt(FUseTypes, Var2, Result);
  1390.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^)
  1391.               shr
  1392.                 GetInt(FUseTypes, Var2, Result);
  1393.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^)
  1394.               shr
  1395.                 GetUInt(FUseTypes, Var2, Result);
  1396.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^)
  1397.               shr
  1398.                 GetInt(FUseTypes, Var2, Result);
  1399.           end;
  1400.         end;
  1401.       7:
  1402.         begin { AND }
  1403.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1404.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) and
  1405.               GetUInt(FUseTypes, Var2, Result);
  1406.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) and
  1407.               GetInt(FUseTypes, Var2, Result);
  1408.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^)
  1409.               and
  1410.                 GetUInt(FUseTypes, Var2, Result);
  1411.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^)
  1412.               and
  1413.                 GetInt(FUseTypes, Var2, Result);
  1414.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^)
  1415.               and
  1416.                 GetUInt(FUseTypes, Var2, Result);
  1417.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^)
  1418.               and
  1419.                 GetInt(FUseTypes, Var2, Result);
  1420.           end;
  1421.         end;
  1422.       8:
  1423.         begin { OR }
  1424.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1425.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) or
  1426.               GetUInt(FUseTypes, Var2, Result);
  1427.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) or
  1428.               GetInt(FUseTypes, Var2, Result);
  1429.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^) or
  1430.               GetUInt(FUseTypes, Var2, Result);
  1431.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^) or
  1432.               GetInt(FUseTypes, Var2, Result);
  1433.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^) or
  1434.               GetUInt(FUseTypes, Var2, Result);
  1435.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^) or
  1436.               GetInt(FUseTypes, Var2, Result);
  1437.           end;
  1438.         end;
  1439.       9:
  1440.         begin { XOR }
  1441.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1442.             btU8: TbtU8((@var1^.Value[1])^) := TbtU8((@var1^.Value[1])^) xor
  1443.               GetUInt(FUseTypes, Var2, Result);
  1444.             btS8: TbtS8((@var1^.Value[1])^) := TbtS8((@var1^.Value[1])^) xor
  1445.               GetInt(FUseTypes, Var2, Result);
  1446.             btU16: TbtU16((@var1^.Value[1])^) := TbtU16((@var1^.Value[1])^)
  1447.               xor
  1448.                 GetUInt(FUseTypes, Var2, Result);
  1449.             btS16: TbtS16((@var1^.Value[1])^) := TbtS16((@var1^.Value[1])^)
  1450.               xor
  1451.                 GetInt(FUseTypes, Var2, Result);
  1452.             btU32: TbtU32((@var1^.Value[1])^) := TbtU32((@var1^.Value[1])^)
  1453.               xor
  1454.                 GetUInt(FUseTypes, Var2, Result);
  1455.             btS32: TbtS32((@var1^.Value[1])^) := TbtS32((@var1^.Value[1])^)
  1456.               xor
  1457.                 GetInt(FUseTypes, Var2, Result);
  1458.           end;
  1459.         end;
  1460.       10:
  1461.         begin { >= }
  1462.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1463.             btU8: b := TbtU8((@var1^.Value[1])^) >= GetUInt(FUseTypes, Var2, Result);
  1464.             btS8: b := TbtS8((@var1^.Value[1])^) >= GetInt(FUseTypes, Var2, Result);
  1465.             btU16: b := TbtU16((@var1^.Value[1])^) >= GetUInt(FUseTypes, Var2, Result);
  1466.             btS16: b := TbtS16((@var1^.Value[1])^) >= GetInt(FUseTypes, Var2, Result);
  1467.             btU32: b := TbtU32((@var1^.Value[1])^) >= GetUInt(FUseTypes, Var2, Result);
  1468.             btS32: b := TbtS32((@var1^.Value[1])^) >= GetInt(FUseTypes, Var2, Result);
  1469.             btSingle: b := TbtSingle((@var1^.Value[1])^) >= GetReal(FUseTypes, Var2,
  1470.                 Result);
  1471.             btDouble: b := TbtDouble((@var1^.Value[1])^) >= GetReal(FUseTypes, Var2,
  1472.                 Result);
  1473.             btExtended: b := TbtExtended((@var1^.Value[1])^) >= GetReal(FUseTypes, Var2,
  1474.                 Result);
  1475.           else
  1476.             b := False;
  1477.           end;
  1478.           SetBoolean(b);
  1479.         end;
  1480.       11:
  1481.         begin { <= }
  1482.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1483.             btU8: b := TbtU8((@var1^.Value[1])^) <= GetUInt(FUseTypes, Var2, Result);
  1484.             btS8: b := TbtS8((@var1^.Value[1])^) <= GetInt(FUseTypes, Var2, Result);
  1485.             btU16: b := TbtU16((@var1^.Value[1])^) <= GetUInt(FUseTypes, Var2, Result);
  1486.             btS16: b := TbtS16((@var1^.Value[1])^) <= GetInt(FUseTypes, Var2, Result);
  1487.             btU32: b := TbtU32((@var1^.Value[1])^) <= GetUInt(FUseTypes, Var2, Result);
  1488.             btS32: b := TbtS32((@var1^.Value[1])^) <= GetInt(FUseTypes, Var2, Result);
  1489.             btSingle: b := TbtSingle((@var1^.Value[1])^) <= GetReal(FUseTypes, Var2,
  1490.                 Result);
  1491.             btDouble: b := TbtDouble((@var1^.Value[1])^) <= GetReal(FUseTypes, Var2,
  1492.                 Result);
  1493.             btExtended: b := TbtExtended((@var1^.Value[1])^) <= GetReal(FUseTypes, Var2,
  1494.                 Result);
  1495.           else
  1496.             b := False;
  1497.           end;
  1498.           SetBoolean(b);
  1499.         end;
  1500.       12:
  1501.         begin { > }
  1502.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1503.             btU8: b := TbtU8((@var1^.Value[1])^) > GetUInt(FUseTypes, Var2, Result);
  1504.             btS8: b := TbtS8((@var1^.Value[1])^) > GetInt(FUseTypes, Var2, Result);
  1505.             btU16: b := TbtU16((@var1^.Value[1])^) > GetUInt(FUseTypes, Var2, Result);
  1506.             btS16: b := TbtS16((@var1^.Value[1])^) > GetInt(FUseTypes, Var2, Result);
  1507.             btU32: b := TbtU32((@var1^.Value[1])^) > GetUInt(FUseTypes, Var2, Result);
  1508.             btS32: b := TbtS32((@var1^.Value[1])^) > GetInt(FUseTypes, Var2, Result);
  1509.             btSingle: b := TbtSingle((@var1^.Value[1])^) > GetReal(FUseTypes, Var2,
  1510.                 Result);
  1511.             btDouble: b := TbtDouble((@var1^.Value[1])^) > GetReal(FUseTypes, Var2,
  1512.                 Result);
  1513.             btExtended: b := TbtExtended((@var1^.Value[1])^) > GetReal(FUseTypes, Var2,
  1514.                 Result);
  1515.           else
  1516.             b := False;
  1517.           end;
  1518.           SetBoolean(b);
  1519.         end;
  1520.       13:
  1521.         begin { < }
  1522.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1523.             btU8: b := TbtU8((@var1^.Value[1])^) < GetUInt(FUseTypes, Var2, Result);
  1524.             btS8: b := TbtS8((@var1^.Value[1])^) < GetInt(FUseTypes, Var2, Result);
  1525.             btU16: b := TbtU16((@var1^.Value[1])^) < GetUInt(FUseTypes, Var2, Result);
  1526.             btS16: b := TbtS16((@var1^.Value[1])^) < GetInt(FUseTypes, Var2, Result);
  1527.             btU32: b := TbtU32((@var1^.Value[1])^) < GetUInt(FUseTypes, Var2, Result);
  1528.             btS32: b := TbtS32((@var1^.Value[1])^) < GetInt(FUseTypes, Var2, Result);
  1529.             btSingle: b := TbtSingle((@var1^.Value[1])^) < GetReal(FUseTypes, Var2,
  1530.                 Result);
  1531.             btDouble: b := TbtDouble((@var1^.Value[1])^) < GetReal(FUseTypes, Var2,
  1532.                 Result);
  1533.             btExtended: b := TbtExtended((@var1^.Value[1])^) < GetReal(FUseTypes, Var2,
  1534.                 Result);
  1535.           else
  1536.             b := False;
  1537.           end;
  1538.           SetBoolean(b);
  1539.         end;
  1540.       14:
  1541.         begin { <> }
  1542.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1543.             btU8: b := TbtU8((@var1^.Value[1])^) <> GetUInt(FUseTypes, Var2, Result);
  1544.             btS8: b := TbtS8((@var1^.Value[1])^) <> GetInt(FUseTypes, Var2, Result);
  1545.             btU16: b := TbtU16((@var1^.Value[1])^) <> GetUInt(FUseTypes, Var2, Result);
  1546.             btS16: b := TbtS16((@var1^.Value[1])^) <> GetInt(FUseTypes, Var2, Result);
  1547.             btU32: b := TbtU32((@var1^.Value[1])^) <> GetUInt(FUseTypes, Var2, Result);
  1548.             btS32: b := TbtS32((@var1^.Value[1])^) <> GetInt(FUseTypes, Var2, Result);
  1549.             btSingle: b := TbtSingle((@var1^.Value[1])^) <> GetReal(FUseTypes, Var2,
  1550.                 Result);
  1551.             btDouble: b := TbtDouble((@var1^.Value[1])^) <> GetReal(FUseTypes, Var2,
  1552.                 Result);
  1553.             btExtended: b := TbtExtended((@var1^.Value[1])^) <> GetReal(FUseTypes, Var2,
  1554.                 Result);
  1555.           else
  1556.             b := False;
  1557.           end;
  1558.           SetBoolean(b);
  1559.         end;
  1560.       15:
  1561.         begin { = }
  1562.           case PIFPSType(FUseTypes.GetItem(var1^.FType))^.BaseType of
  1563.             btU8: b := TbtU8((@var1^.Value[1])^) = GetUInt(FUseTypes, Var2, Result);
  1564.             btS8: b := TbtS8((@var1^.Value[1])^) = GetInt(FUseTypes, Var2, Result);
  1565.             btU16: b := TbtU16((@var1^.Value[1])^) = GetUInt(FUseTypes, Var2, Result);
  1566.             btS16: b := TbtS16((@var1^.Value[1])^) = GetInt(FUseTypes, Var2, Result);
  1567.             btU32: b := TbtU32((@var1^.Value[1])^) = GetUInt(FUseTypes, Var2, Result);
  1568.             btS32: b := TbtS32((@var1^.Value[1])^) = GetInt(FUseTypes, Var2, Result);
  1569.             btSingle: b := TbtSingle((@var1^.Value[1])^) = GetReal(FUseTypes, Var2,
  1570.                 Result);
  1571.             btDouble: b := TbtDouble((@var1^.Value[1])^) = GetReal(FUseTypes, Var2,
  1572.                 Result);
  1573.             btExtended: b := TbtExtended((@var1^.Value[1])^) = GetReal(FUseTypes, Var2,
  1574.                 Result);
  1575.           else
  1576.             b := False;
  1577.           end;
  1578.           SetBoolean(b);
  1579.         end;
  1580.     end;
  1581.   except
  1582.     on E: EDivByZero do
  1583.     begin
  1584.       Result := False;
  1585.       MakeError('', ecDivideByZero, '');
  1586.       Exit;
  1587.     end;
  1588.     on E: EZeroDivide do
  1589.     begin
  1590.       Result := False;
  1591.       MakeError('', ecDivideByZero, '');
  1592.       Exit;
  1593.     end;
  1594.     on E: EMathError do
  1595.     begin
  1596.       Result := False;
  1597.       MakeError('', ecMathError, e.Message);
  1598.       Exit;
  1599.     end;
  1600.     on E: Exception do
  1601.     begin
  1602.       Result := False;
  1603.       MakeError('', ecInternalError, E.Message);
  1604.       Exit;
  1605.     end;
  1606.   end;
  1607.   if not Result then
  1608.     MakeError('', ecTypeMismatch, '')^.Position := Pos;
  1609. end;
  1610.  
  1611. function TIFPSPascalCompiler.IsDuplicate(const s: string): Boolean;
  1612. var
  1613.   h, l: Longint;
  1614.   x: PIFPSProcedure;
  1615. begin
  1616.   h := MakeHash(s);
  1617.   if (s = 'RESULT') then
  1618.   begin
  1619.     Result := True;
  1620.     exit;
  1621.   end;
  1622.  
  1623.   for l := 0 to FAvailableTypes.Count - 1 do
  1624.   begin
  1625.     if (PIFPSType(FAvailableTypes.GetItem(l))^.NameHash = h) and
  1626.       (PIFPSType(FAvailableTypes.GetItem(l))^.Name = s) then
  1627.     begin
  1628.       Result := True;
  1629.       exit;
  1630.     end;
  1631.   end;
  1632.  
  1633.   for l := 0 to FProcs.Count - 1 do
  1634.   begin
  1635.     x := FProcs.GetItem(l);
  1636.     if x^.Internal then
  1637.     begin
  1638.       if (h = x^.NameHash) and (s = x^.Name) then
  1639.       begin
  1640.         Result := True;
  1641.         exit;
  1642.       end;
  1643.     end
  1644.     else
  1645.     begin
  1646.       if (PIFPSUsedRegProc(x)^.RP^.NameHash = h) and
  1647.         (PIFPSUsedRegProc(x)^.RP^.Name = s) then
  1648.       begin
  1649.         Result := True;
  1650.         exit;
  1651.       end;
  1652.     end;
  1653.   end;
  1654.   for l := 0 to FVars.Count - 1 do
  1655.   begin
  1656.     if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
  1657.       (PIFPSVar(FVars.GetItem(l))^.Name = s) then
  1658.     begin
  1659.       Result := True;
  1660.       exit;
  1661.     end;
  1662.   end;
  1663.   for l := 0 to FConstants.Count -1 do
  1664.   begin
  1665.     if (PIFPSConstant(FConstants.GetItem(l))^.NameHash = h) and
  1666.       (PIFPSConstant(FConstants.GetItem(l))^.Name = s) then
  1667.     begin
  1668.       Result := TRue;
  1669.       exit;
  1670.     end;
  1671.   end;
  1672.   Result := False;
  1673. end;
  1674.  
  1675.  
  1676. function TIFPSPascalCompiler.ReadType(const Name: string; FParser: TIfPascalParser): Cardinal; // Cardinal(-1) = Invalid
  1677. var
  1678.   h, l, TypeNo: Longint;
  1679.   fieldname,s: string;
  1680.   RecSubVals: TIfList;
  1681.   rvv: PIFPSRecordType;
  1682.   p, p2: PIFPSType;
  1683.   function ATNUT(C: Cardinal): Cardinal;
  1684.   var
  1685.     i: Longint;
  1686.     P: PIFPSType;
  1687.   begin
  1688.     p := FAvailableTypes.GetItem(C);
  1689.     for i := 0 to FUsedTypes.Count -1 do
  1690.     begin
  1691.       if FUsedTypes.GetItem(I) = P then
  1692.       begin
  1693.         Result := I;
  1694.         exit;
  1695.       end;
  1696.     end;
  1697.     result := Cardinal(-1);
  1698.   end;
  1699.   procedure ClearRecSubVals;
  1700.   var
  1701.     I: Longint;
  1702.     p: PIFPSRecordType;
  1703.   begin
  1704.     for I := 0 to RecSubVals.Count - 1 do
  1705.     begin
  1706.       p := RecSubVals.GetItem(I);
  1707.       Dispose(p);
  1708.     end;
  1709.     RecSubVals.Free;
  1710.   end;
  1711.  
  1712.   procedure MakeRealFieldOffsets;
  1713.   var
  1714.     I: Longint;
  1715.     O: Cardinal;
  1716.     rvv: PIFPSRecordType;
  1717.   begin
  1718.     O := 0;
  1719.     for I := 0 to RecSubVals.Count - 1 do
  1720.     begin
  1721.       rvv := RecSubVals.GetItem(I);
  1722.       rvv^.RealFieldOffset := O;
  1723.       O := O + PIFPSType(FAvailableTypes.GetItem(rvv^.FType))^.TypeSize;
  1724.     end;
  1725.     p^.TypeSize := O;
  1726.   end;
  1727.   function GetTypeCopy(i: Cardinal): Cardinal;
  1728.   begin
  1729.     if PIFPSType(FAvailableTypes.GetItem(I))^.BaseType = btTypeCopy then
  1730.       Result := GetTypeCopy(Cardinal(PIFPSType(FAvailableTypes.GetItem(I))^.Ext))
  1731.     else
  1732.       Result := i;
  1733.   end;
  1734.  
  1735.   function AddProcedure: Cardinal;
  1736.   var
  1737.     IsFunction: Boolean;
  1738.     VNames, Decl: string;
  1739.     modifier: Char;
  1740.     VCType: Cardinal;
  1741.     x: PIFPSType;
  1742.     xp: PIFPSProceduralType;
  1743.     begin
  1744.     if FParser.CurrTokenId = CSTII_Function then
  1745.       IsFunction := True
  1746.     else 
  1747.       IsFunction := False;
  1748.     Decl := '';
  1749.     FParser.Next;
  1750.     if FParser.CurrTokenId = CSTI_OpenRound then
  1751.     begin
  1752.       FParser.Next;
  1753.       if FParser.CurrTokenId <> CSTI_CloseRound then
  1754.       begin
  1755.         while True do
  1756.         begin
  1757.           if FParser.CurrTokenId = CSTII_Const then
  1758.           begin
  1759.             Modifier := '@';
  1760.             FParser.Next;
  1761.           end else
  1762.           if FParser.CurrTokenId = CSTII_Var then
  1763.           begin
  1764.             modifier := '!';
  1765.             FParser.Next;
  1766.           end
  1767.           else
  1768.             modifier := '@';
  1769.           if FParser.CurrTokenId <> CSTI_Identifier then
  1770.           begin
  1771.             Result := Cardinal(-1);
  1772.             if FParser = Self.FParser then
  1773.             MakeError('', ecIdentifierExpected, '');
  1774.             exit;
  1775.           end;
  1776.           VNames := FParser.GetToken + '|';
  1777.           FParser.Next;
  1778.           while FParser.CurrTokenId = CSTI_Comma do
  1779.           begin
  1780.             FParser.Next;
  1781.             if FParser.CurrTokenId <> CSTI_Identifier then
  1782.             begin
  1783.               Result := Cardinal(-1);
  1784.               if FParser = Self.FParser then
  1785.               MakeError('', ecIdentifierExpected, '');
  1786.               exit;
  1787.             end;
  1788.             VNames := VNames + FParser.GetToken + '|';
  1789.             FParser.Next;
  1790.           end;
  1791.           if FParser.CurrTokenId <> CSTI_Colon then
  1792.           begin
  1793.             Result := Cardinal(-1);
  1794.             if FParser = Self.FParser then
  1795.             MakeError('', ecColonExpected, '');
  1796.             exit;
  1797.           end;
  1798.           FParser.Next;
  1799.           if FParser.CurrTokenId <> CSTI_Identifier then
  1800.           begin
  1801.             Result := Cardinal(-1);
  1802.             if FParser = Self.FParser then
  1803.             MakeError('', ecIdentifierExpected, '');
  1804.             exit;
  1805.           end;
  1806.           VCType := FindType(FParser.GetToken);
  1807.           if VCType = Cardinal(-1) then
  1808.           begin
  1809.             if FParser = Self.FParser then
  1810.             MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  1811.             Result := Cardinal(-1);
  1812.             exit;
  1813.           end;
  1814.           while Pos('|', VNames) > 0 do
  1815.           begin
  1816.             Decl := Decl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1) +
  1817.               ' ' + inttostr(VCType);
  1818.             Delete(VNames, 1, Pos('|', VNames));
  1819.           end;
  1820.           FParser.Next;
  1821.           if FParser.CurrTokenId = CSTI_CloseRound then
  1822.             break;
  1823.           if FParser.CurrTokenId <> CSTI_Semicolon then
  1824.           begin
  1825.             if FParser = Self.FParser then
  1826.             MakeError('', ecSemicolonExpected, '');
  1827.             Result := Cardinal(-1);
  1828.             exit;
  1829.           end;
  1830.           FParser.Next;
  1831.         end; {while}
  1832.       end; {if}
  1833.       FParser.Next;
  1834.       end; {if}
  1835.       if IsFunction then
  1836.       begin
  1837.         if FParser.CurrTokenId <> CSTI_Colon then
  1838.         begin
  1839.           if FParser = Self.FParser then
  1840.           MakeError('', ecColonExpected, '');
  1841.           Result := Cardinal(-1);
  1842.           exit;
  1843.         end;
  1844.       FParser.Next;
  1845.       if FParser.CurrTokenId <> CSTI_Identifier then
  1846.       begin
  1847.         Result := Cardinal(-1);
  1848.         if FParser = Self.FParser then
  1849.         MakeError('', ecIdentifierExpected, '');
  1850.         exit;
  1851.       end;
  1852.       VCType := FindType(FParser.GetToken);
  1853.       if VCType = Cardinal(-1) then
  1854.       begin
  1855.         if FParser = Self.FParser then
  1856.         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  1857.         Result := Cardinal(-1);
  1858.         exit;
  1859.       end;
  1860.       FParser.Next;
  1861.     end
  1862.     else
  1863.       VCType := Cardinal(-1);
  1864.     Decl := inttostr(VCType) + Decl;
  1865.     New(x);
  1866.     x^.FExport := False;
  1867.     x^.Name := Name;
  1868.     x^.NameHash := MakeHash(x^.Name);
  1869.     x^.BaseType := btProcPtr;
  1870.     x^.DeclarePosition := FParser.CurrTokenPos;
  1871.     x^.Used := False;
  1872.     x^.TypeSize := 1;
  1873.     x^.RecordSubVals := nil;
  1874.     New(xp);
  1875.     x^.Ext := xp;
  1876.     xp^.ProcDef := Decl;
  1877.     FAvailableTypes.Add(X);
  1878.     Result := FAvailableTypes.Count -1;
  1879.   end; {AddProcedure}
  1880.  
  1881. begin
  1882.   if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
  1883.   begin
  1884.      Result := AddProcedure;
  1885.      Exit;
  1886.   end else if FParser.CurrTokenId = CSTI_OpenRound then
  1887.   begin
  1888.     FParser.Next;
  1889.     L := 0;
  1890.     New(P);
  1891.     p^.NameHash := MakeHash(Name);
  1892.     p^.Name := Name;
  1893.     p^.BaseType := btEnum;
  1894.     p^.Used := False;
  1895.     p^.TypeSize := 1;
  1896.     p^.DeclarePosition := FParser.CurrTokenPos;
  1897.     p^.RecordSubVals := nil;
  1898.     p^.FExport := False;
  1899.     p^.Ext := nil;
  1900.     FAvailableTypes.Add(p);
  1901.  
  1902.     TypeNo := FAvailableTypes.Count -1;
  1903.     repeat
  1904.       if FParser.CurrTokenId <> CSTI_Identifier then
  1905.       begin
  1906.         if FParser = Self.FParser then
  1907.         MakeError('', ecIdentifierExpected, '');
  1908.         Result := Cardinal(-1);
  1909.         exit;
  1910.       end;
  1911.       s := FParser.GetToken;
  1912.       if IsDuplicate(s) then
  1913.       begin
  1914.         if FParser = Self.FParser then
  1915.         MakeError('', ecDuplicateIdentifier, s);
  1916.         Result := Cardinal(-1);
  1917.         Exit;
  1918.       end;
  1919.       AddConstant(s, TypeNo)^.Value.Value := TransCardinalToStr(L);
  1920.       Inc(L);
  1921.       FParser.Next;
  1922.       if FParser.CurrTokenId = CSTI_CloseRound then
  1923.         Break
  1924.       else if FParser.CurrTokenId <> CSTI_Comma then
  1925.       begin
  1926.         if FParser = Self.FParser then
  1927.         MakeError('', ecCloseRoundExpected, '');
  1928.         Result := Cardinal(-1);
  1929.         Exit;
  1930.       end;
  1931.       FParser.Next;
  1932.     until False;
  1933.     FParser.Next;
  1934.     p^.Ext := Pointer(L -1);
  1935.     Result := TypeNo;
  1936.     exit;
  1937.   end else
  1938.   if FParser.CurrTokenId = CSTII_Array then
  1939.   begin
  1940.     FParser.Next;
  1941.     if FParser.CurrTokenId <> CSTII_Of then
  1942.     begin
  1943.       if FParser = Self.FParser then
  1944.       MakeError('', ecOfExpected, '');
  1945.       Result := Cardinal(-1);
  1946.       exit;
  1947.     end;
  1948.     FParser.Next;
  1949.     L := ReadType('', FParser);
  1950.     if L = -1 then
  1951.     begin
  1952.       if FParser = Self.FParser then
  1953.       MakeError('', ecUnknownIdentifier, '');
  1954.       Result := Cardinal(-1);
  1955.       exit;
  1956.     end;
  1957.     if Name = '' then
  1958.     begin
  1959.       TypeNo := ATNUT(l);
  1960.       if TypeNo <> -1 then
  1961.       begin
  1962.         for h := 0 to FUsedTypes.Count -1 do
  1963.         begin
  1964.           p := FUsedTypes.GetItem(H);
  1965.           if (p^.BaseType = btArray) and (p^.Ext = Pointer(TypeNo)) then
  1966.           begin
  1967.             for l := 0 to FAvailableTypes.Count -1 do
  1968.             begin
  1969.               if FAvailableTypes.GetItem(L) = P then
  1970.               begin
  1971.                 Result := l;
  1972.                 exit;
  1973.               end;
  1974.             end;
  1975.             if FParser = Self.FParser then
  1976.             MakeError('', ecInternalError, '0001C');
  1977.             Result := Cardinal(-1);
  1978.             Exit;
  1979.           end;
  1980.         end;
  1981.       end;
  1982.       for h := 0 to FAvailableTypes.Count -1 do
  1983.       begin
  1984.         p := FAvailableTypes.GetItem(H);
  1985.         if (p^.BaseType = btArray) and (p^.Ext = Pointer(L)) and (not p^.Used) then
  1986.         begin
  1987.           Result := H;
  1988.           Exit;
  1989.         end;
  1990.       end;
  1991.     end;
  1992.     New(p);
  1993.     p^.NameHash := MakeHash(Name);
  1994.     p^.Name := Name;
  1995.     p^.Used := False;
  1996.     p^.BaseType := btArray;
  1997.     p^.TypeSize := 1;
  1998.     p^.DeclarePosition := FParser.CurrTokenPos;
  1999.     p^.RecordSubVals := nil;
  2000.     p^.FExport := False;
  2001.     p^.Ext := Pointer(L);
  2002.     FAvailableTypes.Add(p);
  2003.     Result := Cardinal(FAvailableTypes.Count -1);
  2004.     Exit;
  2005.   end
  2006.   else if FParser.CurrTokenId = CSTII_Record then
  2007.   begin
  2008.     FParser.Next;
  2009.     RecSubVals := TIfList.Create;
  2010.     repeat
  2011.       repeat
  2012.         if FParser.CurrTokenId <> CSTI_Identifier then
  2013.         begin
  2014.           ClearRecSubVals;
  2015.           if FParser = Self.FParser then
  2016.           MakeError('', ecIdentifierExpected, '');
  2017.           Result := Cardinal(-1);
  2018.           exit;
  2019.         end;
  2020.         FieldName := FParser.GetToken;
  2021.         s := S+FieldName+'|';
  2022.         FParser.Next;
  2023.         TypeNo := MakeHash(S);
  2024.         for l := 0 to RecSubVals.Count - 1 do
  2025.         begin
  2026.           if (PIFPSRecordType(RecSubVals.GetItem(l))^.FieldNameHash = TypeNo) and
  2027.             (PIFPSRecordType(RecSubVals.GetItem(l))^.FieldName = s) then
  2028.           begin
  2029.             if FParser = Self.FParser then
  2030.               MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
  2031.             ClearRecSubVals;
  2032.             Result := Cardinal(-1);
  2033.             exit;
  2034.           end;
  2035.         end;
  2036.         if FParser.CurrTokenID = CSTI_Colon then Break else
  2037.         if FParser.CurrTokenID <> CSTI_Comma then
  2038.         begin
  2039.           if FParser = Self.FParser then
  2040.             MakeError('', ecColonExpected, '');
  2041.           ClearRecSubVals;
  2042.           Result := Cardinal(-1);
  2043.           exit;
  2044.         end;
  2045.         FParser.Next;
  2046.       until False;
  2047.       FParser.Next;
  2048.       l := ReadType('', FParser);
  2049.       if L = -1 then
  2050.       begin
  2051.         ClearRecSubVals;
  2052.         Result := Cardinal(-1);
  2053.         exit;
  2054.       end;
  2055.       P := FAvailableTypes.GetItem(L);
  2056.       if p^.BaseType = BtTypeCopy then
  2057.       begin
  2058.         L := 0;
  2059.         for TypeNo := 0 to FAvailableTypes.Count -1 do
  2060.         begin
  2061.           if FAvailableTypes.GetItem(TypeNo) = p^.Ext then
  2062.           begin
  2063.             L := TypeNo;
  2064.             Break;
  2065.           end;
  2066.         end;
  2067.       end;
  2068.       if FParser.CurrTokenId <> CSTI_Semicolon then
  2069.       begin
  2070.         ClearRecSubVals;
  2071.         if FParser = Self.FParser then
  2072.         MakeError('', ecSemicolonExpected, '');
  2073.         Result := Cardinal(-1);
  2074.         exit;
  2075.       end; {if}
  2076.       FParser.Next;
  2077.       while Pos('|', s) > 0 do
  2078.       begin
  2079.         fieldname := copy(s, 1, pos('|', s)-1);
  2080.         Delete(s, 1, length(FieldName)+1);
  2081.         New(rvv);
  2082.         rvv^.FieldName := fieldname;
  2083.         rvv^.FieldNameHash := MakeHash(fieldname);
  2084.         rvv^.FType := l;
  2085.         RecSubVals.Add(rvv);
  2086.       end;
  2087.     until FParser.CurrTokenId = CSTII_End;
  2088.     FParser.Next; // skip CSTII_End
  2089.     New(p);
  2090.     p^.NameHash := MakeHash(Name);
  2091.     p^.Name := Name;
  2092.     p^.BaseType := btRecord;
  2093.     p^.DeclarePosition := FParser.CurrTokenPos;
  2094.     p^.RecordSubVals := RecSubVals;
  2095.     p^.Used := False;
  2096.     p^.FExport := False;
  2097.     p^.Ext := nil;
  2098.     FAvailableTypes.Add(p);
  2099.     Result := FAvailableTypes.Count -1;
  2100.     MakeRealFieldOffsets;
  2101.     Exit;
  2102.   end else if FParser.CurrTokenId = CSTI_Identifier then
  2103.   begin
  2104.     s := FParser.GetToken;
  2105.     h := MakeHash(s);
  2106.     p2 := nil;
  2107.     for l := 0 to FAvailableTypes.Count - 1 do
  2108.     begin
  2109.       if (PIFPSType(FAvailableTypes.GetItem(l))^.NameHash = h) and
  2110.         (PIFPSType(FAvailableTypes.GetItem(l))^.Name = s) then
  2111.       begin
  2112.         FParser.Next;
  2113.         p2 := FAvailableTypes.GetItem(l);
  2114.         if p2^.BaseType = BtTypeCopy then
  2115.         begin
  2116.           P2 := p2^.Ext;
  2117.         end;
  2118.         Break;
  2119.       end;
  2120.     end;
  2121.     if p2 = nil then
  2122.     begin
  2123.       Result := Cardinal(-1);
  2124.       if FParser = Self.FParser then
  2125.       MakeError('', ecUnknownType, FParser.OriginalToken);
  2126.       exit;
  2127.     end;
  2128.     if Name <> '' then
  2129.     begin
  2130.       New(p);
  2131.       p^.NameHash := MakeHash(Name);
  2132.       p^.Name := Name;
  2133.       p^.BaseType := BtTypeCopy;
  2134.       p^.TypeSize := 0;
  2135.       p^.DeclarePosition := FParser.CurrTokenPos;
  2136.       p^.RecordSubVals := nil;
  2137.       p^.FExport := FAlse;
  2138.       p^.Used := False;
  2139.       p^.Ext := p2;
  2140.       FAvailableTypes.Add(p);
  2141.       Result := FAvailableTypes.Count -1;
  2142.       Exit;
  2143.     end else begin
  2144.       for h := 0 to FAvailableTypes.Count -1 do
  2145.       begin
  2146.         if FAvailableTypes.GetItem(h) = P2 then
  2147.         begin
  2148.           Result := h;
  2149.           Exit;
  2150.         end;
  2151.       end;
  2152.     end;
  2153.   end;
  2154.   Result := Cardinal(-1);
  2155.   if FParser = Self.FParser then
  2156.   MakeError('', ecIdentifierExpected, '');
  2157.   Exit;
  2158. end;
  2159.  
  2160.  
  2161. function TIFPSPascalCompiler.DoVarBlock(proc: PIFPSProcedure): Boolean;
  2162. var
  2163.   VarName, s: string;
  2164.   VarType: Cardinal;
  2165.   VarNo: Cardinal;
  2166.   v: PIFPSVar;
  2167.   vp: PIFPSProcVar;
  2168.  
  2169.   function VarIsDuplicate(const s: string): Boolean;
  2170.   var
  2171.     h, l: Longint;
  2172.     x: PIFPSProcedure;
  2173.     v: string;
  2174.   begin
  2175.     h := MakeHash(s);
  2176.     if (s = 'RESULT') then
  2177.     begin
  2178.       Result := True;
  2179.       exit;
  2180.     end;
  2181.  
  2182.     for l := 0 to FAvailableTypes.Count - 1 do
  2183.     begin
  2184.       if (PIFPSType(FAvailableTypes.GetItem(l))^.NameHash = h) and
  2185.         (PIFPSType(FAvailableTypes.GetItem(l))^.Name = s) then
  2186.       begin
  2187.         Result := True;
  2188.         exit;
  2189.       end;
  2190.     end;
  2191.  
  2192.     for l := 0 to FProcs.Count - 1 do
  2193.     begin
  2194.       x := FProcs.GetItem(l);
  2195.       if x^.Internal then
  2196.       begin
  2197.         if (h = x^.NameHash) and (s = x^.Name) then
  2198.         begin
  2199.           Result := True;
  2200.           exit;
  2201.         end;
  2202.       end
  2203.       else
  2204.       begin
  2205.         if (PIFPSUsedRegProc(x)^.RP^.NameHash = h) and
  2206.           (PIFPSUsedRegProc(x)^.RP^.Name = s) then
  2207.         begin
  2208.           Result := True;
  2209.           exit;
  2210.         end;
  2211.       end;
  2212.     end;
  2213.     if proc <> nil then
  2214.     begin
  2215.       for l := 0 to proc^.ProcVars.Count - 1 do
  2216.       begin
  2217.         if (PIFPSProcVar(proc^.ProcVars.GetItem(l))^.NameHash = h) and
  2218.           (PIFPSVar(proc^.ProcVars.GetItem(l))^.Name = s) then
  2219.         begin
  2220.           Result := True;
  2221.           exit;
  2222.         end;
  2223.       end;
  2224.     end
  2225.     else
  2226.     begin
  2227.       for l := 0 to FVars.Count - 1 do
  2228.       begin
  2229.         if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
  2230.           (PIFPSVar(FVars.GetItem(l))^.Name = s) then
  2231.         begin
  2232.           Result := True;
  2233.           exit;
  2234.         end;
  2235.       end;
  2236.     end;
  2237.     v := VarName;
  2238.     while Pos('|', v) > 0 do
  2239.     begin
  2240.       if copy(v, 1, Pos('|', v) - 1) = s then
  2241.       begin
  2242.         Result := True;
  2243.         exit;
  2244.       end;
  2245.       Delete(v, 1, Pos('|', v));
  2246.     end;
  2247.     for l := 0 to FConstants.Count -1 do
  2248.     begin
  2249.       if (PIFPSConstant(FConstants.GetItem(l))^.NameHash = h) and
  2250.         (PIFPSConstant(FConstants.GetItem(l))^.Name = s) then
  2251.       begin
  2252.         Result := TRue;
  2253.         exit;
  2254.       end;
  2255.     end;
  2256.     Result := False;
  2257.   end;
  2258.  
  2259. begin
  2260.   Result := False;
  2261.   FParser.Next; // skip CSTII_Var
  2262.   if FParser.CurrTokenId <> CSTI_Identifier then
  2263.   begin
  2264.     MakeError('', ecIdentifierExpected, '');
  2265.     exit;
  2266.   end;
  2267.   repeat
  2268.     if VarIsDuplicate(FParser.GetToken) then
  2269.     begin
  2270.       MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
  2271.       exit;
  2272.     end;
  2273.     VarName := FParser.GetToken + '|';
  2274.     Varno := 0;
  2275.     if @FOnUseVariable <> nil then
  2276.     begin
  2277.       if Proc <> nil then
  2278.         FOnUseVariable(Self, ivtVariable, Proc^.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos)
  2279.       else
  2280.         FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, Cardinal(-1), FParser.CurrTokenPos)
  2281.     end;
  2282.     FParser.Next;
  2283.     while FParser.CurrTokenId = CSTI_Comma do
  2284.     begin
  2285.       FParser.Next;
  2286.       if FParser.CurrTokenId <> CSTI_Identifier then
  2287.       begin
  2288.         MakeError('', ecIdentifierExpected, '');
  2289.       end;
  2290.       if VarIsDuplicate(FParser.GetToken) then
  2291.       begin
  2292.         MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
  2293.         exit;
  2294.       end;
  2295.       VarName := VarName + FParser.GetToken + '|';
  2296.       Inc(varno);
  2297.       if @FOnUseVariable <> nil then
  2298.       begin
  2299.         if Proc <> nil then
  2300.           FOnUseVariable(Self, ivtVariable, Proc^.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos)
  2301.         else
  2302.           FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, Cardinal(-1), FParser.CurrTokenPos)
  2303.       end;
  2304.       FParser.Next;
  2305.     end;
  2306.     if FParser.CurrTokenId <> CSTI_Colon then
  2307.     begin
  2308.       MakeError('', ecColonExpected, '');
  2309.       exit;
  2310.     end;
  2311.     FParser.Next;
  2312.     VarType := at2ut(ReadType('', FParser));
  2313.     if VarType = Cardinal(-1) then
  2314.     begin
  2315.       exit;
  2316.     end;
  2317.     while Pos('|', VarName) > 0 do
  2318.     begin
  2319.       s := copy(VarName, 1, Pos('|', VarName) - 1);
  2320.       Delete(VarName, 1, Pos('|', VarName));
  2321.       if proc = nil then
  2322.       begin
  2323.         New(v);
  2324.         v^.Used := False;
  2325.         v^.Name := s;
  2326.         v^.NameHash := MakeHash(v^.Name);
  2327.         v^.DeclarePosition := FParser.CurrTokenPos;
  2328.         v^.FType := VarType;
  2329.         FVars.Add(v);
  2330.       end
  2331.       else
  2332.       begin
  2333.         New(vp);
  2334.         vp^.Used := False;
  2335.         vp^.VarName := s;
  2336.         vp^.NameHash := MakeHash(vp^.VarName);
  2337.         vp^.VarType := VarType;
  2338.         vp^.CurrentlyUsed := False;
  2339.         vp^.Used := False;
  2340.         vp^.DeclarePosition := FParser.CurrTokenPos;
  2341.         proc.ProcVars.Add(vp);
  2342.       end;
  2343.     end;
  2344.     if FParser.CurrTokenId <> CSTI_Semicolon then
  2345.     begin
  2346.       MakeError('', ecSemicolonExpected, '');
  2347.       exit;
  2348.     end;
  2349.     FParser.Next;
  2350.   until FParser.CurrTokenId <> CSTI_Identifier;
  2351.   Result := True;
  2352. end;
  2353.  
  2354. function TIFPSPascalCompiler.NewProc(const Name: string): PIFPSProcedure;
  2355. begin
  2356.   New(Result);
  2357.   Result^.Forwarded := False;
  2358.   Result^.FExport := 0;
  2359.   Result^.Data := '';
  2360.   Result^.Decl := '-1';
  2361.   Result^.Name := Name;
  2362.   Result^.NameHash := MakeHash(Result^.Name);
  2363.   Result^.Used := False;
  2364.   Result^.Internal := True;
  2365.   Result^.ProcVars := TIfList.Create;
  2366.   Result^.ResUsed := False;
  2367.   Result^.DeclarePosition := FParser.CurrTokenPos;
  2368.   Result^.FLabels := TIfStringList.Create;
  2369.   Result^.FGotos := TIfStringList.Create;
  2370.   FProcs.Add(Result);
  2371. end;
  2372.  
  2373. function TIFPSPascalCompiler.ProcessLabel(Proc: PIFPSProcedure): Boolean;
  2374. var
  2375.   CurrLabel: string;
  2376.   function IsProcDuplic(const s: string): Boolean;
  2377.   var
  2378.     i: Longint;
  2379.     h: Longint;
  2380.     u: string;
  2381.   begin
  2382.     h := MakeHash(s);
  2383.     if s = 'RESULT' then
  2384.       Result := True
  2385.     else if Proc^.Name = s then
  2386.       Result := True
  2387.     else if IsDuplicate(s) then
  2388.       Result := True
  2389.     else
  2390.     begin
  2391.       u := Proc^.Decl;
  2392.       while Length(u) > 0 do
  2393.       begin
  2394.         if D1(GRFW(u)) = s then
  2395.         begin
  2396.           Result := True;
  2397.           exit;
  2398.         end;
  2399.         GRFW(u);
  2400.       end;
  2401.       for i := 0 to Proc^.ProcVars.Count -1 do
  2402.       begin
  2403.         if (PIFPSProcVar(Proc^.ProcVars.GetItem(I))^.NameHash = h) and (PIFPSProcVar(Proc^.ProcVars.GetItem(I))^.VarName = s) then
  2404.         begin
  2405.           Result := True;
  2406.           exit;
  2407.         end;
  2408.       end;
  2409.       for i := 0 to Proc^.FLabels.Count -1 do
  2410.       begin
  2411.         u := Proc^.FLabels.GetItem(i);
  2412.         delete(u, 1, 4);
  2413.         if Longint((@u[1])^) = h then
  2414.         begin
  2415.           delete(u, 1, 4);
  2416.           if u = s then
  2417.           begin
  2418.             Result := True;
  2419.             exit;
  2420.           end;
  2421.         end;
  2422.       end;
  2423.       Result := False;
  2424.     end;
  2425.   end;
  2426. begin
  2427.   FParser.Next;
  2428.   while true do
  2429.   begin
  2430.     if FParser.CurrTokenId <> CSTI_Identifier then
  2431.     begin
  2432.       MakeError('', ecIdentifierExpected, '');
  2433.       Result := False;
  2434.       exit;
  2435.     end;
  2436.     CurrLabel := FParser.GetToken;
  2437.     if IsDuplicate(CurrLabel) or IsProcDuplic(CurrLabel) then
  2438.     begin
  2439.       MakeError('', ecDuplicateIdentifier, '');
  2440.       Result := False;
  2441.       exit;
  2442.     end;
  2443.     FParser.Next;
  2444.     Proc^.FLabels.Add(#$FF#$FF#$FF#$FF+mi2s(MakeHash(CurrLabel))+CurrLabel);
  2445.     if FParser.CurrTokenId = CSTI_Semicolon then
  2446.     begin
  2447.       FParser.Next;
  2448.       Break;
  2449.     end;
  2450.     if FParser.CurrTokenId <> CSTI_Comma then
  2451.     begin
  2452.       MakeError('', ecCommaExpected, '');
  2453.       Result := False;
  2454.       exit;
  2455.     end;
  2456.     FParser.Next;
  2457.   end;
  2458.   Result := True;
  2459. end;
  2460.  
  2461. procedure TIFPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: PIFPSProcedure);
  2462. begin
  2463.   WriteDebugData(#4 + mi2s(ProcNo) + mi2s(Length(Proc^.Data)) + mi2s(FParser.CurrTokenPos));
  2464. end;
  2465. procedure TIFPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: PIFPSProcedure);
  2466. var
  2467.   I: Longint;
  2468.   s, d: string;
  2469. begin
  2470.   s := #2 + mi2s(ProcNo);
  2471.   d := proc^.Decl;
  2472.   if GRFW(d) <> '-1' then
  2473.   begin
  2474.     s := s + 'RESULT'+#1;
  2475.   end;
  2476.   while Length(d) > 0 do
  2477.   begin
  2478.     s := s + D1(GRFW(d)) + #1;
  2479.     GRFW(d);
  2480.   end;
  2481.   s := s + #0#3 + mi2s(ProcNo);
  2482.   for I := 0 to proc^.ProcVars.Count - 1 do
  2483.   begin
  2484.     s := s + PIFPSProcVar(proc^.ProcVars.GetItem(I))^.VarName + #1;
  2485.   end;
  2486.   s := s + #0;
  2487.   WriteDebugData(s);
  2488. end;
  2489.  
  2490.  
  2491.  
  2492. function TIFPSPascalCompiler.ProcessFunction: Boolean;
  2493. var
  2494.   FunctionType: TFuncType;
  2495.   FunctionName: string;
  2496.   FunctionParamNames: string;
  2497.   FunctionTempType: Cardinal;
  2498.   ParamNo: Cardinal;
  2499.   FunctionDecl: string;
  2500.   modifier: Char;
  2501.   F2, Func: PIFPSProcedure;
  2502.   EPos: Cardinal;
  2503.   pp: PIFPSRegProc;
  2504.   pp2: PIFPSUsedRegProc;
  2505.   FuncNo, I: Longint;
  2506.   procedure CheckVars(Func: PIFPSProcedure);
  2507.   var
  2508.     i: Integer;
  2509.     p: PIFPSProcVar;
  2510.   begin
  2511.     for i := 0 to Func^.ProcVars.Count -1 do
  2512.     begin
  2513.       p := Func^.ProcVars.GetItem(I);
  2514.       if not p^.Used then
  2515.       begin
  2516.         MakeHint('', ehVariableNotUsed, p^.VarName)^.Position := p^.DeclarePosition;
  2517.       end;
  2518.     end;
  2519.     if (not Func^.ResUsed) and (Fw(Func^.Decl) <> '-1') then
  2520.     begin
  2521.       MakeHint('', ehVariableNotUsed, 'RESULT')^.Position := Func^.DeclarePosition;
  2522.     end;
  2523.   end;
  2524.  
  2525.   function IsDuplic(const s: string): Boolean;
  2526.   var
  2527.     i: Longint;
  2528.     u: string;
  2529.   begin
  2530.     if s = 'RESULT' then
  2531.       Result := True
  2532.     else if FunctionName = s then
  2533.       Result := True
  2534.     else if IsDuplicate(s) then
  2535.       Result := True
  2536.     else
  2537.     begin
  2538.       u := FunctionDecl;
  2539.       while Length(u) > 0 do
  2540.       begin
  2541.         if D1(GRFW(u)) = s then
  2542.         begin
  2543.           Result := True;
  2544.           exit;
  2545.         end;
  2546.         GRFW(u);
  2547.       end;
  2548.       u := FunctionParamNames;
  2549.       while Pos('|', u) > 0 do
  2550.       begin
  2551.         if copy(u, 1, Pos('|', u) - 1) = s then
  2552.         begin
  2553.           Result := True;
  2554.           exit;
  2555.         end;
  2556.         Delete(u, 1, Pos('|', u));
  2557.       end;
  2558.       if Func = nil then
  2559.       begin
  2560.         result := False;
  2561.         exit;
  2562.       end;
  2563.       for i := 0 to Func^.ProcVars.Count -1 do
  2564.       begin
  2565.         if s = PIFPSProcVar(Func^.ProcVars.GetItem(I))^.VarName then
  2566.         begin
  2567.           Result := True;
  2568.           exit;
  2569.         end;
  2570.       end;
  2571.       for i := 0 to Func^.FLabels.Count -1 do
  2572.       begin
  2573.         u := Func^.FLabels.GetItem(i);
  2574.         delete(u, 1, 4);
  2575.         if u = s then
  2576.         begin
  2577.           Result := True;
  2578.           exit;
  2579.         end;
  2580.       end;
  2581.       Result := False;
  2582.     end;
  2583.   end;
  2584.   procedure WriteProcVars(t: TIfList);
  2585.   var
  2586.     l: Longint;
  2587.     v: PIFPSProcVar;
  2588.   begin
  2589.     for l := 0 to t.Count - 1 do
  2590.     begin
  2591.       v := t.GetItem(l);
  2592.       Func^.Data := Func^.Data  + chr(cm_pt)+ mi2s(v^.VarType);
  2593.     end;
  2594.   end;
  2595.  
  2596. begin
  2597.   if FParser.CurrTokenId = CSTII_Procedure then
  2598.     FunctionType := ftProc
  2599.   else
  2600.     FunctionType := ftFunc;
  2601.   Func := nil;
  2602.   FParser.Next;
  2603.   Result := False;
  2604.   if FParser.CurrTokenId <> CSTI_Identifier then
  2605.   begin
  2606.     MakeError('', ecIdentifierExpected, '');
  2607.     exit;
  2608.   end;
  2609.   EPos := FParser.CurrTokenPos;
  2610.   FunctionName := FParser.GetToken;
  2611.   FuncNo := -1;
  2612.   for i := 0 to FProcs.Count -1 do
  2613.   begin
  2614.     f2 := FProcs.GetItem(i);
  2615.     if (f2^.Internal) and (f2^.Name = FunctionName) and (f2^.Forwarded) then
  2616.     begin
  2617.       Func := FProcs.GetItem(i);
  2618.       FuncNo := i;
  2619.       Break;
  2620.     end;
  2621.   end;
  2622.   if (Func = nil) and IsDuplicate(FunctionName) then
  2623.   begin
  2624.     MakeError('', ecDuplicateIdentifier, FunctionName);
  2625.     exit;
  2626.   end;
  2627.   FParser.Next;
  2628.   FunctionDecl := '';
  2629.   if FParser.CurrTokenId = CSTI_OpenRound then
  2630.   begin
  2631.     FParser.Next;
  2632.     if FParser.CurrTokenId = CSTI_CloseRound then
  2633.     begin
  2634.       FParser.Next;
  2635.     end
  2636.     else
  2637.     begin
  2638.       if FunctionType = ftFunc then
  2639.         ParamNo := 1
  2640.       else
  2641.         ParamNo := 0;
  2642.       while True do
  2643.       begin
  2644.         if FParser.CurrTokenId = CSTII_Var then
  2645.         begin
  2646.           modifier := '!';
  2647.           FParser.Next;
  2648.         end
  2649.         else
  2650.           modifier := '@';
  2651.         if FParser.CurrTokenId <> CSTI_Identifier then
  2652.         begin
  2653.           MakeError('', ecIdentifierExpected, '');
  2654.           exit;
  2655.         end;
  2656.         if IsDuplic(FParser.GetToken) then
  2657.         begin
  2658.           MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
  2659.           exit;
  2660.         end;
  2661.         FunctionParamNames := FParser.GetToken + '|';
  2662.         if @FOnUseVariable <> nil then
  2663.         begin
  2664.           FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos);
  2665.         end;
  2666.         inc(ParamNo);
  2667.         FParser.Next;
  2668.         while FParser.CurrTokenId = CSTI_Comma do
  2669.         begin
  2670.           FParser.Next;
  2671.           if FParser.CurrTokenId <> CSTI_Identifier then
  2672.           begin
  2673.             MakeError('', ecIdentifierExpected, '');
  2674.             exit;
  2675.           end;
  2676.           if IsDuplic(FParser.GetToken) then
  2677.           begin
  2678.             MakeError('', ecDuplicateIdentifier, '');
  2679.             exit;
  2680.           end;
  2681.           if @FOnUseVariable <> nil then
  2682.           begin
  2683.             FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos);
  2684.           end;
  2685.           inc(ParamNo);
  2686.           FunctionParamNames := FunctionParamNames + FParser.GetToken +
  2687.             '|';
  2688.           FParser.Next;
  2689.         end;
  2690.         if FParser.CurrTokenId <> CSTI_Colon then
  2691.         begin
  2692.           MakeError('', ecColonExpected, '');
  2693.           exit;
  2694.         end;
  2695.         FParser.Next;
  2696.         FunctionTempType := at2ut(ReadType('', FParser));
  2697.         if FunctionTempType = Cardinal(-1) then
  2698.         begin
  2699.           exit;
  2700.         end;
  2701.         while Pos('|', FunctionParamNames) > 0 do
  2702.         begin
  2703.           FunctionDecl := FunctionDecl + ' ' + modifier +
  2704.             copy(FunctionParamNames, 1, Pos('|', FunctionParamNames) - 1)
  2705.             + ' '
  2706.             + inttostr(Longint(FunctionTempType));
  2707.           Delete(FunctionParamNames, 1, Pos('|', FunctionParamNames));
  2708.         end;
  2709.         if FParser.CurrTokenId = CSTI_CloseRound then
  2710.           break;
  2711.         if FParser.CurrTokenId <> CSTI_Semicolon then
  2712.         begin
  2713.           MakeError('', ecSemicolonExpected, '');
  2714.           exit;
  2715.         end;
  2716.         FParser.Next;
  2717.       end;
  2718.       FParser.Next;
  2719.     end;
  2720.   end;
  2721.   if FunctionType = ftFunc then
  2722.   begin
  2723.     if FParser.CurrTokenId <> CSTI_Colon then
  2724.     begin
  2725.       MakeError('', ecColonExpected, '');
  2726.       exit;
  2727.     end;
  2728.     FParser.Next;
  2729.     FunctionTempType := at2ut(ReadType('', FParser));
  2730.     if FunctionTempType = Cardinal(-1) then
  2731.       exit;
  2732.     FunctionDecl := inttostr(Longint(FunctionTempType)) + FunctionDecl;
  2733.   end
  2734.   else
  2735.     FunctionDecl := '-1' + FunctionDecl;
  2736.   if FParser.CurrTokenId <> CSTI_Semicolon then
  2737.   begin
  2738.     MakeError('', ecSemicolonExpected, '');
  2739.     exit;
  2740.   end;
  2741.   FParser.Next;
  2742.   if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
  2743.   begin
  2744.     FParser.Next;
  2745.     if FParser.CurrTokenID <> CSTI_String then
  2746.     begin
  2747.       MakeError('', ecStringExpected, '');
  2748.       exit;
  2749.     end;
  2750.     FunctionParamNames := FParser.GetToken;
  2751.     FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
  2752.     FParser.Next;
  2753.     if FParser.CurrTokenID <> CSTI_Semicolon then
  2754.     begin
  2755.       MakeError('', ecSemicolonExpected, '');
  2756.       exit;
  2757.     end;
  2758.     FParser.Next;
  2759.     pp := FOnExternalProc(Self, FunctionName, FunctionDecl, FunctionParamNames);
  2760.     if pp = nil then
  2761.     begin
  2762.       MakeError('', ecCustomError, '');
  2763.       exit;
  2764.     end;
  2765.     new(pp2);
  2766.     pp2^.Internal := false;
  2767.     pp2^.RP := pp;
  2768.     FProcs.Add(pp2);
  2769.     FRegProcs.Add(pp);
  2770.     Result := True;
  2771.     Exit;
  2772.   end else if (Func = nil) and (FParser.CurrTokenID = CSTII_Forward) then
  2773.   begin
  2774.     FParser.Next;
  2775.     if FParser.CurrTokenID  <> CSTI_Semicolon then
  2776.     begin
  2777.       MakeError('', ecSemicolonExpected, '');
  2778.       Exit;
  2779.     end;
  2780.     FParser.Next;
  2781.     Func := NewProc(FunctionName);
  2782.     Func^.Forwarded := True;
  2783.     Func^.DeclarePosition := EPos;
  2784.     Result := True;
  2785.     exit;
  2786.   end;
  2787.   if (Func = nil) then
  2788.   begin
  2789.     Func := NewProc(FunctionName);
  2790.     Func^.Decl := FunctionDecl;
  2791.     Func^.DeclarePosition := EPos;
  2792.     FuncNo := FProcs.Count -1;
  2793.   end else begin
  2794.     Func^.Forwarded := False;
  2795.   end;
  2796.   if FParser.CurrTokenID = CSTII_Export then
  2797.   begin
  2798.     FParser.Next;
  2799.     if FParser.CurrTokenID <> CSTI_Semicolon then
  2800.     begin
  2801.       MakeError('', ecSemicolonExpected, '');
  2802.       exit;
  2803.     end;
  2804.     FParser.Next;
  2805.     Func^.FExport := 1;
  2806.   end;
  2807.   while FParser.CurrTokenId <> CSTII_Begin do
  2808.   begin
  2809.     if FParser.CurrTokenId = CSTII_Var then
  2810.     begin
  2811.       if not DoVarBlock(Func) then
  2812.         exit;
  2813.     end else if FParser.CurrTokenId = CSTII_Label then
  2814.     begin
  2815.       if not ProcessLabel(Func) then
  2816.         Exit;
  2817.     end else
  2818.     begin
  2819.       MakeError('', ecBeginExpected, '');
  2820.       exit;
  2821.     end;
  2822.   end;
  2823.   Debug_WriteParams(FuncNo, Func);
  2824.   WriteProcVars(Func^.ProcVars);
  2825.   if not ProcessSub(tProcBegin, FuncNo, Func) then
  2826.   begin
  2827.     exit;
  2828.   end;
  2829.   CheckVars(Func);
  2830.   ProcessLabelForwards(Func);
  2831.   Result := True;
  2832. end;
  2833.  
  2834. function TIFPSPascalCompiler.DoTypeBlock(FParser: TIfPascalParser): Boolean;
  2835. var
  2836.   VName: string;
  2837. begin
  2838.   Result := False;
  2839.   FParser.Next;
  2840.   if FParser.CurrTokenId <> CSTI_Identifier then
  2841.   begin
  2842.     MakeError('', ecIdentifierExpected, '');
  2843.     exit;
  2844.   end;
  2845.   repeat
  2846.     VName := FParser.GetToken;
  2847.     if IsDuplicate(VName) then
  2848.     begin
  2849.       MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
  2850.       exit;
  2851.     end;
  2852.  
  2853.     FParser.Next;
  2854.     if FParser.CurrTokenId <> CSTI_Equal then
  2855.     begin
  2856.       MakeError('', ecIsExpected, '');
  2857.       exit;
  2858.     end;
  2859.     FParser.Next;
  2860.     if ReadType(VName, FParser) = Cardinal(-1) then
  2861.     begin
  2862.       Exit;
  2863.     end;
  2864.     if FParser.CurrTokenID <> CSTI_Semicolon then
  2865.     begin
  2866.       MakeError('', ecSemicolonExpected, '');
  2867.       Exit;
  2868.     end;
  2869.     FParser.Next;
  2870.   until FParser.CurrTokenId <> CSTI_Identifier;
  2871.   Result := True;
  2872. end;
  2873.  
  2874.  
  2875. function TIFPSPascalCompiler.ProcessSub(FType: TSubOptType; ProcNo: Cardinal; proc: PIFPSProcedure): Boolean;
  2876.  
  2877.  
  2878.   procedure Debug_WriteLine;
  2879.   var
  2880.     b: Boolean;
  2881.   begin
  2882.     if @FOnWriteLine <> nil then begin
  2883.       b := FOnWriteLine(Self, FParser.CurrTokenPos);
  2884.     end else
  2885.       b := true;
  2886.     if b then Debug_SavePosition(ProcNo, proc);
  2887.   end;
  2888.  
  2889.   procedure WriteCommand(b: Byte);
  2890.   begin
  2891.     proc^.Data := proc^.Data + Char(b);
  2892.   end;
  2893.  
  2894.   procedure WriteByte(b: Byte);
  2895.   begin
  2896.     proc^.Data := proc^.Data + Char(b);
  2897.   end;
  2898.  
  2899.   procedure WriteData(const Data; Len: Longint);
  2900.   begin
  2901.     SetLength(proc^.Data, Length(proc^.Data) + Len);
  2902.     Move(Data, proc^.Data[Length(proc^.Data) - Len + 1], Len);
  2903.   end;
  2904.  
  2905.   function ReadReal(const s: string): PIfRVariant;
  2906.   var
  2907.     C: Integer;
  2908.   begin
  2909.     New(Result);
  2910.     Result^.FType := GetType(btExtended);
  2911.     SetLength(Result^.Value, SizeOf(TbtExtended));
  2912.     Val(s, TbtExtended((@Result^.Value[1])^), C);
  2913.   end;
  2914.  
  2915.   function ReadString: PIfRVariant;
  2916.  
  2917.     function ParseString: string;
  2918.     var
  2919.       temp3: string;
  2920.  
  2921.       function ChrToStr(s: string): Char;
  2922.       begin
  2923.         Delete(s, 1, 1); {First char : #}
  2924.         ChrToStr := Chr(StrToInt(s));
  2925.       end;
  2926.  
  2927.       function PString(s: string): string;
  2928.       begin
  2929.         s := copy(s, 2, Length(s) - 2);
  2930.         PString := s;
  2931.       end;
  2932.     begin
  2933.       temp3 := '';
  2934.       while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId =
  2935.         CSTI_Char) do
  2936.       begin
  2937.         if FParser.CurrTokenId = CSTI_String then
  2938.         begin
  2939.           temp3 := temp3 + PString(FParser.GetToken);
  2940.           FParser.Next;
  2941.           if FParser.CurrTokenId = CSTI_String then
  2942.             temp3 := temp3 + #39;
  2943.         end {if}
  2944.         else
  2945.         begin
  2946.           temp3 := temp3 + ChrToStr(FParser.GetToken);
  2947.           FParser.Next;
  2948.         end; {else if}
  2949.       end; {while}
  2950.       ParseString := temp3;
  2951.     end;
  2952.  
  2953.   begin
  2954.     New(Result);
  2955.     Result^.FType := GetType(btString);
  2956.     Result^.Value := ParseString;
  2957.   end;
  2958.  
  2959.   function ReadInteger(const s: string): PIfRVariant;
  2960.   var
  2961.     C: Integer;
  2962.     {$IFNDEF NOINT64}e: Int64;{$ENDIF}
  2963.   begin
  2964.     {$IFNDEF NOINT64}
  2965.     e := StrToInt64Def(s, -1);
  2966.     if (e and $FFFFFFFF) = E then
  2967.     begin
  2968.       New(Result);
  2969.       Result^.FType := GetType(btS32);
  2970.       SetLength(Result^.Value, SizeOf(TbtS32));
  2971.       Val(s, TbtS32((@Result^.Value[1])^), C);
  2972.       if TbtS32((@Result^.Value[1])^) < 0 then
  2973.       begin
  2974.         Val(s, TbtU32((@Result^.Value[1])^), C);
  2975.       end;
  2976.     end else begin
  2977.       New(Result);
  2978.       Result^.FType := GetType(btS64);
  2979.       SetLength(Result^.Value, SizeOf(TbtS64));
  2980.       tbts64((@Result^.Value[1])^) := e;
  2981.     end;
  2982.     {$ELSE}
  2983.     New(Result);
  2984.     Result^.FType := GetType(btS32);
  2985.     SetLength(Result^.Value, SizeOf(TbtS32));
  2986.     Val(s, TbtS32((@Result^.Value[1])^), C);
  2987.     if TbtS32((@Result^.Value[1])^) < 0 then
  2988.     begin
  2989.       Val(s, TbtU32((@Result^.Value[1])^), C);
  2990.     end;
  2991.     {$ENDIF}
  2992.   end;
  2993.  
  2994.   procedure WriteLong(l: Cardinal);
  2995.   begin
  2996.     WriteData(l, 4);
  2997.   end;
  2998.  
  2999.   procedure WriteVariant(p: PIfRVariant);
  3000.   var
  3001.     px: PIFPSType;
  3002.   begin
  3003.     WriteLong(p^.FType);
  3004.     px := FUsedTypes.GetItem(p^.FType);
  3005.     if px^.BaseType = btString then
  3006.     begin
  3007.       WriteLong(Length(p^.Value));
  3008.       WriteData(p^.Value[1], Length(p^.Value));
  3009.     end
  3010.     else if px^.BaseType = btenum then
  3011.     begin
  3012.       if Longint(px^.Ext) <=256 then
  3013.         WriteData(p^.Value[1], 1)
  3014.       else if Longint(px^.Ext) <=65536 then
  3015.         WriteData(p^.Value[1], 2)
  3016.       else
  3017.         WriteData(p^.Value[1], 4);
  3018.     end else
  3019.     begin
  3020.       WriteData(p^.Value[1], Length(p^.Value));
  3021.     end;
  3022.   end;
  3023.  
  3024.   function GetParamType(I: Longint): Cardinal;
  3025.   var
  3026.     u, n: string;
  3027.   begin
  3028.     u := proc^.Decl;
  3029.     Inc(I);
  3030.     n := GRFW(u);
  3031.     if (I = 0) and (n <> '-1') then
  3032.     begin
  3033.       Result := StrToIntDef(n, -1);
  3034.       exit;
  3035.     end
  3036.     else if n <> '-1' then
  3037.       Inc(I);
  3038.     while I < 0 do
  3039.     begin
  3040.       GRFW(u);
  3041.       GRFW(u);
  3042.       Inc(I);
  3043.     end;
  3044.     GRFW(u);
  3045.     Result := StrToIntDef(GRFW(u), -1);
  3046.   end;
  3047.   function GetRecordTypeNo(x: PIFPSValue): Cardinal;
  3048.   var
  3049.     rr: PIFRecField;
  3050.   begin
  3051.     rr := x^.RecField.GetItem(x^.RecField.Count - 1);
  3052.     Result := rr^.FType;
  3053.   end;
  3054.   function AllocStackReg(FType: Cardinal): PIFPSValue;
  3055.   var
  3056.     x: PIFPSProcVar;
  3057.   begin
  3058.     New(x);
  3059.     x^.DeclarePosition := FParser.CurrTokenPos;
  3060.     x^.VarName := '';
  3061.     x^.NameHash := MakeHash(x^.VarName);
  3062.     x^.VarType := FType;
  3063.     proc^.ProcVars.Add(x);
  3064.     New(Result);
  3065.     Result^.FType := CVAL_AllocatedStackReg;
  3066.     Result^.DPos := FParser.CurrTokenPos;
  3067.     Result^.Address := IFPSAddrStackStart + proc^.ProcVars.Count;
  3068.     Result^.RecField := nil;
  3069.     Result^.Modifiers := 0;
  3070.     WriteCommand(Cm_Pt);
  3071.     WriteLong(FType);
  3072.   end;
  3073.  
  3074.   function AllocStackReg2(FType: Cardinal): PIFPSValue;
  3075.   var
  3076.     x: PIFPSProcVar;
  3077.   begin
  3078.     New(x);
  3079.     x^.VarName := '';
  3080.     x^.NameHash := MakeHash(x^.VarName);
  3081.     x^.VarType := FType;
  3082.     proc^.ProcVars.Add(x);
  3083.     New(Result);
  3084.     Result^.FType := CVAL_AllocatedStackReg;
  3085.     Result^.RecField := nil;
  3086.     Result^.Modifiers := 0;
  3087.     Result^.Address := IFPSAddrStackStart + proc^.ProcVars.Count;
  3088.   end;
  3089.   function WriteCalculation(InData, OutReg: PIFPSValue): Boolean; forward;
  3090.  
  3091.   procedure DisposeStackReg(p: PIFPSValue);
  3092.   begin
  3093.     Dispose(
  3094.     PIFPSProcVar(proc^.ProcVars.GetItem(p^.Address - IFPSAddrStackStart - 1))
  3095.     );
  3096.     proc^.ProcVars.Delete(proc^.ProcVars.Count - 1);
  3097.     DisposePValue(p);
  3098.     WriteCommand(CM_PO);
  3099.   end;
  3100.   function GetTypeNo(p: PIFPSValue): Cardinal; forward;
  3101.  
  3102.   function WriteOutRec(x: PIFPSValue; AllowData: Boolean): Boolean; forward;
  3103.   procedure AfterWriteOutRec(var x: PIFPSValue); forward;
  3104.   function FindProc(const Name: string): Cardinal; forward;
  3105.   function checkCompatType2(p1, p2: PIFPSType): Boolean;
  3106.   begin
  3107.     if
  3108.       ((p1^.BaseType = btProcPtr) and (p2 = p1)) or
  3109.       (p1^.BaseType = btVariant) or
  3110.       (p2^.baseType = btVariant) or
  3111.       (IsIntType(p1^.BaseType) and IsIntType(P2^.BaseType)) or
  3112.       (IsRealType(p1^.BaseType) and IsIntRealType(P2^.BaseType)) or
  3113.       ((p1^.BaseType = btString) and (P2^.BaseType = btString)) or
  3114.       ((p1^.BaseType = btString) and (P2^.BaseType = btChar)) or
  3115.       ((p1^.BaseType = btArray) and (p2^.BaseType = btArray)) or
  3116.       ((p1^.BaseType = btChar) and (p2^.BaseType = btChar)) or
  3117.       ((p1^.BaseType = btRecord) and (p2^.BaseType = btrecord)) or
  3118.       ((p1^.BaseType = btEnum) and (p2^.BaseType = btEnum))
  3119.       then
  3120.       Result := True
  3121.     else if ((P1^.BaseType = btclass) and (p2^.Basetype = btClass)) then
  3122.     begin
  3123.       Result :=p1^.Ex.IsCompatibleWith(p2^.Ex);
  3124.     end else
  3125.  
  3126.       Result := False;
  3127.   end;
  3128.  
  3129.   function CheckCompatType(V1, v2: PIFPSValue): Boolean;
  3130.   var
  3131.     p1, P2: PIFPSType;
  3132.   begin
  3133.     if (v1^.Modifiers and 4) <> 0 then
  3134.     begin
  3135.       Result := True;
  3136.       exit;
  3137.     end;
  3138.     p1 := FUsedTypes.GetItem(GetTypeNo(V1));
  3139.     P2 := FUsedTypes.GetItem(GetTypeNo(v2));
  3140.     if (p1^.BaseType = btChar) and (p2^.BaseType = btString) and (v2^.FType = CVAL_Data) and (length(V2^.FData^.Value) = 1) then
  3141.     begin
  3142.       v2^.FData^.FType := GetType(btChar);
  3143.       P2 := FUsedTypes.GetItem(GetTypeNo(v2));
  3144.     end;
  3145.     Result := CheckCompatType2(p1, p2);
  3146.   end;
  3147.  
  3148.   function ProcessFunction(ResModifiers: Byte; ProcNo: Cardinal; InData: TIfList;
  3149.     ResultRegister:
  3150.     PIFPSValue): Boolean; forward;
  3151.   function ProcessVarFunction(ResModifiers: Byte; ProcNo: PIFPSValue; InData: TIfList;
  3152.     ResultRegister:
  3153.     PIFPSValue): Boolean; forward;
  3154.  
  3155.   function MakeNil(NilPos: Cardinal;ivar: PIFPSValue): Boolean;
  3156.   var
  3157.     Procno: Cardinal;
  3158.     PF: PIFPSType;
  3159.     Par: TIfList;
  3160.     pp: PParam;
  3161.   begin
  3162.     Pf := FUsedTypes.GetItem(GetTypeNo(IVar));
  3163.     if (pf^.BaseType <> btClass) or (not pf.Ex.SetNil(GetTypeno(IVar), ProcNo)) or ((Ivar.FType <> CVAL_Addr)and(Ivar.FType <> CVAL_AllocatedStackReg)) then
  3164.     begin
  3165.       MakeError('', ecTypeMismatch, '')^.Position := nilPos;
  3166.       Result := False;
  3167.       exit;
  3168.     end;
  3169.     ivar.FType := CVAL_PushAddr;
  3170.     ivar.Modifiers := ivar.modifiers or 128;
  3171.     Par := TIfList.Create;
  3172.     new(pp);
  3173.     pp^.InReg := ivar;
  3174.     pp^.OutReg := nil;
  3175.     pp^.FType := GetTypeNo(ivar);
  3176.     pp^.OutRegPos := NilPos;
  3177.     par.add(pp);
  3178.     Result := ProcessFunction(0, ProcNo, Par, nil);
  3179.     Dispose(pp);
  3180.     Par.Free;
  3181.     ivar.Modifiers := ivar.modifiers and not 128;
  3182.   end;
  3183.  
  3184.   function PreWriteOutRec(var X: PIFPSValue; FArrType: Cardinal): Boolean;
  3185.   var
  3186.     rr: PIFRecField;
  3187.     tmpp,
  3188.       tmpc: PIFPSValue;
  3189.     i: Longint;
  3190.   begin
  3191.     Result := True;
  3192.     if x^.FType = CVAL_NIL then
  3193.     begin
  3194.       if FArrType = Cardinal(-1) then
  3195.       begin
  3196.         MakeError('', ecTypeMismatch, '');
  3197.         Result := False;
  3198.         Exit;
  3199.       end;
  3200.       tmpp := AllocStackReg(FArrType);
  3201.       if not MakeNil(x^.DPos, tmpp) then
  3202.       begin
  3203.         Result := False;
  3204.         exit;
  3205.       end;
  3206.       tmpp^.FType := CVAL_ArrayAllocatedStackRec;
  3207.       x := tmpp;
  3208.     end else
  3209.     if x^.FType = CVAL_Array then
  3210.     begin
  3211.       if FArrType = Cardinal(-1) then
  3212.       begin
  3213.         MakeError('', ecTypeMismatch, '');
  3214.         Result := False;
  3215.         Exit;
  3216.       end;
  3217.       tmpp := AllocStackReg(FArrType);
  3218.       tmpp^.FType := CVAL_ArrayAllocatedStackRec;
  3219.       tmpc := AllocStackReg(GetType(bts32));
  3220.       WriteCommand(CM_A);
  3221.       WriteOutrec(tmpc, False);
  3222.       WriteByte(1);
  3223.       WriteLong(GetType(bts32));
  3224.       WriteLong(x^.ArrayItems.Count);
  3225.       WriteCommand(CM_PV);
  3226.       WriteOutrec(tmpp, False);
  3227.       WriteCommand(CM_C);
  3228.       WriteLong(FindProc('SETARRAYLENGTH'));
  3229.       WriteCommand(CM_PO);
  3230.       DisposeStackReg(tmpc);
  3231.       new(tmpc);
  3232.       tmpc^.FType := CVAL_Addr;
  3233.       tmpc^.Modifiers := 0;
  3234.       tmpc^.DPos := tmpp^.DPos;
  3235.       tmpc^.Address := tmpp^.Address;
  3236.       tmpc^.RecField := TIFList.Create;
  3237.       new(rr);
  3238.       rr^.FKind := 1;
  3239.       rr^.FType := Cardinal(PIFPSType(FUsedTypes.GetItem(FArrType))^.Ext);
  3240.       tmpc^.RecField.Add(rr);
  3241.       for i := 0 to x^.ArrayItems.Count -1 do
  3242.       begin
  3243.         rr^.ArrayFieldNo := i;
  3244.         if not WriteCalculation(x^.ArrayItems.GetItem(i), tmpc) then
  3245.         begin
  3246.           DisposePValue(tmpc);
  3247.           DisposeStackReg(tmpp);
  3248.           Result := False;
  3249.           Exit;
  3250.         end;
  3251.       end;
  3252.       x := tmpp;
  3253.     end else if (x^.FType = CVAL_Eval) then
  3254.     begin
  3255.       tmpp := AllocStackReg(x^.frestype);
  3256.       WriteCalculation(x, tmpp);
  3257.       if x^.Modifiers = 1 then
  3258.       begin
  3259.         WriteCommand(cm_bn);
  3260.         WriteByte(0);
  3261.         WriteLong(Tmpp^.Address);
  3262.       end else
  3263.       if x^.Modifiers = 2 then
  3264.       begin
  3265.         WriteCommand(cm_vm);
  3266.         WriteByte(0);
  3267.         WriteLong(Tmpp^.Address);
  3268.       end;
  3269.       tmpp^.DPos := cardinal(x);
  3270.       x := tmpp;
  3271.       x^.FType := CVAL_AllocatedStackReg + 1;
  3272.     end else if (x^.FType = CVAL_Proc) or (x^.FType = CVAL_VarProc) then
  3273.     begin
  3274.       if x^.FType = CVAL_VarProc then
  3275.       begin
  3276.         tmpp := AllocStackReg(StrToIntDef(Fw(PIFPSProceduralType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(x^._ProcNo)))^.Ext)^.ProcDef), -1));
  3277.       end else if PIFPSProcedure(FProcs.GetItem(x^.ProcNo))^.Internal then
  3278.         tmpp := AllocStackReg(StrToIntDef(Fw(PIFPSProcedure(FProcs.GetItem(x^.ProcNo))^.Decl), -1))
  3279.       else
  3280.         tmpp := AllocStackReg(StrToIntDef(Fw(PIFPSUsedRegProc(FPRocs.GetItem(x^.ProcNo))^.RP^.Decl), -1));
  3281.       WriteCalculation(x, tmpp);
  3282.       if x^.Modifiers = 1 then
  3283.       begin
  3284.         WriteCommand(cm_bn);
  3285.         WriteByte(0);
  3286.         WriteLong(Tmpp^.Address);
  3287.       end else
  3288.       if x^.Modifiers = 2 then
  3289.       begin
  3290.         WriteCommand(cm_vm);
  3291.         WriteByte(0);
  3292.         WriteLong(Tmpp^.Address);
  3293.       end;
  3294.       tmpp^.DPos := cardinal(x);
  3295.       x := tmpp;
  3296.       x^.FType := CVAL_AllocatedStackReg + 1;
  3297.    end else
  3298.     if ((x^.FType = CVAL_Addr) or (x^.FType = CVAL_PushAddr)) and (x^.RecField <> nil) then
  3299.     begin
  3300.       if x^.RecField.Count = 1 then
  3301.       begin
  3302.         rr := x^.RecField.GetItem(0);
  3303.         if rr^.FKind < 2 then
  3304.           exit; // there is no need pre-calculate anything
  3305.         if rr^.ReadArrayFieldNoFrom^.FType = CVAL_Addr then
  3306.           exit;
  3307.       end; //if
  3308.       tmpp := AllocStackReg(GetType(btPointer));
  3309.       WriteCommand(cm_sp);
  3310.       WriteOutRec(tmpp, True);
  3311.       WriteByte(0);
  3312.       WriteLong(x^.Address);
  3313.  
  3314.       for i := 0 to x^.RecField.Count - 1 do
  3315.       begin
  3316.         rr := x^.RecField.GetItem(I);
  3317.         case rr^.FKind of
  3318.           0, 1:
  3319.             begin
  3320.               WriteCommand(cm_sp);
  3321.               WriteOutRec(tmpp, false);
  3322.               WriteByte(2);
  3323.               WriteLong(tmpp^.Address);
  3324.               WriteLong(rr^.RecFieldNo);
  3325.             end; // case 0,1
  3326.           2:
  3327.             begin
  3328.               tmpc := AllocStackReg(GetType(btU32));
  3329.               if not WriteCalculation(rr^.ReadArrayFieldNoFrom, tmpc) then
  3330.               begin
  3331.                 DisposeStackReg(tmpc);
  3332.                 DisposeStackReg(tmpp);
  3333.                 Result := False;
  3334.                 exit;
  3335.               end; //if
  3336.               WriteCommand(cm_sp);
  3337.               WriteOutRec(tmpp, false);
  3338.               WriteByte(3);
  3339.               WriteData(tmpp^.Address, 4);
  3340.               WriteData(tmpc^.Address, 4);
  3341.               DisposeStackReg(tmpc);
  3342.             end; // case 2
  3343.         end; // case
  3344.         Dispose(rr);
  3345.       end; // for
  3346.       if x^.Modifiers = 1 then
  3347.       begin
  3348.         WriteCommand(cm_bn);
  3349.         WriteByte(0);
  3350.         WriteLong(Tmpp^.Address);
  3351.       end else
  3352.       if x^.Modifiers = 2 then
  3353.       begin
  3354.         WriteCommand(cm_vm);
  3355.         WriteByte(0);
  3356.         WriteLong(Tmpp^.Address);
  3357.       end;
  3358.       x^.RecField.Clear;
  3359.       new(rr);
  3360.       rr^.FKind := 3;
  3361.       rr^.ResultRec := tmpp;
  3362.       x^.RecField.Add(rr);
  3363.     end else if (x^.Modifiers and 3) <> 0 then
  3364.     begin
  3365.       if x^.FType = CVAL_Addr then
  3366.       begin
  3367.         tmpp := AllocStackReg(GetTypeNo(x));
  3368.         tmpp^.FType := CVAL_AllocatedStackReg + 1;
  3369.         WriteCommand(CM_A);
  3370.         WriteByte(0);
  3371.         WriteLong(tmpp^.Address);
  3372.         WriteByte(0);
  3373.         WriteLong(x^.Address);
  3374.         if x^.Modifiers = 1 then
  3375.         begin
  3376.           WriteCommand(cm_bn);
  3377.           WriteByte(0);
  3378.           WriteLong(Tmpp^.Address);
  3379.         end else
  3380.         if x^.Modifiers = 2 then
  3381.         begin
  3382.           WriteCommand(cm_vm);
  3383.           WriteByte(0);
  3384.           WriteLong(Tmpp^.Address);
  3385.         end;
  3386.         tmpp^.DPos := cardinal(x);
  3387.         x := tmpp;
  3388.       end else if x^.FType = CVAL_PushAddr then
  3389.       begin
  3390.         if x^.Modifiers = 1 then
  3391.         begin
  3392.           WriteCommand(cm_bn);
  3393.           WriteByte(0);
  3394.           WriteLong(x^.Address);
  3395.         end else
  3396.         if x^.Modifiers = 2 then
  3397.         begin
  3398.           WriteCommand(cm_vm);
  3399.           WriteByte(0);
  3400.           WriteLong(x^.Address);
  3401.         end;
  3402.       end;
  3403.     end;
  3404.   end;
  3405.  
  3406.   procedure AfterWriteOutRec(var x: PIFPSValue);
  3407.   var
  3408.     rr: PIFRecField;
  3409.     p: Pointer;
  3410.   begin
  3411.     if x^.FType = CVAL_ArrayAllocatedStackRec then
  3412.     begin
  3413.       DisposeStackReg(x);
  3414.     end else
  3415.     if x^.FType = CVAL_AllocatedStackReg +1 then
  3416.     begin
  3417.       p := Pointer(x^.DPos);
  3418.       DisposeStackReg(x);
  3419.       x := p;
  3420.     end else if ((x^.FType = CVAL_Addr) or (x^.FType = CVAL_PushAddr)) and (x^.RecField <> nil) then
  3421.     begin
  3422.       rr := x^.RecField.GetItem(0);
  3423.       if (rr^.FKind = 3) then
  3424.       begin
  3425.         DisposeStackReg(rr^.ResultRec);
  3426.         Dispose(Rr);
  3427.         x^.RecField.Free;
  3428.         x^.RecField := nil;
  3429.       end;
  3430.     end;
  3431.   end; //afterwriteoutrec
  3432.  
  3433.   function WriteOutRec(x: PIFPSValue; AllowData: Boolean): Boolean;
  3434.   var
  3435.     rr: PIFRecField;
  3436.   begin
  3437.     Result := True;
  3438.     case x^.FType of
  3439.       CVAL_ArrayAllocatedStackRec, CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg, CVAL_AllocatedStackReg + 1:
  3440.         begin
  3441.           if x^.RecField = nil then
  3442.           begin
  3443.             WriteByte(0);
  3444.             WriteData(x^.Address, 4);
  3445.           end
  3446.           else
  3447.           begin
  3448.             rr := x^.RecField.GetItem(0);
  3449.             case rr^.FKind of
  3450.               0, 1:
  3451.                 begin
  3452.                   WriteByte(2);
  3453.                   WriteLong(x^.Address);
  3454.                   WriteLong(rr^.RecFieldNo);
  3455.                 end;
  3456.               2:
  3457.                 begin
  3458.                   WriteByte(3);
  3459.                   WriteLong(x^.Address);
  3460.                   WriteLong(rr^.ReadArrayFieldNoFrom^.Address);
  3461.                 end;
  3462.               3:
  3463.                 begin
  3464.                   WriteByte(0);
  3465.                   WriteLong(rr^.ResultRec^.Address);
  3466.                 end;
  3467.             end;
  3468.           end;
  3469.         end;
  3470.       CVAL_Data:
  3471.         if AllowData then
  3472.         begin
  3473.           WriteByte(1);
  3474.           WriteVariant(x^.FData)
  3475.         end
  3476.         else
  3477.         begin
  3478.           Result := False;
  3479.           exit;
  3480.         end;
  3481.     else
  3482.       Result := False;
  3483.     end;
  3484.   end;
  3485.  
  3486.   function GetTypeNo(p: PIFPSValue): Cardinal;
  3487.   var
  3488.     n: PIFPSProcedure;
  3489.   begin
  3490.     if (p^.Modifiers and 8) <> 0 then
  3491.     begin
  3492.       Result := p^.FNewTypeNo;
  3493.       exit;
  3494.     end;
  3495.     if (p^.RecField <> nil) and (p^.FType = CVAL_Addr) then
  3496.     begin
  3497.       Result := GetRecordTypeNo(p);
  3498.     end
  3499.     else
  3500.       case p^.FType of
  3501.         CVAL_Cast:
  3502.         begin
  3503.           Result := p^.NewTypeNo;
  3504.         end;
  3505.         CVAL_Array:
  3506.         begin
  3507.           Result := at2ut(FindType('TVariantArray'));
  3508.         end;
  3509.         CVAL_ArrayAllocatedStackRec, CVAL_Addr, CVAL_AllocatedStackReg, CVAL_PushAddr:
  3510.           begin
  3511.             if p^.Address < IFPSAddrNegativeStackStart then
  3512.             begin
  3513.               if p^.Address < FVars.Count then
  3514.               begin
  3515.                 Result := PIFPSVar(FVars.GetItem(p^.Address))^.FType;
  3516.               end
  3517.               else
  3518.                 Result := Cardinal(-1);
  3519.             end
  3520.             else
  3521.             begin
  3522.               if p^.Address < IFPSAddrStackStart then
  3523.               begin
  3524.                 Result := GetParamType(p^.Address - IFPSAddrStackStart);
  3525.               end
  3526.               else
  3527.                 Result := PIFPSProcVar(proc^.ProcVars.GetItem(p^.Address - 1 -
  3528.                   IFPSAddrStackStart))^.VarType;
  3529.             end;
  3530.           end;
  3531.         CVAL_Data: Result := p^.FData^.FType;
  3532.         CVAL_VarProc:
  3533.           begin
  3534.             Result := StrToIntDef(Fw(PIFPSProceduralType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(p^._ProcNo)))^.Ext)^.ProcDef), -1);
  3535.           end;
  3536.         CVAL_Proc:
  3537.           begin
  3538.             n := PIFPSProcedure(FProcs.GetItem(p^.ProcNo));
  3539.  
  3540.             if n^.Internal then
  3541.               Result := StrToIntDef(Fw(n^.Decl), -1)
  3542.             else
  3543.               Result := StrToIntDef(Fw(PIFPSUsedRegProc(n)^.RP^.Decl), -1);
  3544.           end;
  3545.         CVAL_Eval: Result := p^.frestype;
  3546.       else
  3547.         Result := Cardinal(-1);
  3548.       end;
  3549.   end;
  3550.  
  3551.   function ReadParameters(ProcNo: Cardinal; FSelf: PIFPSValue): PIFPSValue; forward;
  3552.  
  3553.   function FindProc(const Name: string): Cardinal;
  3554.   var
  3555.     l, h: Longint;
  3556.     x: PIFPSUsedRegProc;
  3557.  
  3558.   begin
  3559.     h := MakeHash(Name);
  3560.     for l := 0 to FProcs.Count - 1 do
  3561.     begin
  3562.       if PIFPSProcedure(FProcs.GetItem(l))^.Internal then
  3563.       begin
  3564.         if (PIFPSProcedure(FProcs.GetItem(l))^.NameHash = h) and
  3565.           (PIFPSProcedure(FProcs.GetItem(l))^.Name = Name) then
  3566.         begin
  3567.           Result := l;
  3568.           exit;
  3569.         end;
  3570.       end
  3571.       else
  3572.       begin
  3573.         if (PIFPSUsedRegProc(FProcs.GetItem(l))^.RP^.NameHash = h) and
  3574.           (PIFPSUsedRegProc(FProcs.GetItem(l))^.RP^.Name = Name) then
  3575.         begin
  3576.           Result := l;
  3577.           exit;
  3578.         end;
  3579.       end;
  3580.     end;
  3581.     for l := 0 to FRegProcs.Count - 1 do
  3582.     begin
  3583.       if (PIFPSRegProc(FRegProcs.GetItem(l))^.NameHash = h) and
  3584.         (PIFPSRegProc(FRegProcs.GetItem(l))^.Name = Name) then
  3585.       begin
  3586.         New(x);
  3587.         x^.Internal := False;
  3588.         x^.RP := FRegProcs.GetItem(l);
  3589.         ReplaceTypes(x^.Rp^.Decl);
  3590.         FProcs.Add(x);
  3591.         Result := FProcs.Count - 1;
  3592.         exit;
  3593.       end;
  3594.     end;
  3595.     Result := Cardinal(-1);
  3596.   end; {findfunc}
  3597.  
  3598.   function calc(endOn: TIfPasToken): PIFPSValue; forward;
  3599.  
  3600.   function ReadVarParameters(ProcNoVar: PIFPSValue): PIFPSValue; forward;
  3601.  
  3602.   function GetIdentifier(const FType: Byte): PIFPSValue;
  3603.     {
  3604.       FType:
  3605.         0 = Anything
  3606.         1 = Only variables
  3607.         2 = Not constants
  3608.     }
  3609.   var
  3610.     Temp: PIFPSValue;
  3611.     l, h: Longint;
  3612.     s, u: string;
  3613.     t: PIFPSConstant;
  3614.     Temp1: Cardinal;
  3615.  
  3616.     procedure CheckProcCall(var x: PIFPSValue);
  3617.     begin
  3618.       if FParser.CurrTokenId = CSTI_Dereference then
  3619.       begin
  3620.         if PIFPSType(FUsedTypes.GetItem(GetTypeNo(x)))^.BaseType <> btProcPtr then
  3621.         begin
  3622.           MakeError('', ecTypeMismatch, '');
  3623.           DisposePValue(x);
  3624.           x := nil;
  3625.           Exit;
  3626.         end;
  3627.         FParser.Next;
  3628.         x := ReadVarParameters(x);
  3629.       end;
  3630.     end;
  3631.  
  3632.     procedure CheckFurther(var x: PIFPSValue);
  3633.     var
  3634.       t: Cardinal;
  3635.       rr: PIFRecField;
  3636.       LastRecType, I, LL: Longint;
  3637.       u: PIFPSType;
  3638.       Param: PParam;
  3639.       NewRecFields: TIfList;
  3640.       tmp, tmp3: PIFPSValue;
  3641.       tmp2: Boolean;
  3642.  
  3643.       function FindSubR(const n: string; FType: PIFPSType): Cardinal;
  3644.       var
  3645.         h, I: Longint;
  3646.       begin
  3647.         h := MakeHash(n);
  3648.         for I := 0 to FType.RecordSubVals.Count - 1 do
  3649.         begin
  3650.           if
  3651.             (PIFPSRecordType(FType.RecordSubVals.GetItem(I))^.FieldNameHash =
  3652.             h) and
  3653.             (PIFPSRecordType(FType.RecordSubVals.GetItem(I))^.FieldName = n)
  3654.               then
  3655.           begin
  3656.             Result := I;
  3657.             exit;
  3658.           end;
  3659.         end;
  3660.         Result := Cardinal(-1);
  3661.       end;
  3662.  
  3663.     begin
  3664.       if (x^.FType <> CVAL_Addr) and (x^.FType <> CVAL_PushAddr) and (x^.FType <> CVAL_AllocatedStackReg) then
  3665.         Exit;
  3666.       x.RecField := nil;
  3667.       t := GetTypeNo(x);
  3668.       u := FUsedTypes.GetItem(t);
  3669.       if u^.BaseType = btClass then exit;
  3670.       while True do
  3671.       begin
  3672.         if FParser.CurrTokenId = CSTI_OpenBlock then
  3673.         begin
  3674.           if (u^.BaseType = btString) and (x^.FType = CVAL_Addr) then
  3675.           begin
  3676.             x^.FType := CVAL_PushAddr;
  3677.              FParser.Next;
  3678.             tmp := Calc(CSTI_CloseBlock);
  3679.             if tmp = nil then
  3680.             begin
  3681.               DisposePValue(x);
  3682.               x := nil;
  3683.               exit;
  3684.             end;
  3685.             if not IsIntType(PIFPSType(FUSedTypes.GetItem(GetTypeNo(tmp)))^.BaseType) then
  3686.             begin
  3687.               MakeError('', ecTypeMismatch, '');
  3688.               DisposePValue(tmp);
  3689.               DisposePValue(x);
  3690.               x := nil;
  3691.               exit;
  3692.             end;
  3693.             FParser.Next;
  3694.             if FParser.CurrTokenId = CSTI_Assignment then
  3695.             begin
  3696.               l := FindProc('STRSET');
  3697.               if l = -1 then
  3698.               begin
  3699.                 MakeError('', ecUnknownIdentifier, 'StrGet');
  3700.                 DisposePValue(tmp);
  3701.                 DisposePValue(x);
  3702.                 x := nil;
  3703.                 exit;
  3704.               end;
  3705.               New(tmp3);
  3706.               tmp3^.FType :=CVAL_Proc;
  3707.               tmp3^.Modifiers := 0;
  3708.               tmp3^.DPos := FParser.CurrTokenPos;
  3709.               tmp3^.ProcNo := L;
  3710.               tmp3^.Parameters := TIfList.Create;
  3711.               new(Param);
  3712.               tmp3^.Parameters.Add(Param);
  3713.               new(Param);
  3714.               param^.InReg := tmp;
  3715.               Param^.FType := GetTypeNo(tmp);
  3716.               Param^.OutReg := nil;
  3717.               Param^.OutRegPos := tmp^.DPos;
  3718.               tmp3^.Parameters.Add(Param);
  3719.               new(Param);
  3720.               param^.InReg := x;
  3721.               Param^.FType := GetTypeNo(x);
  3722.               Param^.OutReg := nil;
  3723.               Param^.OutRegPos := tmp^.DPos;
  3724.               tmp3^.Parameters.Add(Param);
  3725.               Param := tmp3^.Parameters.GetItem(0);
  3726.               x := tmp3;
  3727.               FParser.Next;
  3728.               tmp := Calc(CSTI_SemiColon);
  3729.               if (Tmp^.FType = CVAL_DATA) and (PIFPSType(FUSedTypes.GetItem(Tmp^.FData^.FType))^.BaseType = btString) then
  3730.               begin
  3731.                 if Length(Tmp^.FData^.Value) <> 1 then
  3732.                 begin
  3733.                   MakeError('', ecTypeMismatch, '');
  3734.                   DisposePValue(Tmp);
  3735.                   x^.Parameters.Delete(0);
  3736.                   DisposePValue(x);
  3737.                   x := nil;
  3738.                   exit;
  3739.                 end;
  3740.                 Tmp^.FData^.FType := GetType(btChar);
  3741.               end;
  3742.               if PIFPSType(FUSedTypes.GetItem(Tmp^.FData^.FType))^.BaseType <> btChar then
  3743.               begin
  3744.                 MakeError('', ecTypeMismatch, '');
  3745.                 DisposePValue(Tmp);
  3746.                 x^.Parameters.Delete(0);
  3747.                 DisposePValue(x);
  3748.                 x := nil;
  3749.                 exit;
  3750.               end;
  3751.               if tmp = nil then
  3752.               begin
  3753.                 x^.Parameters.Delete(0);
  3754.                 DisposePValue(x);
  3755.                 x := nil;
  3756.                 exit;
  3757.               end;
  3758.               Param^.InReg := tmp;
  3759.               Param^.OutReg := nil;
  3760.               param^.FType := GetTypeNo(tmp);
  3761.               Param^.OutRegPos := tmp^.DPos;
  3762.             end else begin
  3763.               l := FindProc('STRGET');
  3764.               if l = -1 then
  3765.               begin
  3766.                 MakeError('', ecUnknownIdentifier, 'StrGet');
  3767.                 DisposePValue(tmp);
  3768.                 DisposePValue(x);
  3769.                 x := nil;
  3770.                 exit;
  3771.               end;
  3772.               New(tmp3);
  3773.               tmp3^.FType :=CVAL_Proc;
  3774.               tmp3^.Modifiers := 0;
  3775.               tmp3^.DPos := FParser.CurrTokenPos;
  3776.               tmp3^.ProcNo := L;
  3777.               tmp3^.Parameters := TIfList.Create;
  3778.               new(Param);
  3779.               param^.InReg := x;
  3780.               Param^.FType := GetTypeNo(x);
  3781.               Param^.OutReg := nil;
  3782.               Param^.OutRegPos := tmp^.DPos;
  3783.               tmp3^.Parameters.Add(Param);
  3784.               new(Param);
  3785.               param^.InReg := tmp;
  3786.               Param^.FType := GetTypeNo(tmp);
  3787.               Param^.OutReg := nil;
  3788.               Param^.OutRegPos := tmp^.DPos;
  3789.               tmp3^.Parameters.Add(Param);
  3790.               x := tmp3;
  3791.             end;
  3792.             Break;
  3793.           end else if u^.BaseType = btArray then
  3794.           begin
  3795.             FParser.Next;
  3796.             tmp := calc(CSTI_CloseBlock);
  3797.             if tmp = nil then
  3798.             begin
  3799.               DisposePValue(x);
  3800.               x := nil;
  3801.               exit;
  3802.             end;
  3803.             if not IsIntType(PIFPSType(FUSedTypes.GetItem(GetTypeNo(tmp)))^.BaseType) then
  3804.             begin
  3805.               MakeError('', ecTypeMismatch, '');
  3806.               DisposePValue(tmp);
  3807.               DisposePValue(x);
  3808.               x := nil;
  3809.               exit;
  3810.             end;
  3811.             if tmp^.FType = CVAL_Data then
  3812.             begin
  3813.               if x.RecField = nil then
  3814.                 x.RecField := TIfList.Create;
  3815.               new(rr);
  3816.               rr^.FKind := 1;
  3817.               rr^.ArrayFieldNo := GetUInt(FUsedTypes, tmp^.FData, tmp2);
  3818.               rr^.FType := Cardinal(u^.Ext);
  3819.               u := FUsedTypes.GetItem(Cardinal(u^.Ext));
  3820.               x^.RecField.Add(rr);
  3821.             end
  3822.             else
  3823.             begin
  3824.               if x.RecField = nil then
  3825.                 x.RecField := TIfList.Create;
  3826.               new(rr);
  3827.               rr^.FKind := 2;
  3828.               rr^.ReadArrayFieldNoFrom := tmp;
  3829.               rr^.FType := Cardinal(u^.Ext);
  3830.               u := FUsedTypes.GetItem(Cardinal(u^.Ext));
  3831.               x^.RecField.Add(rr);
  3832.             end;
  3833.             if FParser.CurrTokenId <> CSTI_CloseBlock then
  3834.             begin
  3835.               MakeError('', ecCloseBlockExpected, '');
  3836.               DisposePValue(x);
  3837.               x := nil;
  3838.               exit;
  3839.             end;
  3840.             Fparser.Next;
  3841.           end else begin
  3842.             MakeError('', ecSemicolonExpected, '');
  3843.             DisposePValue(x);
  3844.             x := nil;
  3845.             exit;
  3846.           end;
  3847.         end
  3848.         else if FParser.CurrTokenId = CSTI_Period then
  3849.         begin
  3850.           FParser.Next;
  3851.           if u^.BaseType = btRecord then
  3852.           begin
  3853.             t := FindSubR(FParser.GetToken, u);
  3854.             if t = Cardinal(-1) then
  3855.             begin
  3856.               MakeError('', ecUnknownIdentifier, '');
  3857.               DisposePValue(x);
  3858.               x := nil;
  3859.               exit;
  3860.             end;
  3861.             FParser.Next;
  3862.             if x.RecField = nil then
  3863.               x.RecField := TIfList.Create;
  3864.             new(rr);
  3865.             rr^.FKind := 0;
  3866.             rr^.FType := PIFPSRecordType(u^.RecordSubVals.GetItem(t))^.FType;
  3867.             rr^.RecFieldNo := t;
  3868.             u := FUsedTypes.GetItem(rr^.FType);
  3869.             x^.RecField.Add(rr);
  3870.           end
  3871.           else
  3872.           begin
  3873.             DisposePValue(x);
  3874.             MakeError('', ecSemicolonExpected, '');
  3875.             x := nil;
  3876.             exit;
  3877.           end;
  3878.         end
  3879.         else
  3880.           break;
  3881.       end;
  3882.       if x^.RecField = nil then
  3883.         exit;
  3884.       LL := -1;
  3885.       NewRecFields := TIfList.Create;
  3886.       if x^.FType = 0 then
  3887.       begin
  3888.         if x^.Address < IFPSAddrNegativeStackStart then
  3889.           LastRecType := PIFPSVar(FVars.GetItem(x^.Address))^.FType
  3890.         else if x^.Address < IFPSAddrStackStart then
  3891.         begin
  3892.           LastRecType := GetParamType(Longint(x^.Address - IFPSAddrStackStart));
  3893.         end
  3894.         else
  3895.           LastRecType := PIFPSProcVar(proc^.ProcVars.GetItem(x^.Address - 1 - IFPSAddrStackStart))^.VarType;
  3896.         i := 0;
  3897.         u := FUsedTypes.GetItem(LastRecType);
  3898.  
  3899.         while i < Longint(x^.RecField.Count) do
  3900.         begin
  3901.           rr := x^.RecField.GetItem(I);
  3902.           case rr^.FKind of
  3903.             0:
  3904.               begin
  3905.                 if LL = -1 then
  3906.                   inc(ll);
  3907.                 LastRecType := rr^.FType;
  3908.                 LL := LL + Longint(PIFPSRecordType(u^.RecordSubVals.GetItem(rr^.RecFieldNo))^.RealFieldOffset);
  3909.                 u := FUsedTypes.GetItem(LastRecType);
  3910.                 dispose(rr);
  3911.               end;
  3912.             1:
  3913.               begin
  3914.                 if LL <> -1 then
  3915.                 begin
  3916.                   new(rr);
  3917.                   rr^.FKind := 0;
  3918.                   rr^.RecFieldNo := LL;
  3919.                   rr^.FType := LastRecType;
  3920.                   newRecFields.Add(Rr);
  3921.                   rr := x^.RecField.GetItem(I);
  3922.                 end;
  3923.                 u := FUsedTypes.GetItem(rr^.FType);
  3924.                 newRecFields.Add(rr);
  3925.                 LL := -1;
  3926.               end;
  3927.             2:
  3928.               begin
  3929.                 if LL <> -1 then
  3930.                 begin
  3931.                   new(rr);
  3932.                   rr^.FKind := 0;
  3933.                   rr^.FType := LastRecType;
  3934.                   rr^.RecFieldNo := LL;
  3935.                   newRecFields.Add(Rr);
  3936.                   rr := x^.RecField.GetItem(I);
  3937.                 end;
  3938.                 u := FUsedTypes.GetItem(rr^.FType);
  3939.                 newRecFields.Add(rr);
  3940.                 LL := -1;
  3941.               end;
  3942.  
  3943.           end;
  3944.           inc(i);
  3945.         end;
  3946.         if LL <> -1 then
  3947.         begin
  3948.           new(rr);
  3949.           rr^.FKind := 0;
  3950.           rr^.RecFieldNo := LL;
  3951.           rr^.FType := LastRecType;
  3952.           newRecFields.Add(Rr);
  3953.         end;
  3954.         x^.RecField.Free;
  3955.         x^.RecField := NewRecFields;
  3956.       end;
  3957.     end;
  3958.     function ReadPropertyParameters(Params: TIfList; ParamTypes: string): Boolean;
  3959.     var
  3960.       CurrParamType: Cardinal;
  3961.       Temp: PIFPSValue;
  3962.       P: PParam;
  3963.     begin
  3964.       Delete(ParamTypes, 1, pos(' ', ParamTypes)); // Remove property type
  3965.       if FParser.CurrTokenID <> CSTI_OpenBlock then
  3966.       begin
  3967.         MakeError('', ecOpenBlockExpected, '');
  3968.         Result := False;
  3969.         exit;
  3970.       end;
  3971.       FParser.Next;
  3972.       while ParamTypes <> '' do
  3973.       begin
  3974.         CurrParamType := at2ut(StrToIntDef(GRFW(ParamTypes), -1));
  3975.         Temp := Calc(CSTI_CloseBlock);
  3976.         if temp = nil then
  3977.         begin
  3978.           Result := False;
  3979.           Exit;
  3980.         end;
  3981.         New(P);
  3982.         p^.InReg := Temp;
  3983.         p^.OutReg := nil;
  3984.         p^.FType := CurrParamType;
  3985.         p^.OutRegPos := FParser.CurrTokenPos;
  3986.         Params.Add(p);
  3987.         if ParamTypes = '' then
  3988.         begin
  3989.           if FParser.CurrTokenID <> CSTI_CloseBlock then
  3990.           begin
  3991.             MakeError('', ecCloseBlockExpected, '');
  3992.             Result := False;
  3993.             Exit;
  3994.           end;
  3995.           FParser.Next;
  3996.         end else begin
  3997.           if FParser.CurrTokenId <> CSTI_Comma then
  3998.           begin
  3999.             MakeError('', ecCommaExpected, '');
  4000.             Result := False;
  4001.             exit;
  4002.           end;
  4003.           FParser.Next;
  4004.         end;
  4005.       end;
  4006.       Result := True;
  4007.     end;
  4008.     procedure CheckClass(var P: PIFPSValue);
  4009.     var
  4010.       Idx, FTypeNo: Cardinal;
  4011.       FType: PIFPSType;
  4012.       TempP: PIFPSValue;
  4013.       Param: PParam;
  4014.       s: string;
  4015.  
  4016.     begin
  4017.       FTypeNo := GetTypeNo(p);
  4018.       if FTypeNo = Cardinal(-1) then Exit;
  4019.       FType := FUsedTypes.GetItem(FTypeNo);
  4020.       if FType.BaseType <> btClass then Exit;
  4021.       while FParser.CurrTokenID = CSTI_Period do
  4022.       begin
  4023.         FParser.Next;
  4024.         if FParser.CurrTokenID <> CSTI_Identifier then
  4025.         begin
  4026.           MakeError('', ecIdentifierExpected, '');
  4027.           DisposePValue(p);
  4028.           P := nil;
  4029.           Exit;
  4030.         end;
  4031.         s := FParser.GetToken;
  4032.         FParser.Next;
  4033.         if FType.Ex.Func_Find(s, Idx) then
  4034.         begin
  4035.           FType.Ex.Func_Call(Idx, FTypeNo);
  4036.           P := ReadParameters(FTypeNo, P);
  4037.           if p = nil then
  4038.           begin
  4039.             Exit;
  4040.           end;
  4041.         end else if FType.Ex.Property_Find(s, Idx) then
  4042.         begin
  4043.           FType.Ex.Property_GetHeader(Idx, s);
  4044.           TempP := P;
  4045.           New(P);
  4046.           P^.FType := CVAL_Proc;
  4047.           p^.Modifiers := 0;
  4048.           p^.DPos := FParser.CurrTokenPos;
  4049.           P^.Parameters := TIfList.Create;
  4050.           new(param);
  4051.           Param^.InReg := TempP;
  4052.           Param^.OutReg := nil;
  4053.           Param^.FType := GetTypeNo(TempP);
  4054.           P^.Parameters.Add(Param);
  4055.           if pos(' ', s) <> 0 then
  4056.           begin
  4057.             if not ReadPropertyParameters(P^.Parameters, s) then
  4058.             begin
  4059.               DisposePValue(P);
  4060.               P := nil;
  4061.               exit;
  4062.             end;
  4063.           end; // if
  4064.           if FParser.CurrTokenId = CSTI_Assignment then
  4065.           begin
  4066.             FParser.Next;
  4067.             TempP := Calc(CSTI_SemiColon);
  4068.             if TempP = nil then
  4069.             begin
  4070.               DisposePValue(P);
  4071.               p := nil;
  4072.               exit;
  4073.             end;
  4074.             new(param);
  4075.             Param^.InReg := tempp;
  4076.             Param^.OutReg := nil;
  4077.             Param^.FType := at2ut(StrToIntDef(fw(s), -1));
  4078.             P^.Parameters.Add(Param);
  4079.             if not FType.Ex.Property_Set(Idx, p^.ProcNo) then
  4080.             begin
  4081.               MakeError('', ecReadOnlyProperty, '');
  4082.               DisposePValue(p);
  4083.               p := nil;
  4084.               exit;
  4085.             end;
  4086.             Exit;
  4087.           end else begin
  4088.             if not FType.Ex.Property_Get(Idx, p^.ProcNo) then
  4089.             begin
  4090.               MakeError('', ecWriteOnlyProperty, '');
  4091.               DisposePValue(p);
  4092.               p := nil;
  4093.               exit;
  4094.             end;
  4095.           end; // if FParser.CurrTokenId = CSTI_Assign
  4096.         end else
  4097.         begin
  4098.           MakeError('', ecUnknownIdentifier, s);
  4099.           DisposePValue(p);
  4100.           P := nil;
  4101.           Exit;
  4102.         end;
  4103.         FTypeNo := GetTypeNo(p);
  4104.         FType := FUsedTypes.GetItem(FTypeNo);
  4105.         if (FType = nil) or (FType.BaseType <> btClass) then Exit;
  4106.       end; {while}
  4107.     end;
  4108.     function CheckClassType(const TypeNo, ParserPos: Cardinal): PIFPSValue;
  4109.     var
  4110.       FType, FType2: PIFPSType;
  4111.       ProcNo, Idx: Cardinal;
  4112.       PP: PParam;
  4113.       Temp: PIFPSValue;
  4114.     begin
  4115.       FType := FAvailableTypes.GetItem(TypeNo);
  4116.       if FParser.CurrTokenID = CSTI_OpenRound then
  4117.       begin
  4118.         FParser.Next;
  4119.         Temp := Calc(CSTI_CloseRound);
  4120.         if Temp = nil then
  4121.         begin
  4122.           Result := nil;
  4123.           exit;
  4124.         end;
  4125.         if FParser.CurrTokenID <> CSTI_CloseRound then
  4126.         begin
  4127.           DisposePValue(temp);
  4128.           MakeError('', ecCloseRoundExpected, '');
  4129.           Result := nil;
  4130.           exit;
  4131.         end;
  4132.         FType2 := FUsedTypes.GetItem(GetTypeNo(Temp));
  4133.         if (FType^.basetype = BtClass) and (ftype2^.BaseType = btClass) and (ftype <> ftype2) then
  4134.         begin
  4135.           if not FType2^.Ex.CastToType(GetTypeNo(Temp), AT2UT(TypeNo), ProcNo) then
  4136.           begin
  4137.             DisposePValue(Temp);
  4138.             MakeError('', ecTypeMismatch, '');
  4139.             Result := nil;
  4140.             exit;
  4141.           end;
  4142.           New(Result);
  4143.           Result^.FType := CVAL_Proc;
  4144.           Result^.Modifiers := 8;
  4145.           Result^.FNewTypeNo := at2ut(TypeNo);
  4146.           Result^.DPos := FParser.CurrTokenPos;
  4147.           Result^.Parameters := TIfList.Create;
  4148.           Result^.ProcNo := ProcNo;
  4149.           New(pp);
  4150.           pp^.InReg := Temp;
  4151.           pp^.OutReg := nil;
  4152.           pp^.FType := GetTypeNo(Temp);
  4153.           Result^.Parameters.Add(pp);
  4154.           New(pp);
  4155.           pp^.OutReg := nil;
  4156.           pp^.FType := GetType(btu32);
  4157.           New(pp^.InReg);
  4158.           pp^.InReg^.FType := CVAL_Data;
  4159.           pp^.InReg^.Modifiers := 0;
  4160.           pp^.InReg^.DPos := FParser.CurrTokenPos;
  4161.           New(pp^.InReg^.FData);
  4162.           pp^.InReg^.FData^.FType := pp^.FType;
  4163.           pp^.InReg^.FData^.Value := mi2s(at2ut(TypeNo));
  4164.           Result^.Parameters.Add(pp);
  4165.           FParser.Next;
  4166.           Exit;
  4167.         end;
  4168.         if not checkCompatType2(FType, FType2) then
  4169.         begin
  4170.           DisposePValue(Temp);
  4171.           MakeError('', ecTypeMismatch, '');
  4172.           Result := nil;
  4173.           exit;
  4174.         end;
  4175.         FParser.Next;
  4176.         New(Result);
  4177.         Result^.FType := CVAL_Cast;
  4178.         Result^.Modifiers := 0;
  4179.         Result^.DPos := FParser.CurrTokenPos;
  4180.         Result^.Input := Temp;
  4181.         Result^.NewTypeNo := AT2UT(TypeNo);
  4182.         exit;
  4183.       end;
  4184.       if FParser.CurrTokenId <> CSTI_Period then
  4185.       begin
  4186.         Result := nil;
  4187.         MakeError('', ecPeriodExpected, '');
  4188.         Exit;
  4189.       end;
  4190.       if FType^.BaseType <> btClass then
  4191.       begin
  4192.         Result := nil;
  4193.         MakeError('', ecClassTypeExpected, '');
  4194.         Exit;
  4195.       end;
  4196.       FParser.Next;
  4197.       if not FType^.Ex.ClassFunc_Find(FParser.GetToken, Idx) then
  4198.       begin
  4199.         Result := nil;
  4200.         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  4201.         Exit;
  4202.       end;
  4203.       FParser.Next;
  4204.       FType^.Ex.ClassFunc_Call(Idx, ProcNo);
  4205.       New(Temp);
  4206.       Temp^.FType := CVAL_Data;
  4207.       Temp^.Modifiers := 0;
  4208.       New(Temp^.FData);
  4209.       Temp^.FData^.FType := GetType(btU32);
  4210.       SetLength(Temp^.FData^.Value, 4);
  4211.       Cardinal((@Temp^.FData^.Value[1])^) := AT2UT(TypeNo);
  4212.       Result := ReadParameters(ProcNo, Temp);
  4213.       if Result <> nil then
  4214.       begin
  4215.         Result^.Modifiers := Result^.Modifiers or 8;
  4216.         Result^.FNewTypeNo := AT2UT(TypeNo);
  4217.       end;
  4218.     end;
  4219.  
  4220.   begin
  4221.     s := FParser.GetToken;
  4222.     h := MakeHash(s);
  4223.     u := proc.Decl;
  4224.     if s = 'RESULT' then
  4225.     begin
  4226.       if GRFW(u) = '-1' then
  4227.       begin
  4228.         Result := nil;
  4229.         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  4230.       end
  4231.       else
  4232.       begin
  4233.         proc^.ResUsed := True;
  4234.         New(Result);
  4235.         Result^.FType := CVAL_Addr;
  4236.         Result^.Modifiers := 0;
  4237.         Result^.Address := IFPSAddrStackStart - 1;
  4238.         Result^.DPos := FParser.CurrTokenPos;
  4239.         Result^.RecField := nil;
  4240.         if @FOnUseVariable <> nil then
  4241.           FOnUseVariable(Self, ivtParam, 0, ProcNo, FParser.CurrTokenPos);
  4242.         FParser.Next;
  4243.         repeat
  4244.           Temp := Result;
  4245.           if Result <> nil then CheckFurther(Result);
  4246.           if Result <> nil then CheckClass(Result);
  4247.           if Result <> nil then CheckProcCall(Result);
  4248.         until (Result = nil) or (Temp = Result);
  4249.       end;
  4250.       exit;
  4251.     end;
  4252.     if GRFW(u) <> '-1' then
  4253.       l := -2
  4254.     else
  4255.       l := -1;
  4256.     while Length(u) > 0 do
  4257.     begin
  4258.       if D1(GRFW(u)) = s then
  4259.       begin
  4260.         New(Result);
  4261.         Result^.FType := CVAL_Addr;
  4262.         Result^.Modifiers := 0;
  4263.         Result^.Address := IFPSAddrStackStart + Cardinal(l);
  4264.         Result^.RecField := nil;
  4265.         if @FOnUseVariable <> nil then
  4266.           FOnUseVariable(Self, ivtParam, -1 - L, ProcNo, FParser.CurrTokenPos);
  4267.         FParser.Next;
  4268.         Result^.DPos := FParser.CurrTokenPos;
  4269.         repeat
  4270.           Temp := Result;
  4271.           if Result <> nil then CheckFurther(Result);
  4272.           if Result <> nil then CheckClass(Result);
  4273.           if Result <> nil then CheckProcCall(Result);
  4274.         until (Result = nil) or (Temp = Result);
  4275.         exit;
  4276.       end;
  4277.       Dec(l);
  4278.       GRFW(u);
  4279.     end;
  4280.  
  4281.     for l := 0 to proc^.ProcVars.Count - 1 do
  4282.     begin
  4283.       if (PIFPSProcVar(proc^.ProcVars.GetItem(l))^.NameHash = h) and
  4284.         (PIFPSProcVar(proc^.ProcVars.GetItem(l))^.VarName = s) then
  4285.       begin
  4286.         PIFPSProcVar(proc^.ProcVars.GetItem(l))^.Used := True;
  4287.         if @FOnUseVariable <> nil then
  4288.           FOnUseVariable(Self, ivtVariable, L, ProcNo, FParser.CurrTokenPos);
  4289.         New(Result);
  4290.         Result^.FType := CVAL_Addr;
  4291.         Result^.Modifiers := 0;
  4292.         Result^.Address := IFPSAddrStackStart + Cardinal(l) + 1;
  4293.         Result^.DPos := FParser.CurrTokenPos;
  4294.         Result^.RecField := nil;
  4295.  
  4296.         FParser.Next;
  4297.         repeat
  4298.           Temp := Result;
  4299.           if Result <> nil then CheckFurther(Result);
  4300.           if Result <> nil then CheckClass(Result);
  4301.           if Result <> nil then CheckProcCall(Result);
  4302.         until (Result = nil) or (Temp = Result);
  4303.  
  4304.         exit;
  4305.       end;
  4306.     end;
  4307.  
  4308.     for l := 0 to FVars.Count - 1 do
  4309.     begin
  4310.       if (PIFPSVar(FVars.GetItem(l))^.NameHash = h) and
  4311.         (PIFPSVar(FVars.GetItem(l))^.Name = s) then
  4312.       begin
  4313.         PIFPSVar(FVars.GetItem(l))^.Used := True;
  4314.         New(Result);
  4315.         Result^.FType := CVAL_Addr;
  4316.         Result^.Modifiers := 0;
  4317.         Result^.Address := l;
  4318.         Result^.RecField := nil;
  4319.         Result^.DPos := FParser.CurrTokenPos;
  4320.         if @FOnUseVariable <> nil then
  4321.           FOnUseVariable(Self, ivtGlobal, l, ProcNo, FParser.CurrTokenPos);
  4322.         FParser.Next;
  4323.         repeat
  4324.           Temp := Result;
  4325.           if Result <> nil then CheckFurther(Result);
  4326.           if Result <> nil then CheckClass(Result);
  4327.           if Result <> nil then CheckProcCall(Result);
  4328.         until (Result = nil) or (Temp = Result);
  4329.         exit;
  4330.       end;
  4331.     end;
  4332.     Temp1 := FindType(FParser.GetToken);
  4333.     if Temp1 <> Cardinal(-1) then
  4334.     begin
  4335.       l := FParser.CurrTokenPos;
  4336.       if FType = 1 then
  4337.       begin
  4338.         Result := nil;
  4339.         MakeError('', ecVariableExpected, FParser.OriginalToken);
  4340.         exit;
  4341.       end;
  4342.       FParser.Next;
  4343.       Result := CheckClassType(Temp1, l);
  4344.       repeat
  4345.         Temp := Result;
  4346.         if Result <> nil then CheckFurther(Result);
  4347.         if Result <> nil then CheckClass(Result);
  4348.         if Result <> nil then CheckProcCall(Result);
  4349.       until (Result = nil) or (Temp = Result);
  4350.  
  4351.       exit;
  4352.     end;
  4353.     Temp1 := FindProc(FParser.GetToken);
  4354.     if Temp1 <> Cardinal(-1) then
  4355.     begin
  4356.       l := FParser.CurrTokenPos;
  4357.       if FType = 1 then
  4358.       begin
  4359.         Result := nil;
  4360.         MakeError('', ecVariableExpected, FParser.OriginalToken);
  4361.         exit;
  4362.       end;
  4363.       FParser.Next;
  4364.       Result := ReadParameters(Temp1, nil);
  4365.       if Result = nil then
  4366.         exit;
  4367.       Result^.DPos := l;
  4368.       repeat
  4369.         Temp := Result;
  4370.         if Result <> nil then CheckFurther(Result);
  4371.         if Result <> nil then CheckClass(Result);
  4372.         if Result <> nil then CheckProcCall(Result);
  4373.       until (Result = nil) or (Temp = Result);
  4374.       exit;
  4375.     end;
  4376.     for l := 0 to FConstants.Count -1 do
  4377.     begin
  4378.       t := PIFPSConstant(FConstants.GetItem(l));
  4379.       if (t^.NameHash = h) and (t^.Name = s) then
  4380.       begin
  4381.         if FType <> 0 then
  4382.         begin
  4383.           Result := nil;
  4384.           MakeError('', ecVariableExpected, FParser.OriginalToken);
  4385.           exit;
  4386.         end;
  4387.         fparser.next;
  4388.         new(result);
  4389.         Result^.FType := CVAL_Data;
  4390.         Result^.DPos := FParser.CurrTokenPos;
  4391.         Result^.Modifiers := 0;
  4392.         new(Result^.FData);
  4393.         Result^.FData^.FType := at2ut(t^.Value.FType);
  4394.         Result^.FData^.Value := t^.Value.Value;
  4395.         exit;
  4396.       end;
  4397.     end;
  4398.     Result := nil;
  4399.     MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  4400.   end;
  4401.   function ReadVarParameters(ProcNoVar: PIFPSValue): PIFPSValue;
  4402.   var
  4403.     Decl: string;
  4404.     p: PParam;
  4405.     Tmp: PIFPSValue;
  4406.     FType: Cardinal;
  4407.     modifier: Char;
  4408.  
  4409.     function IsVarInCompatible(ft1, ft2: PIFPSType): Boolean;
  4410.     begin
  4411.       ft1 := GetTypeCopyLink(ft1);
  4412.       ft2 := GetTypeCopyLink(ft2);
  4413.       Result := (ft1 <> ft2);
  4414.     end;
  4415.  
  4416.     function getfc(const s: string): Char;
  4417.     begin
  4418.       if Length(s) > 0 then
  4419.         Result := s[1]
  4420.       else
  4421.         Result := #0
  4422.     end;
  4423.   begin
  4424.     Decl := PIFPSProceduralType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(ProcnoVar)))^.Ext)^.ProcDef;
  4425.     GRFW(Decl);
  4426.     New(Result);
  4427.     Result^.FType := CVAL_VarProc;
  4428.     Result^.Modifiers := 0;
  4429.     Result^._ProcNo := ProcNoVar;
  4430.     Result^._Parameters := TIfList.Create;
  4431.     if Length(Decl) = 0 then
  4432.     begin
  4433.       if FParser.CurrTokenId = CSTI_OpenRound then
  4434.       begin
  4435.         FParser.Next;
  4436.         if FParser.CurrTokenId <> CSTI_CloseRound then
  4437.         begin
  4438.           DisposePValue(Result);
  4439.           Result := nil;
  4440.           MakeError('', ecCloseRoundExpected, '');
  4441.           exit;
  4442.         end;
  4443.         FParser.Next;
  4444.       end;
  4445.     end
  4446.     else
  4447.     begin
  4448.       if FParser.CurrTokenId <> CSTI_OpenRound then
  4449.       begin
  4450.         DisposePValue(Result);
  4451.         MakeError('', ecOpenRoundExpected, '');
  4452.         Result := nil;
  4453.         exit;
  4454.       end;
  4455.       FParser.Next;
  4456.       while Length(Decl) > 0 do
  4457.       begin
  4458.         modifier := getfc(GRFW(Decl));
  4459.         FType := StrToInt(GRFW(Decl));
  4460.         if (modifier = '@') then
  4461.         begin
  4462.           Tmp := calc(CSTI_CloseRound);
  4463.           if Tmp = nil then
  4464.           begin
  4465.             DisposePValue(Result);
  4466.             Result := nil;
  4467.             exit;
  4468.           end;
  4469.         end
  4470.         else
  4471.         begin
  4472.           if FParser.CurrTokenId <> CSTI_Identifier then
  4473.           begin
  4474.             MakeError('', ecIdentifierExpected, '');
  4475.             DisposePValue(Result);
  4476.             Result := nil;
  4477.             exit;
  4478.           end;
  4479.           Tmp := GetIdentifier(1); // only variables
  4480.           if Tmp = nil then
  4481.           begin
  4482.             DisposePValue(Result);
  4483.             Result := nil;
  4484.             exit;
  4485.           end;
  4486.           if ((FType = Cardinal(-1)) and (PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp)))^.BaseType = btArray)) then
  4487.           begin
  4488.             {nothing}
  4489.           end else if IsVarInCompatible(FUsedTypes.GetItem(FType), FUsedTypes.GetItem(GetTypeNo(Tmp))) then
  4490.           begin
  4491.             MakeError('', ecTypeMismatch, '');
  4492.             DisposePValue(Result);
  4493.             DisposePValue(Tmp);
  4494.             Result := nil;
  4495.             exit;
  4496.           end;
  4497.           Tmp^.FType := Tmp^.FType + CVAL_PushAddr;
  4498.         end;
  4499.         New(p);
  4500.         p^.InReg := Tmp;
  4501.         p^.OutReg := nil;
  4502.         p^.FType := FType;
  4503.         Result._Parameters.Add(p);
  4504.         if Length(Decl) = 0 then
  4505.         begin
  4506.           if FParser.CurrTokenId <> CSTI_CloseRound then
  4507.           begin
  4508.             MakeError('', ecCloseRoundExpected, '');
  4509.             DisposePValue(Result);
  4510.             Result := nil;
  4511.             exit;
  4512.           end; {if}
  4513.           FParser.Next;
  4514.         end
  4515.         else
  4516.         begin
  4517.           if FParser.CurrTokenId <> CSTI_Comma then
  4518.           begin
  4519.             MakeError('', ecCommaExpected, '');
  4520.             DisposePValue(Result);
  4521.             Result := nil;
  4522.             exit;
  4523.           end; {if}
  4524.           FParser.Next;
  4525.         end; {else if}
  4526.       end; {for}
  4527.     end; {else if}
  4528.   end;
  4529.  
  4530.   function calc(endOn: TIfPasToken): PIFPSValue;
  4531.   var
  4532.     Items: TIfList;
  4533.     p: PCalc_Item;
  4534.     x: PParam;
  4535.     v, vc: PIFPSValue;
  4536.     Pt: PIFPSType;
  4537.     C: Byte;
  4538.     modifiers: byte;
  4539.     L: Cardinal;
  4540.  
  4541.     procedure Cleanup;
  4542.     var
  4543.       p: PCalc_Item;
  4544.       l: Longint;
  4545.     begin
  4546.       for l := 0 to Items.Count - 1 do
  4547.       begin
  4548.         p := Items.GetItem(l);
  4549.         if not p^.C then
  4550.         begin
  4551.           DisposePValue(p^.OutRec);
  4552.         end;
  4553.         Dispose(p);
  4554.       end;
  4555.       Items.Free;
  4556.     end;
  4557.  
  4558.     function SortItems: Boolean;
  4559.     var
  4560.       l: Longint;
  4561.       tt: Cardinal;
  4562.       p, p1, P2, ptemp: PCalc_Item;
  4563.       tempt: PIFPSType;
  4564.       pp: PParam;
  4565.       temps: string;
  4566.  
  4567.       function GetResultType(p1, P2: PIFPSValue; Cmd: Byte): Cardinal;
  4568.       var
  4569.         t1, t2: PIFPSType;
  4570.         tt1, tt2: Cardinal;
  4571.       begin
  4572.         tt1 := GetTypeNo(p1);
  4573.         t1 := FUsedTypes.GetItem(tt1);
  4574.         tt2 := GetTypeNo(P2);
  4575.         t2 := FUsedTypes.GetItem(tt2);
  4576.         if (t1 = nil) or (t2 = nil) then
  4577.         begin
  4578.           Result := Cardinal(-1);
  4579.           exit;
  4580.         end;
  4581.         case Cmd of
  4582.           0: {plus}
  4583.             begin
  4584.               if (t1^.BaseType = btVariant) and (
  4585.                 (t2^.BaseType = btVariant) or
  4586.                 (t2^.BaseType = btString) or
  4587.                 (t2^.BaseType = btPchar) or
  4588.                 (t2^.BaseType = btChar) or
  4589.                 (isIntRealType(t2^.BaseType))) then
  4590.                 Result := tt1
  4591.               else
  4592.               if (t2^.BaseType = btVariant) and (
  4593.                 (t1^.BaseType = btVariant) or
  4594.                 (t1^.BaseType = btString) or
  4595.                 (t1^.BaseType = btPchar) or
  4596.                 (t1^.BaseType = btChar) or
  4597.                 (isIntRealType(t1^.BaseType))) then
  4598.                 Result := tt2
  4599.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4600.                 Result := tt1
  4601.               else if IsIntRealType(t1^.BaseType) and
  4602.                 IsIntRealType(t2^.BaseType) then
  4603.               begin
  4604.                 if IsRealType(t1^.BaseType) then
  4605.                   Result := tt1
  4606.                 else
  4607.                   Result := tt2;
  4608.               end
  4609.               else if (t1^.BaseType = btString) and (t2^.BaseType = btChar) then
  4610.                 Result := tt1
  4611.               else if (t1^.BaseType = btChar) and (t2^.BaseType = btString) then
  4612.                 Result := tt2
  4613.               else if (t1^.BaseType = btChar) and (t2^.BaseType = btChar) then
  4614.                 Result := GetType(btString)
  4615.               else if (t1^.BaseType = btString) and (t2^.BaseType =
  4616.                 btString) then
  4617.                 Result := tt1
  4618.               else if (t1^.BaseType = btString) and (t2^.BaseType = btU8) then
  4619.                 Result := tt1
  4620.               else if (t1^.BaseType = btU8) and (t2^.BaseType = btString) then
  4621.                 Result := tt2
  4622.               else
  4623.                 Result := Cardinal(-1);
  4624.             end;
  4625.           1, 2, 3: { -  * / }
  4626.             begin
  4627.               if (t1^.BaseType = btVariant) and (
  4628.                 (t2^.BaseType = btVariant) or
  4629.                 (isIntRealType(t2^.BaseType))) then
  4630.                 Result := tt1
  4631.               else
  4632.               if (t2^.BaseType = btVariant) and (
  4633.                 (t1^.BaseType = btVariant) or
  4634.                 (isIntRealType(t1^.BaseType))) then
  4635.                 Result := tt2
  4636.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4637.                 Result := tt1
  4638.               else if IsIntRealType(t1^.BaseType) and
  4639.                 IsIntRealType(t2^.BaseType) then
  4640.               begin
  4641.                 if IsRealType(t1^.BaseType) then
  4642.                   Result := tt1
  4643.                 else
  4644.                   Result := tt2;
  4645.               end
  4646.               else
  4647.                 Result := Cardinal(-1);
  4648.             end;
  4649.           7, 8, 9: {and,or,xor}
  4650.             begin
  4651.               if (t1^.BaseType = btVariant) and (
  4652.                 (t2^.BaseType = btVariant) or
  4653.                 (isIntType(t2^.BaseType))) then
  4654.                 Result := tt1
  4655.               else
  4656.               if (t2^.BaseType = btVariant) and (
  4657.                 (t1^.BaseType = btVariant) or
  4658.                 (isIntType(t1^.BaseType))) then
  4659.                 Result := tt2
  4660.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4661.                 Result := tt1
  4662.               else if (tt1 = at2ut(FBooleanType)) and (tt2 = tt1) then
  4663.               begin
  4664.                 Result := tt1;
  4665.                 if ((p1^.FType = CVAL_Data) or (p2^.FType = CVAL_Data)) then
  4666.                 begin
  4667.                   if cmd = 7 then {and}
  4668.                   begin
  4669.                     if p1^.FType = CVAL_Data then
  4670.                     begin
  4671.                       if (p1^.FData^.Value[1] = #1) then
  4672.                         MakeWarning('', ewIsNotNeeded, '"True and"')^.Position := p1^.DPos
  4673.                       else
  4674.                         MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False')^.Position := p1^.DPos
  4675.                     end else begin
  4676.                       if (p2^.FData^.Value[1] = #1) then
  4677.                         MakeWarning('', ewIsNotNeeded, '"and True"')^.Position := p2^.DPos
  4678.                       else
  4679.                         MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False')^.Position := p2^.DPos;
  4680.                     end;
  4681.                   end else if cmd = 8 then {or}
  4682.                   begin
  4683.                     if p1^.FType = CVAL_Data then
  4684.                     begin
  4685.                       if (p1^.FData^.Value[1] = #1) then
  4686.                         MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True')^.Position := p1^.DPos
  4687.                       else
  4688.                         MakeWarning('', ewIsNotNeeded, '"False or"')^.Position := p1^.DPos
  4689.                     end else begin
  4690.                       if (p2^.FData^.Value[1] = #1) then
  4691.                         MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True')^.Position := p2^.DPos
  4692.                       else
  4693.                         MakeWarning('', ewIsNotNeeded, '"or False"')^.Position := p2^.DPos;
  4694.                     end;
  4695.                   end;
  4696.                 end;
  4697.               end else
  4698.                 Result := Cardinal(-1);
  4699.             end;
  4700.           4, 5, 6: {mod,shl,shr}
  4701.             begin
  4702.               if (t1^.BaseType = btVariant) and (
  4703.                 (t2^.BaseType = btVariant) or
  4704.                 (isIntType(t2^.BaseType))) then
  4705.                 Result := tt1
  4706.               else
  4707.               if (t2^.BaseType = btVariant) and (
  4708.                 (t1^.BaseType = btVariant) or
  4709.                 (isIntType(t1^.BaseType))) then
  4710.                 Result := tt2
  4711.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4712.                 Result := tt1
  4713.               else
  4714.                 Result := Cardinal(-1);
  4715.             end;
  4716.           10, 11, 12, 13: { >=, <=, >, <}
  4717.             begin
  4718.               if (t1^.BaseType = btVariant) and (
  4719.                 (t2^.BaseType = btVariant) or
  4720.                 (t2^.BaseType = btString) or
  4721.                 (t2^.BaseType = btPchar) or
  4722.                 (t2^.BaseType = btChar) or
  4723.                 (isIntRealType(t2^.BaseType))) then
  4724.                 Result := tt1
  4725.               else
  4726.               if (t2^.BaseType = btVariant) and (
  4727.                 (t1^.BaseType = btVariant) or
  4728.                 (t1^.BaseType = btString) or
  4729.                 (t1^.BaseType = btPchar) or
  4730.                 (t1^.BaseType = btChar) or
  4731.                 (isIntRealType(t1^.BaseType))) then
  4732.                 Result := tt2
  4733.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4734.                 Result := at2ut(FBooleanType)
  4735.               else if IsIntRealType(t1^.BaseType) and
  4736.                 IsIntRealType(t2^.BaseType) then
  4737.                 Result := at2ut(FBooleanType)
  4738.               else if (t1^.BaseType = btString) and (t2^.BaseType = btString) then
  4739.                 Result := at2ut(FBooleanType)
  4740.               else if (t1^.BaseType = btChar) and (t2^.BaseType = btString) then
  4741.                 Result := at2ut(FBooleanType)
  4742.               else if (t1^.BaseType = btString) and (t2^.BaseType = btChar) then
  4743.                 Result := at2ut(FBooleanType)
  4744.               else if (t1^.BaseType = btVariant) or (t2^.BaseType = btVariant) then
  4745.                 Result := at2ut(FBooleanType)
  4746.               else
  4747.                 Result := Cardinal(-1);
  4748.             end;
  4749.           14, 15: {=, <>}
  4750.             begin
  4751.               if (t1^.BaseType = btVariant) and (
  4752.                 (t2^.BaseType = btVariant) or
  4753.                 (t2^.BaseType = btString) or
  4754.                 (t2^.BaseType = btPchar) or
  4755.                 (t2^.BaseType = btChar) or
  4756.                 (isIntRealType(t2^.BaseType))) then
  4757.                 Result := tt1
  4758.               else
  4759.               if (t2^.BaseType = btVariant) and (
  4760.                 (t1^.BaseType = btVariant) or
  4761.                 (t1^.BaseType = btString) or
  4762.                 (t1^.BaseType = btPchar) or
  4763.                 (t1^.BaseType = btChar) or
  4764.                 (isIntRealType(t1^.BaseType))) then
  4765.                 Result := tt2
  4766.               else if IsIntType(t1^.BaseType) and IsIntType(t2^.BaseType) then
  4767.                 Result := at2ut(FBooleanType)
  4768.               else if IsIntRealType(t1^.BaseType) and
  4769.                 IsIntRealType(t2^.BaseType) then
  4770.                 Result := at2ut(FBooleanType)
  4771.               else if (t1^.BaseType = btChar) and (t2^.BaseType = btChar) then
  4772.                 Result := at2ut(FBooleanType)
  4773.               else if (t1^.BaseType = btChar) and (t2^.BaseType = btString) then
  4774.                 Result := at2ut(FBooleanType)
  4775.               else if (t1^.BaseType = btString) and (t2^.BaseType = btChar) then
  4776.                 Result := at2ut(FBooleanType)
  4777.               else if (t1^.BaseType = btString) and (t2^.BaseType = btString) then
  4778.                 Result := at2ut(FBooleanType)
  4779.               else if (t1^.BaseType = btEnum) and (t1 = t2) then
  4780.                 Result := at2ut(FBooleanType)
  4781.               else if (t1^.BaseType = btVariant) or (t2^.BaseType = btVariant) then
  4782.                 Result := at2ut(FBooleanType)
  4783.               else Result := Cardinal(-1);
  4784.             end;
  4785.         else
  4786.           Result := Cardinal(-1);
  4787.         end;
  4788.       end;
  4789.       procedure ApplyModifiers(FData: PIFPSValue);
  4790.       begin
  4791.         if (FData^.FType = CVAL_Data) then
  4792.         begin
  4793.           if FData^.Modifiers = 1 then // not
  4794.           begin
  4795.             FData^.Modifiers := FData^.Modifiers and not 1;
  4796.             case PIFPSType(FUsedTypes.GetItem(FData.FData^.FType))^.BaseType of
  4797.               btEnum: TbtU32((@FData^.FData^.Value[1])^) := tbtu32(TbtU32((@FData^.FData^.Value[1])^) = 0); 
  4798.               btU8: TbtU8((@FData.FData^.Value[1])^) := tbtu8(TbtU8((@FData.FData^.Value[1])^) = 0);
  4799.               btS8: TbtS8((@FData^.FData^.Value[1])^) := tbts8(TbtS8((@FData^.FData^.Value[1])^) = 0);
  4800.               btU16: TbtU16((@FData^.FData^.Value[1])^) := tbtu16(TbtU16((@FData^.FData^.Value[1])^) = 0);
  4801.               btS16: TbtS16((@FData^.FData^.Value[1])^) := tbts16(TbtS16((@FData^.FData^.Value[1])^) = 0);
  4802.               btU32: TbtU32((@FData^.FData^.Value[1])^) := tbtu32(TbtU32((@FData^.FData^.Value[1])^) = 0);
  4803.               btS32: TbtS32((@FData^.FData^.Value[1])^) := tbts32(TbtS32((@FData^.FData^.Value[1])^) = 0);
  4804.             end;
  4805.           end else
  4806.           if FData^.Modifiers = 2 then // minus
  4807.           begin
  4808.             FData^.Modifiers := FData^.Modifiers and not 2;
  4809.             case PIFPSType(FUsedTypes.GetItem(FData^.FData^.FType))^.BaseType of
  4810.               btU8: TbtU8((@FData^.FData^.Value[1])^) := - TbtU8((@FData^.FData^.Value[1])^);
  4811.               btS8: TbtS8((@FData^.FData^.Value[1])^) := - TbtS8((@FData^.FData^.Value[1])^);
  4812.               btU16: TbtU16((@FData^.FData^.Value[1])^) := - TbtU16((@FData^.FData^.Value[1])^);
  4813.               btS16: TbtS16((@FData^.FData^.Value[1])^) := - TbtS16((@FData^.FData^.Value[1])^);
  4814.               btU32: TbtU32((@FData^.FData^.Value[1])^) := - TbtU32((@FData^.FData^.Value[1])^);
  4815.               btS32: TbtS32((@FData^.FData^.Value[1])^) := - TbtS32((@FData^.FData^.Value[1])^);
  4816.               btSingle: TbtSingle((@FData^.FData^.Value[1])^) := - TbtSingle((@FData^.FData^.Value[1])^);
  4817.               btDouble: TbtDouble((@FData^.FData^.Value[1])^) := - TbtDouble((@FData^.FData^.Value[1])^);
  4818.               btExtended: TbtExtended((@FData^.FData^.Value[1])^) := - tbtExtended((@FData^.FData^.Value[1])^);
  4819.             end;
  4820.           end;
  4821.         end;
  4822.       end;
  4823.     begin
  4824.       SortItems := False;
  4825.       if Items.Count = 1 then
  4826.       begin
  4827.         p1 := Items.GetItem(0);
  4828.         ApplyModifiers(p1^.OutRec);
  4829.         SortItems := True;
  4830.         exit;
  4831.       end;
  4832.       for l := 0 to (Longint(Items.Count) div 2) do
  4833.       begin
  4834.         p1 := Items.GetItem(l shl 1);
  4835.         if p1^.OutRec^.FType = CVAL_Data then
  4836.           ApplyModifiers(P1^.OutRec);
  4837.       end;
  4838.       l := 0;
  4839.       while l < Longint(Items.Count - 1) div 2 do
  4840.       begin
  4841.         p := Items.GetItem((l shl 1) + 1);
  4842.         p1 := Items.GetItem((l shl 1));
  4843.         P2 := Items.GetItem((l shl 1) + 2);
  4844.         case p^.calcCmd of
  4845.           2, 3, 4, 5, 6, 7: {*}
  4846.             begin
  4847.               if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
  4848.                 CVAL_Data) then
  4849.               begin
  4850.                 if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
  4851.                   p^.calcCmd, P2^.OutRec^.DPos) then
  4852.                 begin
  4853.                   exit;
  4854.                 end;
  4855.                 Items.Delete((l shl 1) + 1);
  4856.                 Items.Delete((l shl 1) + 1);
  4857.                 DisposePValue(P2^.OutRec);
  4858.                 Dispose(P2);
  4859.                 Dispose(p);
  4860.               end
  4861.               else 
  4862.               begin
  4863.                 tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
  4864.                 if tt = Cardinal(-1) then
  4865.                 begin
  4866.                   MakeError('', ecTypeMismatch, '')^.Position :=
  4867.                     P2^.OutRec^.DPos;
  4868.                   exit;
  4869.                 end;
  4870.                 New(ptemp);
  4871.                 ptemp^.C := False;
  4872.                 New(ptemp^.OutRec);
  4873.                 ptemp^.OutRec^.Modifiers := 0;
  4874.                 ptemp^.OutRec^.FType := CVAL_Eval;
  4875.                 ptemp^.OutRec^.SubItems := TIfList.Create;
  4876.                 ptemp^.OutRec^.SubItems.Add(p1);
  4877.                 ptemp^.OutRec^.SubItems.Add(p);
  4878.                 ptemp^.OutRec^.SubItems.Add(P2);
  4879.                 ptemp^.OutRec^.frestype := tt;
  4880.                 Items.SetItem((l shl 1), ptemp);
  4881.                 Items.Delete((l shl 1) + 1);
  4882.                 Items.Delete((l shl 1) + 1);
  4883.               end;
  4884.             end;
  4885.         else
  4886.           Inc(l);
  4887.         end;
  4888.       end;
  4889.       l := 0;
  4890.       while l < Longint(Items.Count - 1) div 2 do
  4891.       begin
  4892.         p := Items.GetItem((l shl 1) + 1);
  4893.         p1 := Items.GetItem((l shl 1));
  4894.         P2 := Items.GetItem((l shl 1) + 2);
  4895.         case p^.calcCmd of
  4896.           0, 1, 8, 9:
  4897.             begin
  4898.               if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
  4899.                 CVAL_Data) then
  4900.               begin
  4901.                 if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
  4902.                   p^.calcCmd, P2^.OutRec^.DPos) then
  4903.                 begin
  4904.                   exit;
  4905.                 end;
  4906.                 Items.Delete((l shl 1) + 1);
  4907.                 Items.Delete((l shl 1) + 1);
  4908.                 DisposePValue(P2^.OutRec);
  4909.                 Dispose(P2);
  4910.                 Dispose(p);
  4911.               end
  4912.               else
  4913.               begin
  4914.                 tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
  4915.                 if tt = Cardinal(-1) then
  4916.                 begin
  4917.                   MakeError('', ecTypeMismatch, '')^.Position :=
  4918.                     P2^.OutRec^.DPos;
  4919.                   exit;
  4920.                 end;
  4921.                 New(ptemp);
  4922.                 ptemp^.C := False;
  4923.                 New(ptemp^.OutRec);
  4924.                 ptemp^.OutRec^.Modifiers := 0;
  4925.                 ptemp^.OutRec^.FType := CVAL_Eval;
  4926.                 ptemp^.OutRec^.SubItems := TIfList.Create;
  4927.                 ptemp^.OutRec^.SubItems.Add(p1);
  4928.                 ptemp^.OutRec^.SubItems.Add(p);
  4929.                 ptemp^.OutRec^.SubItems.Add(P2);
  4930.                 ptemp^.OutRec^.frestype := tt;
  4931.                 Items.SetItem((l shl 1), ptemp);
  4932.                 Items.Delete((l shl 1) + 1);
  4933.                 Items.Delete((l shl 1) + 1);
  4934.               end;
  4935.             end;
  4936.         else
  4937.           Inc(l);
  4938.         end;
  4939.       end;
  4940.       l := 0;
  4941.       while l < Longint(Items.Count - 1) div 2 do
  4942.       begin
  4943.         p := Items.GetItem((l shl 1) + 1);
  4944.         p1 := Items.GetItem((l shl 1));
  4945.         P2 := Items.GetItem((l shl 1) + 2);
  4946.         case p^.calcCmd of
  4947.           10, 11, 12, 13, 14, 15:
  4948.             begin
  4949.               if (p1^.OutRec^.FType <> CVAL_VarProcPtr) and (p2^.OutRec^.FType <> CVAL_VarProcPtr) and
  4950.               ((PIFPSType(FUsedTypes.GetItem(GetTypeNo(p1^.OutRec)))^.BaseType = btclass) or
  4951.               (PIFPSType(FUsedTypes.GetItem(GetTypeNo(p2^.OutRec)))^.BaseType = btclass)) and
  4952.               ((p^.CalcCmd = 14) or (p^.CalcCmd = 15)) then
  4953.               begin
  4954.                 tempt := FUsedTypes.GetItem(GetTypeNo(p1^.OutRec));
  4955.                 if not tempt^.Ex.CompareClass(GetTypeNo(p2^.OutRec), tt) then
  4956.                 begin
  4957.                   exit;
  4958.                 end;
  4959.                 new(ptemp);
  4960.                 ptemp^.C := False;
  4961.                 new(ptemp^.outrec);
  4962.                 with ptemp^.outrec^ do
  4963.                 begin
  4964.                   FType := CVAL_Proc;
  4965.                   if p^.calcCmd = 14 then
  4966.                     Modifiers := 1
  4967.                   else
  4968.                     Modifiers := 0;
  4969.                   ProcNo := tt;
  4970.                   Parameters := TIfList.Create;
  4971.                   new(pp);
  4972.                   if PIFPSProcedure(FProcs.GetItem(tt))^.Internal then
  4973.                     temps := PIFPSProcedure(FProcs.GetItem(tt))^.Decl
  4974.                   else
  4975.                     temps := PIFPSUsedRegProc(FProcs.GetItem(tt))^.rp^.Decl;
  4976.                   GRFW(temps);
  4977.                   pp^.InReg := p1^.OutRec;
  4978.                   pp^.OutReg := nil;
  4979.                   grfw(temps);
  4980.                   pp^.FType := StrToIntDef(grfw(temps), -1);
  4981.                   pp^.OutRegPos := p1^.OutRec^.DPos;
  4982.                   Parameters.add(pp);
  4983.                   new(pp);
  4984.                   pp^.InReg := p2^.OutRec;
  4985.                   pp^.OutReg := nil;
  4986.                   grfw(temps);
  4987.                   pp^.FType := StrToIntDef(grfw(temps), -1);
  4988.                   pp^.OutRegPos := p2^.OutRec^.DPos;
  4989.                   Parameters.add(pp);
  4990.                 end;
  4991.                 Items.SetItem((l shl 1), ptemp);
  4992.                 Items.Delete((l shl 1) + 1);
  4993.                 Items.Delete((l shl 1) + 1);
  4994.                 Dispose(P2);
  4995.                 dispose(p1);
  4996.                 Dispose(p);
  4997.               end else 
  4998.               if (p1^.OutRec^.FType = CVAL_Data) and (P2^.OutRec^.FType =
  4999.                 CVAL_Data) then
  5000.               begin
  5001.                 if not PreCalc(FUsedTypes, p1^.OutRec^.Modifiers, p1^.OutRec^.FData, p2^.OutRec^.Modifiers, P2^.OutRec^.FData,
  5002.                   p^.calcCmd, P2^.OutRec^.DPos) then
  5003.                 begin
  5004.                   exit;
  5005.                 end;
  5006.                 Items.Delete((l shl 1) + 1);
  5007.                 Items.Delete((l shl 1) + 1);
  5008.                 DisposePValue(P2^.OutRec);
  5009.                 Dispose(P2);
  5010.                 Dispose(p);
  5011.               end
  5012.               else
  5013.               begin
  5014.                 tt := GetResultType(p1^.OutRec, P2^.OutRec, p^.calcCmd);
  5015.                 if tt = Cardinal(-1) then
  5016.                 begin
  5017.                   MakeError('', ecTypeMismatch, '')^.Position :=
  5018.                     P2^.OutRec^.DPos;
  5019.                   exit;
  5020.                 end;
  5021.                 New(ptemp);
  5022.                 ptemp^.C := False;
  5023.                 New(ptemp^.OutRec);
  5024.                 ptemp^.OutRec^.Modifiers := 0;
  5025.                 ptemp^.OutRec^.FType := CVAL_Eval;
  5026.                 ptemp^.OutRec^.SubItems := TIfList.Create;
  5027.                 ptemp^.OutRec^.SubItems.Add(p1);
  5028.                 ptemp^.OutRec^.SubItems.Add(p);
  5029.                 ptemp^.OutRec^.SubItems.Add(P2);
  5030.                 ptemp^.OutRec^.frestype := tt;
  5031.                 Items.SetItem((l shl 1), ptemp);
  5032.                 Items.Delete((l shl 1) + 1);
  5033.                 Items.Delete((l shl 1) + 1);
  5034.               end;
  5035.             end;
  5036.         else
  5037.           Inc(l);
  5038.         end;
  5039.       end;
  5040.       SortItems := True;
  5041.     end;
  5042.   begin
  5043.     Items := TIfList.Create;
  5044.     calc := nil;
  5045.     while True do
  5046.     begin
  5047.       modifiers := 0;
  5048.       if Items.Count and 1 = 0 then
  5049.       begin
  5050.         if fParser.CurrTokenID = CSTII_Not then
  5051.         begin
  5052.           FParser.Next;
  5053.           modifiers := 1;
  5054.         end else // only allow one of these two
  5055.         if fParser.CurrTokenID = CSTI_Minus then
  5056.         begin
  5057.           FParser.Next;
  5058.           modifiers := 2;
  5059.         end;
  5060.         case FParser.CurrTokenId of
  5061.           CSTI_AddressOf:
  5062.             begin
  5063.               if (Modifiers <> 0) then
  5064.               begin
  5065.                 MakeError('', ecTypeMismatch, '');
  5066.                 Cleanup;
  5067.                 exit;
  5068.               end;
  5069.               FParser.Next;
  5070.               if FParser.CurrTokenId <> CSTI_Identifier then
  5071.               begin
  5072.                 MakeError('', ecIdentifierExpected, '');
  5073.                 Cleanup;
  5074.                 Exit;
  5075.               end;
  5076.               L := FindProc(FParser.GetToken);
  5077.               if L = Cardinal(-1) then
  5078.               begin
  5079.                 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  5080.                 Cleanup;
  5081.                 Exit;
  5082.               end;
  5083.               PIFPSProcedure(FProcs.GetItem(L))^.FExport := 2;
  5084.               FParser.Next;
  5085.               New(v);
  5086.               v^.FType := CVAL_VarProcPtr;
  5087.               v^.Modifiers := 0;
  5088.               v^.DPos := FParser.CurrTokenPos;
  5089.               v^.VProcNo := L;
  5090.               New(p);
  5091.               p^.C := False;
  5092.               p^.OutRec := v;
  5093.               Items.Add(p);
  5094.             end;
  5095.           CSTI_OpenBlock:
  5096.             begin
  5097.               if (Modifiers <> 0) then
  5098.               begin
  5099.                 MakeError('', ecTypeMismatch, '');
  5100.                 Cleanup;
  5101.                 exit;
  5102.               end;
  5103.               New(v);
  5104.               v^.FType := CVAL_Array;
  5105.               v^.Modifiers := 0;
  5106.               v^.DPos := FParser.CurrTokenPos;
  5107.               v^.ArrayItems := TIfList.Create;
  5108.               New(p);
  5109.               p^.C := False;
  5110.               p^.OutRec := v;
  5111.               Items.Add(p);
  5112.               FParser.Next;
  5113.               while FParser.CurrTokenId <> CSTI_CloseBlock do
  5114.               begin
  5115.                 vc := calc(CSTI_CloseBlock);
  5116.                 if vc = nil  then
  5117.                 begin
  5118.                   Cleanup;
  5119.                   exit;
  5120.                 end; {if}
  5121.                 if vc^.FType = CVAL_Array then
  5122.                 begin
  5123.                   MakeError('', ecIdentifierExpected, '')^.Position := v^.DPos;
  5124.                   Cleanup;
  5125.                   Exit;
  5126.                 end;
  5127.                 v^.ArrayItems.Add(vc);
  5128.                 if FParser.CurrTokenId = CSTI_Comma then
  5129.                 begin
  5130.                   FParser.Next;
  5131.                   Continue;
  5132.                 end;
  5133.               end; {while}
  5134.               FParser.Next;
  5135.             end; {csti_openblock}
  5136.           CSTI_EOF:
  5137.             begin
  5138.               MakeError('', ecUnexpectedEndOfFile, '');
  5139.               Cleanup;
  5140.               exit;
  5141.             end;
  5142.           CSTI_OpenRound:
  5143.             begin
  5144.               FParser.Next;
  5145.               v := calc(CSTI_CloseRound);
  5146.               if v = nil then
  5147.               begin
  5148.                 Cleanup;
  5149.                 exit;
  5150.               end;
  5151.               if FParser.CurrTokenId <> CSTI_CloseRound then
  5152.               begin
  5153.                 DisposePValue(v);
  5154.                 MakeError('', ecCloseRoundExpected, '');
  5155.                 Cleanup;
  5156.                 exit;
  5157.               end;
  5158.               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
  5159.               begin
  5160.                 DisposePValue(v);
  5161.                 MakeError('', ecTypeMismatch, '');
  5162.                 Cleanup;
  5163.                 exit;
  5164.               end;
  5165.  
  5166.               New(p);
  5167.               p^.C := False;
  5168.               if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
  5169.               begin
  5170.                 v^.modifiers := v^.modifiers xor (modifiers and 1);
  5171.               end;
  5172.               if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
  5173.               begin
  5174.                 v^.modifiers := v^.modifiers xor (modifiers and 2);
  5175.               end;
  5176.               p^.OutRec := v;
  5177.               Items.Add(p);
  5178.  
  5179.               FParser.Next;
  5180.             end;
  5181.           CSTII_Chr:
  5182.             begin
  5183.               if modifiers <> 0then
  5184.               begin
  5185.                 MakeError('', ecTypeMismatch, '');
  5186.                 Cleanup;
  5187.                 exit;
  5188.               end;
  5189.               FParser.Next;
  5190.               if FParser.CurrTokenID <> CSTI_OpenRound then
  5191.               begin
  5192.                 MakeError('', ecOpenRoundExpected, '');
  5193.                 Cleanup;
  5194.                 exit;
  5195.               end;
  5196.               FParser.Next;
  5197.               v := calc(CSTI_CloseRound);
  5198.               if v = nil then
  5199.               begin
  5200.                 Cleanup;
  5201.                 exit;
  5202.               end;
  5203.               if FParser.CurrTokenId <> CSTI_CloseRound then
  5204.               begin
  5205.                 DisposePValue(v);
  5206.                 MakeError('', ecCloseRoundExpected, '');
  5207.                 Cleanup;
  5208.                 exit;
  5209.               end;
  5210.               if not IsIntType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(v)))^.BaseType) then
  5211.               begin
  5212.                 DisposePValue(v);
  5213.                 MakeError('', ecTypeMismatch, '');
  5214.                 Cleanup;
  5215.                 exit;
  5216.               end;
  5217.               New(p);
  5218.               p^.c := False;
  5219.               New(p^.OutRec);
  5220.               p^.OutRec^.FType := CVAL_Cast;
  5221.               p^.OutRec^.Modifiers := 0;
  5222.               p^.OutRec^.DPos := FParser.CurrTokenPos;
  5223.               p^.OutRec^.Input := v;
  5224.               p^.OutRec^.NewTypeNo := GetType(btChar);
  5225.               Items.Add(p);
  5226.               FParser.Next;
  5227.             end;
  5228.           CSTII_Ord:
  5229.             begin
  5230.               FParser.Next;
  5231.               if FParser.CurrTokenID <> CSTI_OpenRound then
  5232.               begin
  5233.                 MakeError('', ecOpenRoundExpected, '');
  5234.                 Cleanup;
  5235.                 exit;
  5236.               end;
  5237.               FParser.Next;
  5238.               v := calc(CSTI_CloseRound);
  5239.               if v = nil then
  5240.               begin
  5241.                 Cleanup;
  5242.                 exit;
  5243.               end;
  5244.               if FParser.CurrTokenId <> CSTI_CloseRound then
  5245.               begin
  5246.                 DisposePValue(v);
  5247.                 MakeError('', ecCloseRoundExpected, '');
  5248.                 Cleanup;
  5249.                 exit;
  5250.               end;
  5251.               Pt := FUsedTypes.GetItem(GetTypeNo(v));
  5252.               if (pt^.BaseType = btString) and (v^.FType = CVAL_Data) and (Length(v^.FData.Value) =1) then
  5253.               begin
  5254.                 v^.FData.FType := GetType(btChar);
  5255.                 Pt := FUsedTypes.GetItem(GetTypeNo(v));
  5256.               end;
  5257.               New(p);
  5258.               p^.c := False;
  5259.               if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
  5260.               begin
  5261.                 v^.modifiers := v^.modifiers xor (modifiers and 1);
  5262.               end;
  5263.               if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
  5264.               begin
  5265.                 v^.modifiers := v^.modifiers xor (modifiers and 2);
  5266.               end;
  5267.               New(p^.OutRec);
  5268.               p^.OutRec^.FType := CVAL_Cast;
  5269.               p^.OutRec^.Modifiers := 0;
  5270.               p^.OutRec^.DPos := FParser.CurrTokenPos;
  5271.               p^.OutRec^.Input := v;
  5272.               if (pt^.BaseType = btChar) then
  5273.               begin
  5274.                 p^.OutRec^.NewTypeNo := GetType(btU8);
  5275.               end else if (pt^.BaseType = btEnum) then
  5276.               begin
  5277.                 if Longint(pt^.Ext) <= 256 then
  5278.                   p^.OutRec^.NewTypeNo := GetType(btU8)
  5279.                 else if Longint(pt^.Ext) <= 65536 then
  5280.                   p^.OutRec^.NewTypeNo := GetType(btU16)
  5281.                 else
  5282.                   p^.OutRec^.NewTypeNo := GetType(btU32);
  5283.               end else
  5284.               begin
  5285.                 Dispose(P^.OutRec);
  5286.                 Dispose(p);
  5287.                 DisposePValue(v);
  5288.                 MakeError('', ecTypeMismatch, '');
  5289.                 Cleanup;
  5290.                 exit;
  5291.               end;
  5292.               Items.Add(p);
  5293.               FParser.Next;
  5294.             end;
  5295.          CSTI_String, CSTI_Char:
  5296.             begin
  5297.               if (Modifiers <> 0) then
  5298.               begin
  5299.                 MakeError('', ecTypeMismatch, '');
  5300.                 Cleanup;
  5301.                 exit;
  5302.               end;
  5303.               New(v);
  5304.               v^.FType := CVAL_Data;
  5305.               v^.DPos := FParser.CurrTokenPos;
  5306.               v^.FData := ReadString;
  5307.               v^.Modifiers := modifiers;
  5308.               v^.RecField := nil;
  5309.               New(p);
  5310.               p^.C := False;
  5311.               p^.OutRec := v;
  5312.               Items.Add(p);
  5313.  
  5314.             end;
  5315.           CSTI_HexInt, CSTI_Integer:
  5316.             begin
  5317.               New(v);
  5318.               v^.FType := CVAL_Data;
  5319.               v^.DPos := FParser.CurrTokenPos;
  5320.               v^.FData := ReadInteger(FParser.GetToken);
  5321.               v^.Modifiers := modifiers;
  5322.               New(p);
  5323.               p^.C := False;
  5324.               p^.OutRec := v;
  5325.               Items.Add(p);
  5326.  
  5327.               FParser.Next;
  5328.             end;
  5329.           CSTI_Real:
  5330.             begin
  5331.               if ((Modifiers and 1) <> 0)  then
  5332.               begin
  5333.                 MakeError('', ecTypeMismatch, '');
  5334.                 Cleanup;
  5335.                 exit;
  5336.               end;
  5337.               New(v);
  5338.               v^.FType := CVAL_Data;
  5339.               v^.DPos := FParser.CurrTokenPos;
  5340.               v^.FData := ReadReal(FParser.GetToken);
  5341.               v^.Modifiers := modifiers;
  5342.               New(p);
  5343.               p^.C := False;
  5344.               p^.OutRec := v;
  5345.               Items.Add(p);
  5346.               FParser.Next;
  5347.             end;
  5348.           CSTI_Identifier:
  5349.             begin
  5350.               if FParser.GetToken = 'LOW' then
  5351.                 c := 1
  5352.               else
  5353.                 c := 0;
  5354.               if (FParser.GetToken = 'HIGH') or (c <> 0) then
  5355.               begin
  5356.                 FParser.Next;
  5357.                 if FParser.CurrTokenId <> CSTI_OpenRound then
  5358.                 begin
  5359.                   MakeError('', ecOpenRoundExpected, '');
  5360.                   Cleanup;
  5361.                   Exit;
  5362.                 end;
  5363.                 FParser.Next;
  5364.                 L := FindType(FParser.GetToken);
  5365.                 if L = Cardinal(-1) then
  5366.                 begin
  5367.                   v := GetIdentifier(1);
  5368.                   if v = nil then
  5369.                   begin
  5370.                     Cleanup;
  5371.                     Exit;
  5372.                   end;
  5373.                   L := GetTypeNo(v);
  5374.                   DisposePValue(v);
  5375.                 end else FParser.Next;
  5376.                 pt := FAvailableTypes.GetItem(L);
  5377.                 if pt^.BaseType <> btEnum then
  5378.                 begin
  5379.                   MakeError('', ecTypeMismatch, '');
  5380.                   Cleanup;
  5381.                   Exit;
  5382.                 end;
  5383.                 New(v);
  5384.                 new(v^.FData);
  5385.                 v^.FType := CVAL_Data;
  5386.                 v^.DPos := FParser.CurrTokenPos;
  5387.                 v^.FData^.FType := AT2UT(L);
  5388.                 if c = 1 then
  5389.                   v^.FData^.Value := #0#0#0#0
  5390.                 else
  5391.                   v^.FData^.Value := TransCardinalToStr(Cardinal(pt^.Ex));
  5392.                 v^.Modifiers := modifiers;
  5393.                 New(p);
  5394.                 p^.C := False;
  5395.                 p^.OutRec := v;
  5396.                 Items.Add(p);
  5397.                 if FParser.CurrTokenId <> CSTI_CloseRound then
  5398.                 begin
  5399.                   MakeError('', ecCloseRoundExpected, '');
  5400.                   Cleanup;
  5401.                   Exit;
  5402.                 end;
  5403.               end else if FParser.GetToken = 'ASSIGNED' then
  5404.               begin
  5405.                 if (Modifiers and 2) <> 0 then
  5406.                 begin
  5407.                   MakeError('', ecTypeMismatch, '');
  5408.                   cleanup;
  5409.                   exit;
  5410.                 end;
  5411.                 FParser.Next;
  5412.                 if FParser.CurrTokenId <> CSTI_OpenRound then
  5413.                 begin
  5414.                   MakeError('', ecOpenRoundExpected, '');
  5415.                   Cleanup;
  5416.                   Exit;
  5417.                 end;
  5418.                 FParser.Next;
  5419.                 vc := calc(CSTI_CloseRound);
  5420.                 if vc = nil then
  5421.                 begin
  5422.                   Cleanup;
  5423.                   Exit;
  5424.                 end;
  5425.                 Pt := FUsedTypes.GetItem(GetTypeNo(vc));
  5426.                 if (pt^.BaseType <> btProcPtr) and (pt^.BaseType <> btClass) and (pt^.BaseType <> btPChar) and (pt^.BaseType <> btString) then
  5427.                 begin
  5428.                   DisposePValue(vc);
  5429.                   MakeError('', ecTypeMismatch, '');
  5430.                   Cleanup;
  5431.                   exit;
  5432.                 end;
  5433.                 if FParser.CurrTokenId <> CSTI_CloseRound then
  5434.                 begin
  5435.                   MakeError('', ecCloseRoundExpected, '');
  5436.                   Cleanup;
  5437.                   Exit;
  5438.                 end;
  5439.                 FParser.Next;
  5440.                 new(v);
  5441.                 V^.FType := CVAL_Proc;
  5442.                 v^.Modifiers := 0;
  5443.                 v^.ProcNo := FindProc('!ASSIGNED');
  5444.                 V^.Parameters :=TIfList.Create;
  5445.                 new(x);
  5446.                 X^.InReg := vc;
  5447.                 x^.OutReg := nil;
  5448.                 x^.FType := GetTypeNo(vc);
  5449.                 X^.OutRegPos := FParser.CurrTokenPos;
  5450.                 v^.Parameters.Add(x);
  5451.                 new(p);
  5452.                 p^.C := False;
  5453.                 p^.OutRec := v;
  5454.                 Items.Add(p);
  5455.               end else if FParser.GetToken = 'NIL' then
  5456.               begin
  5457.                 if modifiers <> 0 then
  5458.                 begin
  5459.                   MakeError('', ecTypeMismatch, '');
  5460.                   cleanup;
  5461.                   exit;
  5462.                 end;
  5463.                 New(v);
  5464.                 v^.FType := CVAL_Nil;
  5465.                 v^.DPos := FParser.CurrTokenPos;
  5466.                 v^.Modifiers := 0;
  5467.                 New(p);
  5468.                 p^.C := False;
  5469.                 p^.OutRec := v;
  5470.                 Items.Add(p);
  5471.                 FParser.Next;
  5472.               end else begin
  5473.                 v := GetIdentifier(0);
  5474.                 if v = nil then
  5475.                 begin
  5476.                   Cleanup;
  5477.                   exit;
  5478.                 end
  5479.                 else if (GetTypeNo(v) = Cardinal(-1)) then
  5480.                 begin
  5481.                   MakeError('', ecTypeMismatch, '')^.Position := v^.DPos;
  5482.                   DisposePValue(v);
  5483.                   Cleanup;
  5484.                   Exit;
  5485.                 end else
  5486.                 begin
  5487.                   if ((Modifiers and 1) <> 0) and (not IsIntBoolType(GetTypeNo(v))) or ((Modifiers
  5488.                   and 2) <> 0) and (not IsIntRealType(PIFPSType(
  5489.                   FUsedTypes.GetItem(GetTypeNo(v)))^.BaseType))
  5490.                   then
  5491.                   begin
  5492.                     DisposePValue(v);
  5493.                     MakeError('', ecTypeMismatch, '');
  5494.                     Cleanup;
  5495.                     exit;
  5496.                   end;
  5497.                   v^.Modifiers := v^.modifiers or modifiers;
  5498.                   New(p);
  5499.                   p^.C := False;
  5500.                   p^.OutRec := v;
  5501.                   Items.Add(p);
  5502.                 end;
  5503.               end;
  5504.             end;
  5505.         else
  5506.           begin
  5507.             MakeError('', ecSyntaxError, '');
  5508.             Cleanup;
  5509.             exit;
  5510.           end;
  5511.         end; {case}
  5512.       end
  5513.       else {Items.Count and 1 = 1}
  5514.       begin
  5515.         if FParser.CurrTokenId = endOn then
  5516.           break;
  5517.         C := 0;
  5518.         case FParser.CurrTokenId of
  5519.           CSTI_EOF:
  5520.             begin
  5521.               MakeError('', ecUnexpectedEndOfFile, '');
  5522.               Cleanup;
  5523.               exit;
  5524.             end;
  5525.           CSTI_CloseBlock,
  5526.             CSTII_To,
  5527.             CSTI_CloseRound,
  5528.             CSTI_Semicolon,
  5529.             CSTII_Else,
  5530.             CSTII_End,
  5531.             CSTI_Comma: break;
  5532.           CSTI_Plus: ;
  5533.           CSTI_Minus: C := 1;
  5534.           CSTI_Multiply: C := 2;
  5535.           CSTII_div, CSTI_Divide: C := 3;
  5536.           CSTII_mod: C := 4;
  5537.           CSTII_shl: C := 5;
  5538.           CSTII_shr: C := 6;
  5539.           CSTII_and: C := 7;
  5540.           CSTII_or: C := 8;
  5541.           CSTII_xor: C := 9;
  5542.           CSTI_GreaterEqual: C := 10;
  5543.           CSTI_LessEqual: C := 11;
  5544.           CSTI_Greater: C := 12;
  5545.           CSTI_Less: C := 13;
  5546.           CSTI_NotEqual: C := 14;
  5547.           CSTI_Equal: C := 15;
  5548.         else
  5549.           begin
  5550.             MakeError('', ecSyntaxError, '');
  5551.             Cleanup;
  5552.             exit;
  5553.           end;
  5554.         end; {case}
  5555.         New(p);
  5556.         p^.C := True;
  5557.         p^.calcCmd := C;
  5558.         Items.Add(p);
  5559.         FParser.Next;
  5560.       end;
  5561.     end;
  5562.     if not SortItems then
  5563.     begin
  5564.       Cleanup;
  5565.       exit;
  5566.     end;
  5567.     if Items.Count = 1 then      
  5568.     begin
  5569.       p := Items.GetItem(0);
  5570.       Result := p^.OutRec;
  5571.       Dispose(p);
  5572.       Items.Free;
  5573.     end
  5574.     else
  5575.     begin
  5576.       New(Result);
  5577.       Result^.FType := CVAL_Eval;
  5578.       Result^.DPos := 0;
  5579.       result^.Modifiers := 0;
  5580.       Result^.SubItems := Items;
  5581.     end;
  5582.   end;
  5583.  
  5584.   function ReadParameters(ProcNo: Cardinal; fSelf: PIFPSValue): PIFPSValue;
  5585.   var
  5586.     Decl: string;
  5587.     p: PParam;
  5588.     Tmp: PIFPSValue;
  5589.     FType: Cardinal;
  5590.     modifier: Char;
  5591.  
  5592.     function IsVarInCompatible(ft1, ft2: PIFPSType): Boolean;
  5593.     begin
  5594.       ft1 := GetTypeCopyLink(ft1);
  5595.       ft2 := GetTypeCopyLink(ft2);
  5596.       Result := (ft1 <> ft2);
  5597.     end;
  5598.  
  5599.     function getfc(const s: string): Char;
  5600.     begin
  5601.       if Length(s) > 0 then
  5602.         Result := s[1]
  5603.       else
  5604.         Result := #0
  5605.     end;
  5606.   begin
  5607.     if PIFPSProcedure(FProcs.GetItem(ProcNo))^.Internal then
  5608.       Decl := PIFPSProcedure(FProcs.GetItem(ProcNo))^.Decl
  5609.     else
  5610.       Decl := PIFPSUsedRegProc(FProcs.GetItem(ProcNo))^.RP^.Decl;
  5611.     GRFW(Decl);
  5612.     New(Result);
  5613.     Result^.FType := CVAL_Proc;
  5614.     Result^.DPos := FParser.CurrTokenPos;
  5615.     Result^.Modifiers := 0;
  5616.     Result^.ProcNo := ProcNo;
  5617.     Result^.Parameters := TIfList.Create;
  5618.     if FSelf <> nil then begin
  5619.       new(p);
  5620.       p^.InReg := fself;
  5621.       p^.OutReg := nil;
  5622.       p^.FType := GetTypeNo(fself);
  5623.       Result^.Parameters.Add(p);
  5624.     end;
  5625.     if Length(Decl) = 0 then
  5626.     begin
  5627.       if FParser.CurrTokenId = CSTI_OpenRound then
  5628.       begin
  5629.         FParser.Next;
  5630.         if FParser.CurrTokenId <> CSTI_CloseRound then
  5631.         begin
  5632.           DisposePValue(Result);
  5633.           Result := nil;
  5634.           MakeError('', ecCloseRoundExpected, '');
  5635.           exit;
  5636.         end;
  5637.         FParser.Next;
  5638.       end;
  5639.     end
  5640.     else
  5641.     begin
  5642.       if FParser.CurrTokenId <> CSTI_OpenRound then
  5643.       begin
  5644.         DisposePValue(Result);
  5645.         MakeError('', ecOpenRoundExpected, '');
  5646.         Result := nil;
  5647.         exit;
  5648.       end;
  5649.       FParser.Next;
  5650.       while Length(Decl) > 0 do
  5651.       begin
  5652.         modifier := getfc(GRFW(Decl));
  5653.         FType := StrToInt(GRFW(Decl));
  5654.         if (modifier = '@') then
  5655.         begin
  5656.           Tmp := calc(CSTI_CloseRound);
  5657.           if Tmp = nil then
  5658.           begin
  5659.             DisposePValue(Result);
  5660.             Result := nil;
  5661.             exit;
  5662.           end;
  5663.         end
  5664.         else
  5665.         begin
  5666.           if FParser.CurrTokenId <> CSTI_Identifier then
  5667.           begin
  5668.             MakeError('', ecIdentifierExpected, '');
  5669.             DisposePValue(Result);
  5670.             Result := nil;
  5671.             exit;
  5672.           end;
  5673.           Tmp := GetIdentifier(1); // only variables
  5674.           if Tmp = nil then
  5675.           begin
  5676.             DisposePValue(Result);
  5677.             Result := nil;
  5678.             exit;
  5679.           end;
  5680.           if ((FType = Cardinal(-1)) or (PIFPSType(FUsedTypes.GetItem(GetTypeNo(Tmp)))^.BaseType = btArray)) then
  5681.           begin
  5682.             {nothing}
  5683.           end else if IsVarInCompatible(FUsedTypes.GetItem(FType), FUsedTypes.GetItem(GetTypeNo(Tmp))) then
  5684.           begin
  5685.             MakeError('', ecTypeMismatch, '');
  5686.             DisposePValue(Result);
  5687.             DisposePValue(Tmp);
  5688.             Result := nil;
  5689.             exit;
  5690.           end;
  5691.           Tmp^.FType := Tmp^.FType + CVAL_PushAddr;
  5692.         end;
  5693.         New(p);
  5694.         p^.InReg := Tmp;
  5695.         p^.OutReg := nil;
  5696.         p^.FType := FType;
  5697.         Result.Parameters.Add(p);
  5698.         if Length(Decl) = 0 then
  5699.         begin
  5700.           if FParser.CurrTokenId <> CSTI_CloseRound then
  5701.           begin
  5702.             MakeError('', ecCloseRoundExpected, '');
  5703.             DisposePValue(Result);
  5704.             Result := nil;
  5705.             exit;
  5706.           end; {if}
  5707.           FParser.Next;
  5708.         end
  5709.         else
  5710.         begin
  5711.           if FParser.CurrTokenId <> CSTI_Comma then
  5712.           begin
  5713.             MakeError('', ecCommaExpected, '');
  5714.             DisposePValue(Result);
  5715.             Result := nil;
  5716.             exit;
  5717.           end; {if}
  5718.           FParser.Next;
  5719.         end; {else if}
  5720.       end; {for}
  5721.     end; {else if}
  5722.   end;
  5723.  
  5724.  
  5725.   function WriteCalculation(InData, OutReg: PIFPSValue): Boolean;
  5726.   var
  5727.     l: Longint;
  5728.     tmpcalc, p, PT, pt2: PIFPSValue;
  5729.     bmodsave: byte;
  5730.     C: Byte;
  5731.  
  5732.     function CheckOutreg(Where, Outreg: PIFPSValue): Boolean;
  5733.     var
  5734.       i: Longint;
  5735.       P: PCalc_Item;
  5736.     begin
  5737.       case Where^.FType of
  5738.         CVAL_Cast:
  5739.           begin
  5740.             if CheckOutreg(Where^.Input, Outreg) then
  5741.             begin
  5742.               Result := True;
  5743.               exit;
  5744.             end;
  5745.           end;
  5746.         CVAL_Addr, CVAL_PushAddr, CVAL_AllocatedStackReg:
  5747.           begin
  5748.             if SameReg(Where, OutReg) then
  5749.             begin
  5750.               Result := True;
  5751.               exit;
  5752.             end;
  5753.           end;
  5754.         CVAL_Eval:
  5755.           for i := 0 to Where.SubItems.Count -1 do
  5756.           begin
  5757.             p := Where.SubItems.GetItem(i);
  5758.             if not p^.C then
  5759.               if CheckOutreg(p^.OutRec, Outreg) then
  5760.               begin
  5761.                 Result := True;
  5762.                 Exit;
  5763.               end;
  5764.           end;
  5765.         CVAL_Proc, CVAL_VarProc:
  5766.           for i := 0 to Where^.Parameters.Count -1 do
  5767.           begin
  5768.             if CheckOutreg(PParam(Where^.Parameters.GetItem(i))^.InReg, Outreg) then
  5769.             begin
  5770.               Result := True;
  5771.               Exit;
  5772.             end;
  5773.           end;
  5774.         CVAL_ClassProcCall,
  5775.         CVAL_ClassMethodCall,
  5776.         CVAL_ClassPropertyCallSet,
  5777.         CVAL_ClassPropertyCallGet:
  5778.           begin
  5779.             if CheckOutreg(Where^.Self, Outreg) then
  5780.             begin
  5781.               Result := True;
  5782.               exit;
  5783.             end;
  5784.             for i := 0 to Where^.Params.Count -1 do
  5785.             begin
  5786.               if CheckOutreg(PParam(Where^.Params.GetItem(i))^.InReg, Outreg) then
  5787.               begin
  5788.                 Result := True;
  5789.                 Exit;
  5790.               end;
  5791.             end;
  5792.  
  5793.           end;
  5794.       end;
  5795.       Result := False;;
  5796.     end;
  5797.   begin
  5798.     if indata^.FType = CVAL_Cast then
  5799.     begin
  5800.       if GetTypeNo(OutReg) = Indata^.NewTypeNo then
  5801.       begin
  5802.         OutReg^.Modifiers := outreg^.modifiers or 4;
  5803.         Result := WriteCalculation(Indata^.Input, OutReg);
  5804.         OutReg^.Modifiers := outreg^.modifiers and not 4;
  5805.         Exit;
  5806.       end else begin
  5807.         p := AllocStackReg(Indata^.NewTypeNo);
  5808.         p^.DPos := InData^.DPos;
  5809.         p^.Modifiers := p^.modifiers or 4;
  5810.         if not WriteCalculation(Indata^.Input, p) then
  5811.         begin
  5812.           DisposeStackReg(p);
  5813.           Result := False;
  5814.           Exit;
  5815.         end;
  5816.         Result := WriteCalculation(p, outreg);
  5817.         DisposeStackReg(p);
  5818.         exit;
  5819.       end;
  5820.     end else
  5821.     if InData^.FType = CVAL_VarProcPtr then
  5822.     begin
  5823.       if not CheckCompatProc(GetTypeNo(OutReg), InData^.VProcNo) then
  5824.       begin
  5825.         MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
  5826.         Result := False;
  5827.         exit;
  5828.       end;
  5829.       New(p);
  5830.       p^.FType := CVAL_Data;
  5831.       p^.Modifiers := 0;
  5832.       p^.DPos := Indata^.DPos;
  5833.       New(p^.FData);
  5834.       p^.FData.FType := GetTypeNo(OutReg);
  5835.       p^.FData.Value := mi2s(Indata^.VProcNo);
  5836.       WriteCommand(CM_A);
  5837.       WriteOutRec( OutReg, False);
  5838.       WriteOutRec(p, True);
  5839.       DisposePValue(p);
  5840.     end else
  5841.     if (InData^.FType = CVAL_Proc) or (InData^.FType = CVAL_VarProc) then
  5842.     begin
  5843.       if not CheckCompatType(OutReg, InData) then
  5844.       begin
  5845.         MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
  5846.         Result := False;
  5847.         exit;
  5848.       end;
  5849.  
  5850.       if InData^.FType = CVAL_VarProc then
  5851.       begin
  5852.         if not ProcessVarFunction(InData^.Modifiers, InData^._ProcNo, InData^._Parameters, OutReg) then
  5853.         begin
  5854.           Result := False;
  5855.           exit;
  5856.         end;
  5857.       end else begin
  5858.         if not ProcessFunction(InData^.Modifiers, InData^.ProcNo, InData^.Parameters, OutReg) then
  5859.         begin
  5860.           Result := False;
  5861.           exit;
  5862.         end;
  5863.       end;
  5864.       if Indata^.Modifiers = 1 then begin
  5865.         PreWriteOutRec(OutReg, Cardinal(-1));
  5866.         WriteCommand(cm_bn);
  5867.         WriteOutRec(OutReg, False);
  5868.         AfterWriteOutRec(OutReg);
  5869.       end else if Indata^.Modifiers = 2 then begin
  5870.         PreWriteOutRec(OutReg, Cardinal(-1));
  5871.         WriteCommand(cm_vm);
  5872.         WriteOutRec(OutReg, False);
  5873.         AfterWriteOutRec(OutReg);
  5874.       end;
  5875.     end
  5876.     else if InData^.FType = CVAL_Eval then
  5877.     begin
  5878.       if CheckOutreg(InData, OutReg) then
  5879.       begin
  5880.         tmpcalc := AllocStackReg(GetTypeNo(OutReg));
  5881.         if not WriteCalculation(InData, TmpCalc) then
  5882.         begin
  5883.           DisposeStackReg(tmpcalc);
  5884.           Result := False;
  5885.           exit;
  5886.         end;
  5887.         if not WriteCalculation(TmpCalc, OutReg) then
  5888.         begin
  5889.           DisposeStackReg(tmpcalc);
  5890.           Result := False;
  5891.           exit;
  5892.         end;
  5893.         DisposeStackReg(tmpcalc);
  5894.       end else begin
  5895.         bmodsave := Indata^.Modifiers and 15;
  5896.         p := PCalc_Item(InData^.SubItems.GetItem(0))^.OutRec;
  5897.         C := PCalc_Item(InData^.SubItems.GetItem(1))^.calcCmd;
  5898.         if c >= 10 then
  5899.         begin
  5900.           tmpcalc := p;
  5901.         end else begin
  5902.           if not WriteCalculation(p, OutReg) then
  5903.           begin
  5904.             Result := False;
  5905.             exit;
  5906.           end; {if}
  5907.           tmpcalc := nil;
  5908.         end;
  5909.         for l := 0 to ((InData^.SubItems.Count - 1) div 2) - 1 do
  5910.         begin
  5911.           p := PCalc_Item(InData^.SubItems.GetItem((l shl 1) + 2))^.OutRec;
  5912.           C := PCalc_Item(InData^.SubItems.GetItem((l shl 1) + 1))^.calcCmd;
  5913.           if C < 10 then
  5914.           begin
  5915.             if p^.FType = CVAL_Eval then
  5916.             begin
  5917.               PT := AllocStackReg(GetTypeNo(OutReg));
  5918.               if not WriteCalculation(p, PT) then
  5919.               begin
  5920.                 DisposeStackReg(PT);
  5921.                 Result := False;
  5922.                 exit;
  5923.               end; {if}
  5924.               PreWriteOutRec( OutReg, Cardinal(-1)); {error}
  5925.               WriteCommand(CM_CA);
  5926.               WriteData(C, 1);
  5927.               if not WriteOutRec(OutReg, False) then
  5928.               begin
  5929.                 MakeError('', ecInternalError, '00001');
  5930.                 DisposeStackReg(pt);
  5931.                 Result := False;
  5932.                 exit;
  5933.               end; {if}
  5934.               if not WriteOutRec(PT, True) then
  5935.               begin
  5936.                 MakeError('', ecInternalError, '00002');
  5937.                 DisposeStackReg(pt);
  5938.                 Result := False;
  5939.                 exit;
  5940.               end; {if}
  5941.               AfterWriteOutRec(Pt);
  5942.               DisposeStackReg(PT);
  5943.             end
  5944.             else if (p^.FType = CVAL_Proc) or (P^.Ftype = CVAL_VarProc) or (p^.FType = CVAL_Cast) then
  5945.             begin
  5946.               PT := AllocStackReg(GetTypeNo(OutReg));
  5947.               if not WriteCalculation(p, Pt) then
  5948.               begin
  5949.                 DisposeStackReg(Pt);
  5950.                 Result := False;
  5951.                 exit;
  5952.               end;
  5953.               PreWriteOutRec(OutReg, Cardinal(-1)); {error}
  5954.               PreWriteOutRec(pt, Cardinal(-1)); {error}
  5955.               WriteCommand(CM_CA);
  5956.               WriteData(C, 1);
  5957.               if not WriteOutRec(OutReg, False) then
  5958.               begin
  5959.                 MakeError('', ecInternalError, '00005');
  5960.                 Result := False;
  5961.                 exit;
  5962.               end; {if}
  5963.               if not WriteOutRec(pt, True) then
  5964.               begin
  5965.                 MakeError('', ecInternalError, '00006');
  5966.                 Result := False;
  5967.                 exit;
  5968.               end; {if}
  5969.               AfterWriteOutRec(p);
  5970.               AfterWriteOutRec(OutReg);
  5971.               DisposeStackReg(Pt);
  5972.             end else begin
  5973.               PreWriteOutRec(OutReg, Cardinal(-1)); {error}
  5974.               PreWriteOutRec(p, GetTypeNo(Outreg)); {error}
  5975.               WriteCommand(CM_CA);
  5976.               WriteData(C, 1);
  5977.               if not WriteOutRec(OutReg, False) then
  5978.               begin
  5979.                 MakeError('', ecInternalError, '00005');
  5980.                 Result := False;
  5981.                 exit;
  5982.               end; {if}
  5983.               if not WriteOutRec(p, True) then
  5984.               begin
  5985.                 MakeError('', ecInternalError, '00006');
  5986.                 Result := False;
  5987.                 exit;
  5988.               end; {if}
  5989.               AfterWriteOutRec(p);
  5990.               AfterWriteOutRec(OutReg);
  5991.  
  5992.             end; {else if}
  5993.           end
  5994.           else
  5995.           begin
  5996.             C := C - 10;
  5997.             if p^.FType = CVAL_Eval then
  5998.             begin
  5999.  
  6000.               PT := AllocStackReg(p^.frestype);
  6001.               if not WriteCalculation(p, PT) then
  6002.               begin
  6003.                 DisposeStackReg(PT);
  6004.                 Result := False;
  6005.                 exit;
  6006.               end; {if}
  6007.               if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
  6008.               begin
  6009.                 PT2 := AllocStackReg(at2ut(FBooleanType));
  6010.               end
  6011.               else
  6012.                 PT2 := OutReg;
  6013.               PreWriteOutRec(OutReg, Cardinal(-1));
  6014.               if tmpcalc <> nil then PreWriteOutRec(Tmpcalc, Cardinal(-1));
  6015.               WriteCommand(CM_CO);
  6016.               WriteByte(C);
  6017.               if (pt2 = OutReg) then
  6018.               begin
  6019.                 if not WriteOutRec(OutReg, False) then
  6020.                 begin
  6021.                   MakeError('', ecInternalError, '00007');
  6022.                   Result := False;
  6023.                   exit;
  6024.                 end; {if}
  6025.               end
  6026.               else
  6027.               begin
  6028.                 if not WriteOutRec(pt2, False) then
  6029.                 begin
  6030.                   MakeError('', ecInternalError, '00007');
  6031.                   Result := False;
  6032.                   exit;
  6033.                 end; {if}
  6034.               end;
  6035.               if tmpcalc <> nil then
  6036.               begin
  6037.                 if not WriteOutRec(tmpcalc, True) then
  6038.                 begin
  6039.                   MakeError('', ecInternalError, '00008');
  6040.                   Result := False;
  6041.                   exit;
  6042.                 end; {if}
  6043.               end else begin
  6044.                 if not WriteOutRec(OutReg, False) then
  6045.                 begin
  6046.                   MakeError('', ecInternalError, '00008');
  6047.                   Result := False;
  6048.                   exit;
  6049.                 end; {if}
  6050.               end;
  6051.               if not WriteOutRec(PT, True) then
  6052.               begin
  6053.                 MakeError('', ecInternalError, '00009');
  6054.                 Result := False;
  6055.                 exit;
  6056.               end; {if}
  6057.               if tmpcalc <> nil then begin
  6058.                 AfterWriteOutRec(Tmpcalc);
  6059.                 tmpcalc := nil;
  6060.               end;
  6061.               AfterWriteOutRec(OutReg);
  6062.               DisposeStackReg(PT);
  6063.               if pt2 <> OutReg then
  6064.               begin
  6065.                 if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address <
  6066.                   IFPSAddrNegativeStackStart) then
  6067.                 begin
  6068.                   MakeError('', ecTypeMismatch, '')^.Position :=
  6069.                     OutReg^.DPos;
  6070.                   DisposeStackReg(PT);
  6071.                   Result := False;
  6072.                   exit;
  6073.                 end;
  6074.                 PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address - 1 -
  6075.                   IFPSAddrStackStart))^.VarType := GetType(btS32);
  6076.                 WriteCommand(Cm_ST); // set stack type
  6077.                 WriteLong(PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address
  6078.                   - 1 - IFPSAddrStackStart))^.VarType);
  6079.                 WriteLong(OutReg^.Address - IFPSAddrStackStart);
  6080.                 WriteCommand(CM_A); // stack assignment
  6081.                 WriteCommand(CVAL_Addr);
  6082.                 WriteLong(OutReg^.Address);
  6083.                 if not WriteOutRec(pt2, False) then
  6084.                 begin
  6085.                   MakeError('', ecInternalError, '0000A');
  6086.                   DisposeStackReg(PT);
  6087.                   Result := False;
  6088.                   exit;
  6089.                 end;
  6090.                 DisposeStackReg(pt2);
  6091.               end;
  6092.  
  6093.             end
  6094.             else if p^.FType = CVAL_Proc then
  6095.             begin
  6096.               if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
  6097.               begin
  6098.                 PT2 := AllocStackReg(at2ut(FBooleanType));
  6099.               end
  6100.               else
  6101.                 PT2 := OutReg;
  6102.               if PIFPSProcedure(FProcs.GetItem(p^.ProcNo))^.Internal then
  6103.                 PT := AllocStackReg(StrToIntDef(Fw(PIFPSProcedure(FProcs.GetItem(p^.ProcNo))^.Decl), -1))
  6104.               else
  6105.                 PT := AllocStackReg(StrToIntDef(Fw(PIFPSUSedRegProc(FProcs.GetItem(p^.ProcNo))^.rp^.Decl), -1));
  6106.               if not ProcessFunction(p^.Modifiers, p^.ProcNo, p^.Parameters, PT) then
  6107.               begin
  6108.                 Result := False;
  6109.                 exit;
  6110.               end;
  6111.               pt^.Modifiers := p^.modifiers;
  6112.               WriteCalculation(pt, pt);
  6113.               pt^.Modifiers := 0;
  6114.               PreWriteOutRec(OutReg, Cardinal(-1));
  6115.               if tmpcalc <> nil then PreWriteOutRec(tmpcalc, Cardinal(-1));
  6116.               WriteCommand(CM_CO);
  6117.               WriteByte(C);
  6118.               if pt2 = Outreg then
  6119.               begin
  6120.                 if not WriteOutRec(OutReg, False) then
  6121.                 begin
  6122.                   MakeError('', ecInternalError, '0000B');
  6123.                   Result := False;
  6124.                   exit;
  6125.                 end; {if}
  6126.               end
  6127.               else
  6128.               begin
  6129.                 if not WriteOutRec(pt2, False) then
  6130.                 begin
  6131.                   MakeError('', ecInternalError, '0000B');
  6132.                   Result := False;
  6133.                   exit;
  6134.                 end; {if}
  6135.               end;
  6136.               if tmpcalc <> nil then
  6137.               begin
  6138.                 if not WriteOutRec(tmpcalc, true) then
  6139.                 begin
  6140.                   MakeError('', ecInternalError, '0000C');
  6141.                   Result := False;
  6142.                   exit;
  6143.                 end; {if}
  6144.               end else begin
  6145.                 if not WriteOutRec(OutReg, False) then
  6146.                 begin
  6147.                   MakeError('', ecInternalError, '0000C');
  6148.                   Result := False;
  6149.                   exit;
  6150.                 end; {if}
  6151.               end;
  6152.               if not WriteOutRec(PT, True) then
  6153.               begin
  6154.                 MakeError('', ecInternalError, '0000D');
  6155.                 Result := False;
  6156.                 exit;
  6157.               end; {if}
  6158.               if TmpCalc <> nil then
  6159.               begin
  6160.                 AfterWriteOutRec(TmpCalc);
  6161.                 tmpcalc := nil;
  6162.               end;
  6163.               AfterWriteOutRec(OutReg);
  6164.               DisposeStackReg(PT);
  6165.               if pt2 <> OutReg then
  6166.               begin
  6167.                 if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address <
  6168.                   IFPSAddrNegativeStackStart) then
  6169.                 begin
  6170.                   MakeError('', ecTypeMismatch, '')^.Position :=
  6171.                     InData^.DPos;
  6172.                   DisposeStackReg(pt2);
  6173.                   Result := False;
  6174.                   exit;
  6175.                 end;
  6176.                 PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address - 1 -
  6177.                   IFPSAddrStackStart))^.VarType := GetType(btS32);
  6178.                 WriteCommand(Cm_ST); // set stack type
  6179.                 WriteLong(PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address
  6180.                   - 1
  6181.                   - IFPSAddrStackStart))^.VarType);
  6182.                 WriteLong(OutReg^.Address - IFPSAddrStackStart);
  6183.  
  6184.                 WriteCommand(CM_A); // stack assignment
  6185.                 WriteCommand(CVAL_Addr);
  6186.                 WriteLong(OutReg^.Address);
  6187.                 if not WriteOutRec(pt2, False) then
  6188.                 begin
  6189.                   MakeError('', ecInternalError, '0000E');
  6190.                   DisposeStackReg(pt2);
  6191.                   Result := False;
  6192.                   exit;
  6193.                 end; {if}
  6194.                 DisposeStackReg(pt2);
  6195.               end;
  6196.             end
  6197.             else
  6198.             begin
  6199.               if GetTypeNo(OutReg)<> at2ut(FBooleanType) then
  6200.               begin
  6201.                 PT := AllocStackReg(at2ut(FBooleanType));
  6202.               end
  6203.               else
  6204.                 PT := OutReg;
  6205.               PreWriteOutRec(OutReg, Cardinal(-1));
  6206.               PreWriteOutRec(P, GetTypeNo(Outreg));
  6207.               if TmpCalc <> nil then PreWriteOutRec(tmpcalc, Cardinal(-1));
  6208.  
  6209.               WriteCommand(CM_CO);
  6210.               WriteData(C, 1);
  6211.               if Pt = OutReg then
  6212.               begin
  6213.                 if not WriteOutRec(OutReg, False) then
  6214.                 begin
  6215.                   MakeError('', ecInternalError, '0000F');
  6216.                   Result := False;
  6217.                   exit;
  6218.                 end; {if}
  6219.               end
  6220.               else
  6221.               begin
  6222.                 if not WriteOutRec(PT, False) then
  6223.                 begin
  6224.                   MakeError('', ecInternalError, '0000F');
  6225.                   Result := False;
  6226.                   exit;
  6227.                 end; {if}
  6228.               end;
  6229.               if tmpcalc <> nil then
  6230.               begin
  6231.                 if not WriteOutRec(tmpcalc, True) then
  6232.                 begin
  6233.                   MakeError('', ecInternalError, '00010');
  6234.                   DisposeStackReg(PT);
  6235.                   Result := False;
  6236.                   exit;
  6237.                 end; {if}
  6238.               end else begin
  6239.                 if not WriteOutRec(OutReg, False) then
  6240.                 begin
  6241.                   MakeError('', ecInternalError, '00010');
  6242.                   DisposeStackReg(PT);
  6243.                   Result := False;
  6244.                   exit;
  6245.                 end; {if}
  6246.               end;
  6247.               if not WriteOutRec(p, True) then
  6248.               begin
  6249.                 MakeError('', ecInternalError, '00011');
  6250.                 DisposeStackReg(PT);
  6251.                 Result := False;
  6252.                 exit;
  6253.               end; {case}
  6254.               if TmpCalc <> nil then begin
  6255.                 AfterWriteOutRec(tmpcalc);
  6256.                 tmpcalc := nil;
  6257.               end;
  6258.               AfterWriteOutRec(P);
  6259.               AfterWriteOutRec(OutReg);
  6260.               if PT <> OutReg then
  6261.               begin
  6262.                 if (OutReg^.FType <> CVAL_Addr) or (OutReg^.Address < IFPSAddrNegativeStackStart) then
  6263.                 begin
  6264.                   MakeError('', ecTypeMismatch, '')^.Position :=
  6265.                     InData^.DPos;
  6266.                   DisposeStackReg(PT);
  6267.                   Result := False;
  6268.                   exit;
  6269.                 end;
  6270.                 PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address - 1 -
  6271.                   IFPSAddrStackStart))^.VarType := GetType(btS32);
  6272.                 WriteCommand(Cm_ST); // set stack type
  6273.                 WriteLong(PIFPSProcVar(proc^.ProcVars.GetItem(OutReg^.Address
  6274.                   - 1
  6275.                   - IFPSAddrStackStart))^.VarType);
  6276.                 WriteLong(OutReg^.Address - IFPSAddrStackStart);
  6277.  
  6278.                 WriteCommand(CM_A); // stack assignment
  6279.                 WriteCommand(CVAL_Addr);
  6280.                 WriteLong(OutReg^.Address);
  6281.                 if not WriteOutRec(PT, False) then
  6282.                 begin
  6283.                   MakeError('', ecInternalError, '00012');
  6284.                   DisposeStackReg(PT);
  6285.                   Result := False;
  6286.                   exit;
  6287.                 end; {if}
  6288.                 DisposeStackReg(PT);
  6289.               end;
  6290.             end; {else if}
  6291.           end;
  6292.         end; {for}
  6293.         l := outreg^.modifiers;
  6294.         OutReg^.Modifiers := outreg^.Modifiers or bmodsave;
  6295.         WriteCalculation(OutReg, OutReg);
  6296.         outreg^.modifiers := l;
  6297.       end; {if}
  6298.     end
  6299.     else
  6300.     begin
  6301.       if not SameReg(OutReg, InData) then
  6302.       begin
  6303.         if (indata^.FType <> CVAL_NIL) and not CheckCompatType(OutReg, InData) then
  6304.         begin
  6305.           MakeError('', ecTypeMismatch, '')^.Position := InData^.DPos;
  6306.           Result := False;
  6307.           exit;
  6308.         end;
  6309.         if not PreWriteOutRec(InData, GetTypeNo(Outreg)) then
  6310.         begin
  6311.           Result := False;
  6312.           exit;
  6313.         end;
  6314.         if not PreWriteOutRec(OutReg, Cardinal(-1)) then
  6315.         begin
  6316.           Result := False;
  6317.           Exit;
  6318.         end;
  6319.         WriteCommand(CM_A);
  6320.         if not WriteOutRec(OutReg, False) then
  6321.         begin
  6322.           MakeError('', ecInternalError, '00013');
  6323.           AfterWriteOutRec(OutReg);
  6324.           AfterWriteOutRec(InData);
  6325.           Result := False;
  6326.           exit;
  6327.         end; {if}
  6328.         if not WriteOutRec(InData, True) then
  6329.         begin
  6330.           MakeError('', ecInternalError, '00014');
  6331.           AfterWriteOutRec(OutReg);
  6332.           AfterWriteOutRec(InData);
  6333.           Result := False;
  6334.           exit;
  6335.         end; {if}
  6336.         AfterWriteOutRec(OutReg);
  6337.         AfterWriteOutRec(InData);
  6338.       end else if InData^.Modifiers = 1 then begin
  6339.         InData^.Modifiers := 0;
  6340.         PreWriteOutRec(InData, GetTypeNo(Outreg));
  6341.         WriteCommand(cm_bn);
  6342.         WriteOutRec(InData, False);
  6343.         AfterWriteOutRec(InData);
  6344.       end else if InData^.Modifiers = 2 then begin
  6345.         InData^.Modifiers := 0;
  6346.         PreWriteOutRec(InData, GetTypeNo(Outreg));
  6347.         WriteCommand(cm_vm);
  6348.         WriteOutRec(InData, False);
  6349.         AfterWriteOutRec(InData);
  6350.       end;
  6351.     end; {if}
  6352.     Result := True;
  6353.   end; {WriteCalculation}
  6354.  
  6355.   function ProcessFunction(ResModifiers: Byte; ProcNo: Cardinal; InData: TIfList;
  6356.     ResultRegister:
  6357.     PIFPSValue): Boolean;
  6358.   var
  6359.     res: string;
  6360.     Tmp: PParam;
  6361.     resreg: PIFPSValue;
  6362.     l: Longint;
  6363.  
  6364.     procedure CleanParams;
  6365.     var
  6366.       l: Longint;
  6367.       x: PIFPSValue;
  6368.     begin
  6369.       for l := 0 to InData.Count - 1 do
  6370.       begin
  6371.         x := PParam(InData.GetItem(l))^.OutReg;
  6372.         if x <> nil then
  6373.         begin
  6374.           DisposeStackReg(x);
  6375.         end;
  6376.       end;
  6377.       if resreg <> nil then
  6378.       begin
  6379.         if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(resreg) then
  6380.         begin
  6381.           ResultRegister^.Modifiers := ResModifiers;
  6382.           if not WriteCalculation(ResultRegister, resreg) then
  6383.           begin
  6384.             Result := False;
  6385.           end;
  6386.  
  6387.           DisposeStackReg(ResultRegister);
  6388.         end else DisposeStackReg(resreg);
  6389.       end;
  6390.     end;
  6391.   begin
  6392.     if PIFPSProcedure(FProcs.GetItem(ProcNo))^.Internal then
  6393.       res := PIFPSProcedure(FProcs.GetItem(ProcNo))^.Decl
  6394.     else
  6395.       res := PIFPSUsedRegProc(FProcs.GetItem(ProcNo))^.RP^.Decl;
  6396.     if Pos(' ', res) > 0 then
  6397.       res := copy(res, 1, Pos(' ', res) - 1);
  6398.     Result := False;
  6399.     if (ResModifiers and 8 <> 0) then
  6400.     begin
  6401.       if (ResultRegister = nil) then
  6402.       begin
  6403.         MakeError('', ecNoResult, '');
  6404.         Exit;
  6405.       end else resreg := nil;
  6406.     end else
  6407.     if (res = '-1') and (ResultRegister <> nil) then
  6408.     begin
  6409.       MakeError('', ecNoResult, '');
  6410.       exit;
  6411.     end
  6412.     else if (res <> '-1')  then
  6413.     begin
  6414.       if (ResultRegister = nil) then
  6415.       begin
  6416.         resreg := AllocStackReg(StrToInt(res));
  6417.         ResultRegister := resreg;
  6418.       end else if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(ResultRegister) then
  6419.       begin
  6420.         resreg := ResultRegister;
  6421.         ResultRegister := AllocStackReg(StrToInt(res));
  6422.       end else resreg := nil;
  6423.     end
  6424.     else
  6425.       resreg := nil;
  6426.  
  6427.     for l := InData.Count - 1 downto 0 do
  6428.     begin
  6429.       Tmp := InData.GetItem(l);
  6430.       if (Tmp^.InReg^.FType = CVAL_PushAddr) then
  6431.       begin
  6432.         Tmp^.OutReg := AllocStackReg2(Tmp^.FType);
  6433.         PreWriteOutRec(Tmp^.InReg, Cardinal(-1));
  6434.         WriteCommand(CM_PV);
  6435.         WriteOutRec(Tmp^.InReg, False);
  6436.         AfterWriteOutRec(Tmp^.InReg);
  6437.       end
  6438.       else
  6439.       begin
  6440.         Tmp^.OutReg := AllocStackReg(Tmp^.FType);
  6441.         if not WriteCalculation(Tmp^.InReg, Tmp^.OutReg) then
  6442.         begin
  6443.           CleanParams;
  6444.           exit;
  6445.         end;
  6446.       end;
  6447.       DisposePValue(Tmp^.InReg);
  6448.       Tmp^.InReg := nil;
  6449.     end; {for}
  6450.     if (res <> '-1') or (ResModifiers and 8 <> 0) then
  6451.     begin
  6452.       WriteCommand(CM_PV);
  6453.       if not WriteOutRec(ResultRegister, False) then
  6454.       begin
  6455.         CleanParams;
  6456.         MakeError('', ecInternalError, '00015');
  6457.         exit;
  6458.       end;
  6459.     end;
  6460.     WriteCommand(Cm_C);
  6461.     WriteLong(ProcNo);
  6462.     if (res <> '-1') or (ResModifiers and 8 <> 0)then
  6463.       WriteCommand(CM_PO);
  6464.     Result := True;
  6465.     CleanParams;
  6466.   end; {ProcessFunction}
  6467.  
  6468.   function ProcessVarFunction(ResModifiers: Byte; ProcNo: PIFPSValue; InData: TIfList;
  6469.     ResultRegister: PIFPSValue): Boolean;
  6470.   var
  6471.     res: string;
  6472.     Tmp: PParam;
  6473.     resreg: PIFPSValue;
  6474.     l: Longint;
  6475.  
  6476.     procedure CleanParams;
  6477.     var
  6478.       l: Longint;
  6479.       x: PIFPSValue;
  6480.     begin
  6481.       for l := 0 to InData.Count - 1 do
  6482.       begin
  6483.         x := PParam(InData.GetItem(l))^.OutReg;
  6484.         if x <> nil then
  6485.         begin
  6486.           DisposeStackReg(x);
  6487.         end;
  6488.       end;
  6489.       AfterWriteOutRec(ProcNo);
  6490.       if resreg <> nil then
  6491.       begin
  6492.         if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(resreg) then
  6493.         begin
  6494.           ResultRegister^.Modifiers := ResModifiers;
  6495.           WriteCalculation(ResultRegister, resreg);
  6496.           DisposeStackReg(ResultRegister);
  6497.         end else DisposeStackReg(resreg);
  6498.       end;
  6499.     end;
  6500.   begin
  6501.     res := PIFPSProceduralType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(ProcNo)))^.Ext)^.ProcDef;
  6502.     if Pos(' ', res) > 0 then
  6503.       res := copy(res, 1, Pos(' ', res) - 1);
  6504.     Result := False;
  6505.     if (res = '-1') and (ResultRegister <> nil) then
  6506.     begin
  6507.       MakeError('', ecNoResult, '');
  6508.       exit;
  6509.     end
  6510.     else if (res <> '-1')  then
  6511.     begin
  6512.       if (ResultRegister = nil) then
  6513.       begin
  6514.         resreg := AllocStackReg(StrToInt(res));
  6515.         ResultRegister := resreg;
  6516.       end else if Cardinal(StrTointDef(Res, -1)) <> GetTypeNo(ResultRegister) then
  6517.       begin
  6518.         resreg := ResultRegister;
  6519.         ResultRegister := AllocStackReg(StrToInt(res));
  6520.       end else resreg := nil;
  6521.     end
  6522.     else
  6523.       resreg := nil;
  6524.  
  6525.     PreWriteOutRec(ProcNo, Cardinal(-1));
  6526.     for l := InData.Count - 1 downto 0 do
  6527.     begin
  6528.       Tmp := InData.GetItem(l);
  6529.       if (Tmp^.InReg^.FType = CVAL_PushAddr) then
  6530.       begin
  6531.         Tmp^.OutReg := AllocStackReg2(Tmp^.FType);
  6532.         PreWriteOutRec(Tmp^.InReg, Cardinal(-1));
  6533.         WriteCommand(CM_PV);
  6534.         WriteOutRec(Tmp^.InReg, False);
  6535.         AfterWriteOutRec(Tmp^.InReg);
  6536.       end
  6537.       else
  6538.       begin
  6539.         Tmp^.OutReg := AllocStackReg(Tmp^.FType);
  6540.         if not WriteCalculation(Tmp^.InReg, Tmp^.OutReg) then
  6541.         begin
  6542.           CleanParams;
  6543.           exit;
  6544.         end;
  6545.       end;
  6546.       DisposePValue(Tmp^.InReg);
  6547.       Tmp^.InReg := nil;
  6548.     end; {for}
  6549.     if res <> '-1' then
  6550.     begin
  6551.       WriteCommand(CM_PV);
  6552.       if not WriteOutRec(ResultRegister, False) then
  6553.       begin
  6554.         CleanParams;
  6555.         MakeError('', ecInternalError, '00015');
  6556.         exit;
  6557.       end;
  6558.     end;
  6559.     WriteCommand(Cm_cv);
  6560.     WriteOutRec(ProcNo, True);
  6561.     if res <> '-1' then
  6562.       WriteCommand(CM_PO);
  6563.     Result := True;
  6564.     CleanParams;
  6565.   end; {ProcessVarFunction}
  6566.  
  6567.   function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
  6568.   var
  6569.     I, J: Longint;
  6570.     Ok: LongBool;
  6571.     FLabelsInBlock: TIfStringList;
  6572.     s: string;
  6573.   begin
  6574.     FLabelsInBlock := TIfStringList.Create;
  6575.     for i := 0 to Proc^.FLabels.Count -1 do
  6576.     begin
  6577.       s := Proc^.FLabels.GetItem(I);
  6578.       if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
  6579.       begin
  6580.         Delete(s, 1, 8);
  6581.         FLabelsInBlock.Add(s);
  6582.       end;
  6583.     end;
  6584.     for i := 0 to Proc^.FGotos.Count -1 do
  6585.     begin
  6586.       s := Proc^.FGotos.GetItem(I);
  6587.       if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
  6588.       begin
  6589.         Delete(s, 1, 8);
  6590.         OK := False;
  6591.         for J := 0 to FLabelsInBlock.Count -1 do
  6592.         begin
  6593.           if FLabelsInBlock.GetItem(J) = s then
  6594.           begin
  6595.             Ok := True;
  6596.             Break;
  6597.           end;
  6598.         end;
  6599.         if not Ok then
  6600.         begin
  6601.           MakeError('', ecInvalidJump, '');
  6602.           Result := True;
  6603.           FLabelsInBlock.Free;
  6604.           exit;
  6605.         end;
  6606.       end else begin
  6607.         Delete(s, 1, 4);
  6608.         OK := True;
  6609.         for J := 0 to FLabelsInBlock.Count -1 do
  6610.         begin
  6611.           if FLabelsInBlock.GetItem(J) = s then
  6612.           begin
  6613.             Ok := False;
  6614.             Break;
  6615.           end;
  6616.         end;
  6617.         if not Ok then
  6618.         begin
  6619.           MakeError('', ecInvalidJump, '');
  6620.           Result := True;
  6621.           FLabelsInBlock.Free;
  6622.           exit;
  6623.         end;
  6624.       end;
  6625.     end;
  6626.     FLabelsInBlock.Free;
  6627.     Result := False;
  6628.   end;
  6629.  
  6630.   function ProcessFor: Boolean;
  6631.     { Process a for x := y to z do }
  6632.   var
  6633.     VVar: PIFPSValue;
  6634.     TempVar,
  6635.       InitialVal,
  6636.       finalVal: PIFPSValue;
  6637.     Backwards: Boolean;
  6638.     FPos, NPos, EPos, RPos: Longint;
  6639.     OldCO, OldBO: TIfList;
  6640.     I: Longint;
  6641.   begin
  6642.     Debug_WriteLine;
  6643.     Result := False;
  6644.     FParser.Next;
  6645.     if FParser.CurrTokenId <> CSTI_Identifier then
  6646.     begin
  6647.       MakeError('', ecIdentifierExpected, '');
  6648.       exit;
  6649.     end;
  6650.     VVar := GetIdentifier(1);
  6651.     if VVar = nil then
  6652.       exit;
  6653.     case PIFPSType(FUsedTypes.GetItem(GetTypeNo(VVar)))^.BaseType of
  6654.       btU8, btS8, btU16, btS16, btU32, btS32: ;
  6655.     else
  6656.       begin
  6657.         MakeError('', ecTypeMismatch, '');
  6658.         DisposePValue(VVar);
  6659.         exit;
  6660.       end;
  6661.     end;
  6662.     if FParser.CurrTokenId <> CSTI_Assignment then
  6663.     begin
  6664.       MakeError('', ecAssignmentExpected, '');
  6665.       DisposePValue(VVar);
  6666.       exit;
  6667.     end;
  6668.     FParser.Next;
  6669.     InitialVal := calc(CSTII_DownTo);
  6670.     if InitialVal = nil then
  6671.     begin
  6672.       DisposePValue(VVar);
  6673.       exit;
  6674.     end;
  6675.     if FParser.CurrTokenId = CSTII_To then
  6676.       Backwards := False
  6677.     else if FParser.CurrTokenId = CSTII_DownTo then
  6678.       Backwards := True
  6679.     else
  6680.     begin
  6681.       MakeError('', ecToExpected, '');
  6682.       DisposePValue(VVar);
  6683.       DisposePValue(InitialVal);
  6684.       exit;
  6685.     end;
  6686.     FParser.Next;
  6687.     finalVal := calc(CSTII_do);
  6688.     if finalVal = nil then
  6689.     begin
  6690.       DisposePValue(VVar);
  6691.       DisposePValue(InitialVal);
  6692.       exit;
  6693.     end;
  6694.     if FParser.CurrTokenId <> CSTII_do then
  6695.     begin
  6696.       MakeError('', ecDoExpected, '');
  6697.       DisposePValue(VVar);
  6698.       DisposePValue(InitialVal);
  6699.       DisposePValue(finalVal);
  6700.       exit;
  6701.     end;
  6702.     FParser.Next;
  6703.     if not WriteCalculation(InitialVal, VVar) then
  6704.     begin
  6705.       DisposePValue(VVar);
  6706.       DisposePValue(InitialVal);
  6707.       DisposePValue(finalVal);
  6708.       exit;
  6709.     end;
  6710.     DisposePValue(InitialVal);
  6711.     TempVar := AllocStackReg(at2ut(FBooleanType));
  6712.     NPos := Length(proc^.Data);
  6713.     PreWriteOutRec(VVar, Cardinal(-1));
  6714.     PreWriteOutRec(finalVal, Cardinal(-1));
  6715.     WriteCommand(CM_CO);
  6716.     if Backwards then
  6717.     begin
  6718.       WriteByte(0); { >= }
  6719.     end
  6720.     else
  6721.     begin
  6722.       WriteByte(1); { <= }
  6723.     end;
  6724.     if not WriteOutRec(TempVar, False) then
  6725.     begin
  6726.       DisposePValue(TempVar);
  6727.       DisposePValue(VVar);
  6728.       DisposePValue(finalVal);
  6729.       exit;
  6730.     end;
  6731.     WriteOutRec(VVar, False);
  6732.     WriteOutRec(finalVal, True);
  6733.     AfterWriteOutRec(finalVal);
  6734.     AfterWriteOutRec(VVar);
  6735.     WriteCommand(Cm_CNG);
  6736.     EPos := Length(proc^.Data);
  6737.     WriteLong($12345678);
  6738.     WriteOutRec(TempVar, False);
  6739.     RPos := Length(proc^.Data);
  6740.     OldCO := FContinueOffsets;
  6741.     FContinueOffsets := TIfList.Create;
  6742.     OldBO := FBreakOffsets;
  6743.     FBreakOffsets := TIFList.Create;
  6744.     if not ProcessSub(tOneliner, ProcNo, proc) then
  6745.     begin
  6746.       DisposePValue(TempVar);
  6747.       DisposePValue(VVar);
  6748.       DisposePValue(finalVal);
  6749.       FBreakOffsets.Free;
  6750.       FContinueOffsets.Free;
  6751.       FContinueOffsets := OldCO;
  6752.       FBreakOffsets := OldBo;
  6753.       exit;
  6754.     end;
  6755.     New(InitialVal);
  6756.     InitialVal^.FType := CVAL_Data;
  6757.     New(InitialVal^.FData);
  6758.     InitialVal^.FData^.FType := GetTypeNo(VVar);
  6759.     case PIFPSType(FUsedTypes.GetItem(InitialVal^.FData^.FType))^.BaseType
  6760.       of
  6761.       btU8, btS8: InitialVal^.FData^.Value := #1;
  6762.       btU16, btS16: InitialVal^.FData^.Value := #1#0;
  6763.       btU32, btS32: InitialVal^.FData^.Value := #1#0#0#0;
  6764.     else
  6765.       begin
  6766.         MakeError('', ecInternalError, '00019');
  6767.         DisposePValue(TempVar);
  6768.         DisposePValue(VVar);
  6769.         DisposePValue(finalVal);
  6770.         DisposePValue(InitialVal);
  6771.         FBreakOffsets.Free;
  6772.         FContinueOffsets.Free;
  6773.         FContinueOffsets := OldCO;
  6774.         FBreakOffsets := OldBo;
  6775.         exit;
  6776.       end;
  6777.     end;
  6778.     FPos := Length(Proc^.Data);
  6779.     PreWriteOutRec(InitialVal, Cardinal(-1));
  6780.     PreWriteOutRec(VVar, Cardinal(-1));
  6781.     WriteCommand(CM_CA);
  6782.     if Backwards then
  6783.       WriteByte(1) {-}
  6784.     else
  6785.       WriteByte(0); {+}
  6786.     WriteOutRec(VVar, False);
  6787.     WriteOutRec(InitialVal, True);
  6788.     AfterWriteOutRec(VVar);
  6789.     AfterWriteOutRec(InitialVal);
  6790.     DisposePValue(InitialVal);
  6791.     WriteCommand(Cm_G);
  6792.     WriteLong(Longint(NPos - Length(proc^.Data) - 4));
  6793.     Longint((@proc^.Data[EPos + 1])^) := Length(proc^.Data) - RPos;
  6794.     for i := 0 to FBreakOffsets.Count -1 do
  6795.     begin
  6796.       EPos := Cardinal(FBreakOffsets.GetItem(I));
  6797.       Longint((@proc^.Data[EPos - 3])^) := Length(proc^.Data) - Longint(EPos);
  6798.     end;
  6799.     for i := 0 to FContinueOffsets.Count -1 do
  6800.     begin
  6801.       EPos := Cardinal(FContinueOffsets.GetItem(I));
  6802.       Longint((@proc^.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
  6803.     end;
  6804.     FBreakOffsets.Free;
  6805.     FContinueOffsets.Free;
  6806.     FContinueOffsets := OldCO;
  6807.     FBreakOffsets := OldBo;
  6808.     DisposeStackReg(TempVar);
  6809.     DisposePValue(VVar);
  6810.     DisposePValue(finalVal);
  6811.     if HasInvalidJumps(RPos, Length(Proc^.Data)) then
  6812.     begin
  6813.       Result := False;
  6814.       exit;
  6815.     end;
  6816.     Result := True;
  6817.   end; {ProcessFor}
  6818.  
  6819.   function ProcessWhile: Boolean;
  6820.   var
  6821.     vin, vout: PIFPSValue;
  6822.     SPos, EPos: Cardinal;
  6823.     OldCo, OldBO: TIfList;
  6824.     I: Longint;
  6825.   begin
  6826.     Result := False;
  6827.     Debug_WriteLine;
  6828.     FParser.Next;
  6829.     vout := calc(CSTII_do);
  6830.     if vout = nil then
  6831.       exit;
  6832.     if FParser.CurrTokenId <> CSTII_do then
  6833.     begin
  6834.       DisposePValue(vout);
  6835.       MakeError('', ecDoExpected, '');
  6836.       exit;
  6837.     end;
  6838.     vin := AllocStackReg(at2ut(FBooleanType));
  6839.     SPos := Length(proc^.Data); // start position
  6840.     OldCo := FContinueOffsets;
  6841.     FContinueOffsets := TIfList.Create;
  6842.     OldBO := FBreakOffsets;
  6843.     FBreakOffsets := TIFList.Create;
  6844.     if not WriteCalculation(vout, vin) then
  6845.     begin
  6846.       DisposePValue(vout);
  6847.       DisposeStackReg(vin);
  6848.       FBreakOffsets.Free;
  6849.       FContinueOffsets.Free;
  6850.       FContinueOffsets := OldCO;
  6851.       FBreakOffsets := OldBo;
  6852.       exit;
  6853.     end;
  6854.     DisposePValue(vout);
  6855.     FParser.Next; // skip DO
  6856.     WriteCommand(Cm_CNG); // only goto if expression is false
  6857.     WriteLong($12345678);
  6858.     EPos := Length(proc^.Data);
  6859.     if not WriteOutRec(vin, False) then
  6860.     begin
  6861.       MakeError('', ecInternalError, '00017');
  6862.       DisposeStackReg(vin);
  6863.       FBreakOffsets.Free;
  6864.       FContinueOffsets.Free;
  6865.       FContinueOffsets := OldCO;
  6866.       FBreakOffsets := OldBo;
  6867.       exit;
  6868.     end;
  6869.     if not ProcessSub(tOneliner, ProcNo, proc) then
  6870.     begin
  6871.       DisposeStackReg(vin);
  6872.       FBreakOffsets.Free;
  6873.       FContinueOffsets.Free;
  6874.       FContinueOffsets := OldCO;
  6875.       FBreakOffsets := OldBo;
  6876.       exit;
  6877.     end;
  6878.     Debug_WriteLine;
  6879.     WriteCommand(Cm_G);
  6880.     WriteLong(Longint(SPos) - Length(proc^.Data) - 4);
  6881.     Longint((@proc^.Data[EPos - 3])^) := Length(proc^.Data) - Longint(EPos) - 5;
  6882.     for i := 0 to FBreakOffsets.Count -1 do
  6883.     begin
  6884.       EPos := Cardinal(FBreakOffsets.GetItem(I));
  6885.       Longint((@proc^.Data[EPos - 3])^) := Length(proc^.Data) - Longint(EPos);
  6886.     end;
  6887.     for i := 0 to FContinueOffsets.Count -1 do
  6888.     begin
  6889.       EPos := Cardinal(FContinueOffsets.GetItem(I));
  6890.       Longint((@proc^.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
  6891.     end;
  6892.     FBreakOffsets.Free;
  6893.     FContinueOffsets.Free;
  6894.     FContinueOffsets := OldCO;
  6895.     FBreakOffsets := OldBo;
  6896.     DisposeStackReg(vin);
  6897.     if HasInvalidJumps(EPos, Length(Proc^.Data)) then
  6898.     begin
  6899.       Result := False;
  6900.       exit;
  6901.     end;
  6902.     Result := True;
  6903.   end;
  6904.  
  6905.   function ProcessRepeat: Boolean;
  6906.   var
  6907.     vin, vout: PIFPSValue;
  6908.     SPos, EPos: Cardinal;
  6909.     I: Longint;
  6910.     OldCo, OldBO: TIfList;
  6911.   begin
  6912.     Result := False;
  6913.     Debug_WriteLine;
  6914.     FParser.Next;
  6915.     OldCo := FContinueOffsets;
  6916.     FContinueOffsets := TIfList.Create;
  6917.     OldBO := FBreakOffsets;
  6918.     FBreakOffsets := TIFList.Create;
  6919.     vin := AllocStackReg(at2ut(FBooleanType));
  6920.     SPos := Length(proc^.Data);
  6921.     if not ProcessSub(tRepeat, ProcNo, proc) then
  6922.     begin
  6923.       FBreakOffsets.Free;
  6924.       FContinueOffsets.Free;
  6925.       FContinueOffsets := OldCO;
  6926.       FBreakOffsets := OldBo;
  6927.       DisposeStackReg(vin);
  6928.       exit;
  6929.     end;
  6930.     FParser.Next; //cstii_until
  6931.     vout := calc(CSTI_Semicolon);
  6932.     if vout = nil then
  6933.     begin
  6934.       FBreakOffsets.Free;
  6935.       FContinueOffsets.Free;
  6936.       FContinueOffsets := OldCO;
  6937.       FBreakOffsets := OldBo;
  6938.       DisposeStackReg(vin);
  6939.       exit;
  6940.     end;
  6941.     if not WriteCalculation(vout, vin) then
  6942.     begin
  6943.       DisposePValue(vout);
  6944.       DisposeStackReg(vin);
  6945.       FBreakOffsets.Free;
  6946.       FContinueOffsets.Free;
  6947.       FContinueOffsets := OldCO;
  6948.       FBreakOffsets := OldBo;
  6949.       exit;
  6950.     end;
  6951.     DisposePValue(vout);
  6952.     WriteCommand(Cm_CNG);
  6953.     WriteLong($12345678);
  6954.     EPos := Length(proc^.Data);
  6955.     if not WriteOutRec(vin, False) then
  6956.     begin
  6957.       MakeError('', ecInternalError, '00016');
  6958.       DisposeStackReg(vin);
  6959.       FBreakOffsets.Free;
  6960.       FContinueOffsets.Free;
  6961.       FContinueOffsets := OldCO;
  6962.       FBreakOffsets := OldBo;
  6963.       exit;
  6964.     end;
  6965.     Longint((@proc^.Data[EPos - 3])^) := Longint(SPos) -
  6966.       Length(proc^.Data);
  6967.     for i := 0 to FBreakOffsets.Count -1 do
  6968.     begin
  6969.       EPos := Cardinal(FBreakOffsets.GetItem(I));
  6970.       Longint((@proc^.Data[EPos - 3])^) := Length(proc^.Data) - Longint(EPos);
  6971.     end;
  6972.     for i := 0 to FContinueOffsets.Count -1 do
  6973.     begin
  6974.       EPos := Cardinal(FContinueOffsets.GetItem(I));
  6975.       Longint((@proc^.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
  6976.     end;
  6977.     FBreakOffsets.Free;
  6978.     FContinueOffsets.Free;
  6979.     FContinueOffsets := OldCO;
  6980.     FBreakOffsets := OldBo;
  6981.     DisposeStackReg(vin);
  6982.     if HasInvalidJumps(SPos, Length(Proc^.Data)) then
  6983.     begin
  6984.       Result := False;
  6985.       exit;
  6986.     end;
  6987.     Result := True;
  6988.   end; {ProcessRepeat}
  6989.  
  6990.   function ProcessIf: Boolean;
  6991.   var
  6992.     vout, vin: PIFPSValue;
  6993.     SPos, EPos: Cardinal;
  6994.   begin
  6995.     Result := False;
  6996.     Debug_WriteLine;
  6997.     FParser.Next;
  6998.     vout := calc(CSTII_Then);
  6999.     if vout = nil then
  7000.       exit;
  7001.     if FParser.CurrTokenId <> CSTII_Then then
  7002.     begin
  7003.       DisposePValue(vout);
  7004.       MakeError('', ecThenExpected, '');
  7005.       exit;
  7006.     end;
  7007.     vin := AllocStackReg(at2ut(FBooleanType));
  7008.     if not WriteCalculation(vout, vin) then
  7009.     begin
  7010.       DisposePValue(vout);
  7011.       DisposeStackReg(vin);
  7012.       exit;
  7013.     end;
  7014.     DisposePValue(vout);
  7015.     WriteCommand(cm_sf);
  7016.     if not WriteOutRec(vin, False) then
  7017.     begin
  7018.       MakeError('', ecInternalError, '00018');
  7019.       DisposeStackReg(vin);
  7020.       exit;
  7021.     end;
  7022.     WriteByte(1);
  7023.     DisposeStackReg(vin);
  7024.     WriteCommand(cm_fg);
  7025.     WriteLong($12345678);
  7026.     SPos := Length(proc^.Data);
  7027.     FParser.Next; // skip then
  7028.     if not ProcessSub(tifOneliner, Procno, proc) then
  7029.     begin
  7030.       exit;
  7031.     end;
  7032.     if FParser.CurrTokenId = CSTII_Else then
  7033.     begin
  7034.       WriteCommand(Cm_G);
  7035.       WriteLong($12345678);
  7036.       EPos := Length(proc^.Data);
  7037.       Longint((@proc^.Data[SPos - 3])^) := Length(proc^.Data) -
  7038.         Longint(SPos);
  7039.       FParser.Next;
  7040.       if not ProcessSub(tOneliner, ProcNo, proc) then
  7041.       begin
  7042.         exit;
  7043.       end;
  7044.       Longint((@proc^.Data[EPos - 3])^) := Length(proc^.Data) - Longint(EPos);
  7045.     end
  7046.     else
  7047.     begin
  7048.       Longint((@proc^.Data[SPos - 3])^) := Length(proc^.Data) -
  7049.         Longint(SPos) + 5
  7050.         - 5;
  7051.     end;
  7052.     Result := True;
  7053.   end; {ProcessIf}
  7054.  
  7055.   function ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
  7056.   var
  7057.     I, H: Longint;
  7058.     s: string;
  7059.   begin
  7060.     h := MakeHash(FParser.GetToken);
  7061.     for i := 0 to Proc^.FLabels.Count -1 do
  7062.     begin
  7063.       s := proc^.FLabels.GetItem(I);
  7064.       delete(s, 1, 4);
  7065.       if Longint((@s[1])^) = h then
  7066.       begin
  7067.         delete(s, 1, 4);
  7068.         if s = FParser.GetToken then
  7069.         begin
  7070.           s := proc^.FLabels.GetItem(I);
  7071.           Cardinal((@s[1])^) := Length(Proc^.Data);
  7072.           Proc^.FLabels.SetItem(i, s);
  7073.           FParser.Next;
  7074.           if fParser.CurrTokenId = CSTI_Colon then
  7075.           begin
  7076.             Result := 1;
  7077.             FParser.Next;
  7078.             exit;
  7079.           end else begin
  7080.             MakeError('', ecColonExpected, '');
  7081.             Result := 0;
  7082.             Exit;
  7083.           end;
  7084.         end;
  7085.       end;
  7086.     end;
  7087.     result := 2;
  7088.   end;
  7089.  
  7090.   function ProcessIdentifier: Boolean;
  7091.   var
  7092.     vin, vout: PIFPSValue;
  7093.   begin
  7094.     Result := False;
  7095.     Debug_WriteLine;
  7096.     vin := GetIdentifier(2);
  7097.     if vin <> nil then
  7098.     begin
  7099.       if vin^.FType < CVAL_Proc then
  7100.       begin // assignment needed
  7101.         if FParser.CurrTokenId <> CSTI_Assignment then
  7102.         begin
  7103.           MakeError('', ecAssignmentExpected, '');
  7104.           DisposePValue(vin);
  7105.           exit;
  7106.         end;
  7107.         FParser.Next;
  7108.         vout := calc(CSTI_Semicolon);
  7109.         if vout = nil then
  7110.         begin
  7111.           DisposePValue(vin);
  7112.           exit;
  7113.         end;
  7114.         if not WriteCalculation(vout, vin) then
  7115.         begin
  7116.           DisposePValue(vin);
  7117.           DisposePValue(vout);
  7118.           exit;
  7119.         end;
  7120.         DisposePValue(vin);
  7121.         DisposePValue(vout);
  7122.       end
  7123.       else if vin^.FType = CVAL_VarProc then
  7124.       begin
  7125.         Result := ProcessVarFunction(0, Vin^._ProcNo, vin^._Parameters, nil);
  7126.         DisposePValue(vin);
  7127.         Exit;
  7128.       end else
  7129.       begin
  7130.         Result := ProcessFunction(0, vin^.ProcNo, vin^.Parameters, nil);
  7131.         DisposePValue(vin);
  7132.         exit;
  7133.       end;
  7134.     end
  7135.     else
  7136.     begin
  7137.       Result := False;
  7138.       exit;
  7139.     end;
  7140.     Result := True;
  7141.   end; {ProcessIdentifier}
  7142.  
  7143.   function ProcessCase: Boolean;
  7144.   var
  7145.     TempRec, CV, Val, CalcItem: PIFPSValue;
  7146.     p: PCalc_Item;
  7147.     SPos, CurrP: Cardinal;
  7148.     I: Longint;
  7149.     EndReloc: TIfList;
  7150.   begin
  7151.     Debug_WriteLine;
  7152.     FParser.Next;
  7153.     Val := calc(CSTII_of);
  7154.     if Val = nil then
  7155.     begin
  7156.       ProcessCase := False;
  7157.       exit;
  7158.     end; {if}
  7159.     if FParser.CurrTokenId <> CSTII_Of then
  7160.     begin
  7161.       MakeError('', ecOfExpected, '');
  7162.       DisposePValue(Val);
  7163.       ProcessCase := False;
  7164.       exit;
  7165.     end; {if}
  7166.     FParser.Next;
  7167.     TempRec := AllocStackReg(GetTypeNo(Val));
  7168.     if not WriteCalculation(Val, TempRec) then
  7169.     begin
  7170.       DisposeStackReg(TempRec);
  7171.       DisposePValue(Val);
  7172.       ProcessCase := False;
  7173.       exit;
  7174.     end; {if}
  7175.     DisposePValue(Val);
  7176.     EndReloc := TIfList.Create;
  7177.     CalcItem := AllocStackReg(at2ut(FBooleanType));
  7178.     SPos := Length(Proc^.Data);
  7179.     repeat
  7180.       Val := calc(CSTI_Colon);
  7181.       if (Val = nil) or (FParser.CurrTokenID <> CSTI_Colon) then
  7182.       begin
  7183.         if FParser.CurrTokenID <> CSTI_Colon then
  7184.           MakeError('', ecColonExpected, '');
  7185.         DisposeStackReg(CalcItem);
  7186.         DisposeStackReg(TempRec);
  7187.         EndReloc.Free;
  7188.         ProcessCase := False;
  7189.         exit;
  7190.       end; {if}
  7191.       FParser.Next;
  7192.       New(cv);
  7193.       cv^.DPos := FParser.CurrTokenPos;
  7194.       cv^.FType := CVAL_Eval;
  7195.       cv^.SubItems:= TIfList.Create;
  7196.       cv^.Modifiers := 0;
  7197.       new(p);
  7198.       p^.C := False;
  7199.       p^.OutRec := Val;
  7200.       cv^.SubItems.Add(p);
  7201.       new(p);
  7202.       p^.C := True;
  7203.       p^.calcCmd := 15;
  7204.       cv^.SubItems.Add(p);
  7205.       new(p);
  7206.       p^.C := False;
  7207.       p^.OutRec := TempRec;
  7208.       cv^.SubItems.Add(p);
  7209.       if not WriteCalculation(CV, CalcItem) then
  7210.       begin
  7211.         DisposeStackReg(CalcItem);
  7212.         DisposePValue(CV);
  7213.         EndReloc.Free;
  7214.         ProcessCase := False;
  7215.         exit;
  7216.       end;
  7217.       Cv.SubItems.Delete(2);
  7218.       Dispose(p);
  7219.       DisposePValue(CV);
  7220.       WriteByte(Cm_CNG);
  7221.       WriteLong($12345678);
  7222.       CurrP := Length(Proc^.Data);
  7223.       WriteOutRec(CalcItem, False);
  7224.       if not ProcessSub(tifOneliner, Procno, proc) then
  7225.       begin
  7226.         DisposeStackReg(CalcItem);
  7227.         DisposeStackReg(TempRec);
  7228.         EndReloc.Free;
  7229.         ProcessCase := False;
  7230.         exit;
  7231.       end;
  7232.       WriteByte(Cm_G);
  7233.       WriteLong($12345678);
  7234.       EndReloc.Add(Pointer(Length(Proc^.Data)));
  7235.       Cardinal((@Proc^.Data[CurrP - 3])^) := Cardinal(Length(Proc^.Data)) - CurrP - 5;
  7236.       if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
  7237.       if FParser.CurrTokenID = CSTII_Else then
  7238.       begin
  7239.         FParser.Next;
  7240.         if not ProcessSub(tOneliner, Procno, proc) then
  7241.         begin
  7242.           DisposeStackReg(CalcItem);
  7243.           DisposeStackReg(TempRec);
  7244.           EndReloc.Free;
  7245.           ProcessCase := False;
  7246.           exit;
  7247.         end;
  7248.         if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
  7249.         if FParser.CurrtokenId <> CSTII_End then
  7250.         begin
  7251.           MakeError('', ecEndExpected, '');
  7252.           DisposeStackReg(CalcItem);
  7253.           DisposeStackReg(TempRec);
  7254.           EndReloc.Free;
  7255.           ProcessCase := False;
  7256.           exit;
  7257.         end;
  7258.       end;
  7259.     until FParser.CurrTokenID = CSTII_End;
  7260.     FParser.Next;
  7261.     for i := 0 to EndReloc.Count -1 do
  7262.     begin
  7263.       Cardinal((@Proc^.Data[Cardinal(EndReloc.GetItem(I))- 3])^) := Cardinal(Length(Proc^.Data)) - Cardinal(EndReloc.GetItem(I));
  7264.     end;
  7265.     DisposeStackReg(CalcItem);
  7266.     DisposeStackReg(TempRec);
  7267.     EndReloc.Free;
  7268.     if HasInvalidJumps(SPos, Length(Proc^.Data)) then
  7269.     begin
  7270.       Result := False;
  7271.       exit;
  7272.     end;
  7273.     Result := True;
  7274.   end; {ProcessCase}
  7275.   function ProcessGoto: Boolean;
  7276.   var
  7277.     I, H: Longint;
  7278.     s: string;
  7279.   begin
  7280.     Debug_WriteLine;
  7281.     FParser.Next;
  7282.     h := MakeHash(FParser.GetToken);
  7283.     for i := 0 to Proc^.FLabels.Count -1 do
  7284.     begin
  7285.       s := proc^.FLabels.GetItem(I);
  7286.       delete(s, 1, 4);
  7287.       if Longint((@s[1])^) = h then
  7288.       begin
  7289.         delete(s, 1, 4);
  7290.         if s = FParser.GetToken then
  7291.         begin
  7292.           FParser.Next;
  7293.           WriteCommand(Cm_G);
  7294.           WriteLong($12345678);
  7295.           Proc^.FGotos.Add(mi2s(length(Proc^.Data))+mi2s(i));
  7296.           Result := True;
  7297.           exit;
  7298.         end;
  7299.       end;
  7300.     end;
  7301.     MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
  7302.     Result := False;
  7303.   end; {ProcessGoto}
  7304.   function ProcessTry: Boolean;
  7305.   var
  7306.     FStartOffset: Cardinal;
  7307.   begin
  7308.     FParser.Next;
  7309.     WriteCommand(cm_puexh);
  7310.     FStartOffset := Length(Proc^.Data) + 1;
  7311.     WriteLong(Cardinal(-1));
  7312.     WriteLong(Cardinal(-1));
  7313.     WriteLong(Cardinal(-1));
  7314.     WriteLong(Cardinal(-1));
  7315.     if ProcessSub(tTry, ProcNo, Proc) then
  7316.     begin
  7317.       WriteCommand(cmd_poexh);
  7318.       WriteByte(0);
  7319.       if FParser.CurrTokenID = CSTII_Except then
  7320.       begin
  7321.         FParser.Next;
  7322.         Cardinal((@Proc^.Data[FStartOffset + 4])^) := Cardinal(Length(Proc^.Data)) - FStartOffset - 15;
  7323.         if ProcessSub(tTryEnd, ProcNo, Proc) then
  7324.         begin
  7325.           WriteCommand(cmd_poexh);
  7326.           writeByte(2);
  7327.           if FParser.CurrTokenId = CSTII_Finally then
  7328.           begin
  7329.             Cardinal((@Proc^.Data[FStartOffset + 8])^) := Cardinal(Length(Proc^.Data)) - FStartOffset - 15;
  7330.             FParser.Next;
  7331.             if ProcessSub(tTryEnd, ProcNo, Proc) then
  7332.             begin
  7333.               if FParser.CurrTokenId = CSTII_End then
  7334.               begin
  7335.                 WriteCommand(cmd_poexh);
  7336.                 writeByte(3);
  7337.               end else begin
  7338.                 MakeError('', ecEndExpected, '');
  7339.                 Result := False;
  7340.                 exit;
  7341.               end;
  7342.             end else begin Result := False; exit; end;
  7343.           end else if FParser.CurrTokenID <> CSTII_End then
  7344.           begin
  7345.             MakeError('', ecEndExpected, '');
  7346.             Result := False;
  7347.             exit;
  7348.           end;
  7349.           FParser.Next;
  7350.         end else begin Result := False; exit; end;
  7351.       end else if FParser.CurrTokenId = CSTII_Finally then
  7352.       begin
  7353.         FParser.Next;
  7354.         Cardinal((@Proc^.Data[FStartOffset])^) := Cardinal(Length(Proc^.Data)) - FStartOffset - 15;
  7355.         if ProcessSub(tTryEnd, ProcNo, Proc) then
  7356.         begin
  7357.           WriteCommand(cmd_poexh);
  7358.           writeByte(1);
  7359.           if FParser.CurrTokenId = CSTII_Except then
  7360.           begin
  7361.             Cardinal((@Proc^.Data[FStartOffset + 4])^) := Cardinal(Length(Proc^.Data)) - FStartOffset - 15;
  7362.             FParser.Next;
  7363.             if ProcessSub(tTryEnd, ProcNo, Proc) then
  7364.             begin
  7365.               if FParser.CurrTokenId = CSTII_End then
  7366.               begin
  7367.                 WriteCommand(cmd_poexh);
  7368.                 writeByte(2);
  7369.               end else begin
  7370.                 MakeError('', ecEndExpected, '');
  7371.                 Result := False;
  7372.                 exit;
  7373.               end;
  7374.             end else begin Result := False; exit; end;
  7375.           end else if FParser.CurrTokenID <> CSTII_End then
  7376.           begin
  7377.             MakeError('', ecEndExpected, '');
  7378.             Result := False;
  7379.             exit;
  7380.           end;
  7381.           FParser.Next;
  7382.         end else begin Result := False; exit; end;
  7383.       end;
  7384.     end else begin Result := False; exit; end;
  7385.     Cardinal((@Proc^.Data[FStartOffset + 12])^) := Cardinal(Length(Proc^.Data)) - FStartOffset - 15;
  7386.     Result := True;
  7387.   end; {ProcessTry}
  7388. begin
  7389.   ProcessSub := False;
  7390.   if (FType = tProcBegin) or (FType = tMainBegin) or (FType = tSubBegin) then
  7391.   begin
  7392.     FParser.Next; // skip CSTII_Begin
  7393.   end;
  7394.   while True do
  7395.   begin
  7396.     case FParser.CurrTokenId of
  7397.       CSTII_break:
  7398.         begin
  7399.           if FBreakOffsets = nil then
  7400.           begin
  7401.             MakeError('', ecNotInLoop, '');
  7402.             exit;
  7403.           end;
  7404.           WriteCommand(Cm_G);
  7405.           WriteLong($12345678);
  7406.           FBreakOffsets.Add(Pointer(Length(Proc^.Data)));
  7407.           FParser.Next;
  7408.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7409.             break;
  7410.         end;
  7411.       CSTII_Continue:
  7412.         begin
  7413.           if FBreakOffsets = nil then
  7414.           begin
  7415.             MakeError('', ecNotInLoop, '');
  7416.             exit;
  7417.           end;
  7418.           WriteCommand(Cm_G);
  7419.           WriteLong($12345678);
  7420.           FContinueOffsets.Add(Pointer(Length(Proc^.Data)));
  7421.           FParser.Next;
  7422.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7423.             break;
  7424.         end;
  7425.       CSTII_Goto:
  7426.         begin
  7427.           if not ProcessGoto then
  7428.             Exit;
  7429.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7430.             break;
  7431.         end;
  7432.       CSTII_Try:
  7433.         begin
  7434.           if not ProcessTry then
  7435.             Exit;
  7436.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7437.             break;
  7438.         end;
  7439.       CSTII_Finally, CSTII_Except:
  7440.         begin
  7441.           if (FType = tTry) or (FType = tTryEnd) then
  7442.             Break
  7443.           else
  7444.             begin
  7445.               MakeError('', ecEndExpected, '');
  7446.               Exit;
  7447.             end;
  7448.         end;
  7449.       CSTII_Begin:
  7450.         begin
  7451.           if not ProcessSub(tSubBegin, ProcNo, proc) then
  7452.             Exit;
  7453.           FParser.Next; // skip END
  7454.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7455.             break;
  7456.         end;
  7457.       CSTI_Semicolon:
  7458.         begin
  7459.           FParser.Next;
  7460.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7461.             break;
  7462.         end;
  7463.       CSTII_until:
  7464.         begin
  7465.           Debug_WriteLine;
  7466.           if FType = tRepeat then
  7467.           begin
  7468.             break;
  7469.           end
  7470.           else
  7471.           begin
  7472.             MakeError('', ecIdentifierExpected, '');
  7473.             exit;
  7474.           end;
  7475.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7476.             break;
  7477.         end;
  7478.       CSTII_Else:
  7479.         begin
  7480.           if FType = tifOneliner then
  7481.             break
  7482.           else
  7483.           begin
  7484.             MakeError('', ecIdentifierExpected, '');
  7485.             exit;
  7486.           end;
  7487.         end;
  7488.       CSTII_repeat:
  7489.         begin
  7490.           if not ProcessRepeat then
  7491.             exit;
  7492.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7493.             break;
  7494.         end;
  7495.       CSTII_For:
  7496.         begin
  7497.           if not ProcessFor then
  7498.             exit;
  7499.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7500.             break;
  7501.         end;
  7502.       CSTII_While:
  7503.         begin
  7504.           if not ProcessWhile then
  7505.             exit;
  7506.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7507.             break;
  7508.         end;
  7509.       CSTII_Exit:
  7510.         begin
  7511.           Debug_WriteLine;
  7512.           WriteCommand(Cm_R);
  7513.           FParser.Next;
  7514.         end;
  7515.       CSTII_Case:
  7516.         begin
  7517.           if not ProcessCase then
  7518.             exit;
  7519.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7520.             break;
  7521.         end;
  7522.       CSTII_If:
  7523.         begin
  7524.           if not ProcessIf then
  7525.             exit;
  7526.           if (FType = tifOneliner) or (FType = TOneLiner) then
  7527.             break;
  7528.         end;
  7529.       CSTI_Identifier:
  7530.         begin
  7531.           case ProcessLabel of
  7532.             0: Exit;
  7533.             1: ;
  7534.             else
  7535.             begin
  7536.               if not ProcessIdentifier then
  7537.                 exit;
  7538.               if (FType = tifOneliner) or (FType = TOneLiner) then
  7539.                 break;
  7540.             end;
  7541.           end; {case}
  7542.         end;
  7543.       CSTII_End:
  7544.         begin
  7545.           if (FType = tTryEnd) or (FType = tMainBegin) or (FType = tSubBegin) or (FType =
  7546.             tifOneliner) or (FType = tProcBegin) or (FType = TOneLiner) then
  7547.           begin
  7548.             break;
  7549.           end
  7550.           else
  7551.           begin
  7552.             MakeError('', ecIdentifierExpected, '');
  7553.             exit;
  7554.           end;
  7555.         end;
  7556.       CSTI_EOF:
  7557.         begin
  7558.           MakeError('', ecUnexpectedEndOfFile, '');
  7559.           exit;
  7560.         end;
  7561.     else
  7562.       begin
  7563.         MakeError('', ecIdentifierExpected, '');
  7564.         exit;
  7565.       end;
  7566.     end;
  7567.   end;
  7568.   if (FType = tMainBegin) or (FType = tProcBegin) then
  7569.   begin
  7570.     WriteCommand(Cm_R);
  7571.     FParser.Next; // skip end
  7572.     if (FType = tMainBegin) and (FParser.CurrTokenId <> CSTI_Period) then
  7573.     begin
  7574.       MakeError('', ecPeriodExpected, '');
  7575.       exit;
  7576.     end;
  7577.     if (FType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
  7578.     begin
  7579.       MakeError('', ecSemicolonExpected, '');
  7580.       exit;
  7581.     end;
  7582.     FParser.Next;
  7583.   end;
  7584.   ProcessSub := True;
  7585. end;
  7586.  
  7587.  
  7588. function TIFPSPascalCompiler.ProcessLabelForwards(Proc: PIFPSProcedure): Boolean;
  7589. var
  7590.   i: Longint;
  7591.   s, s2: string;
  7592. begin
  7593.   for i := 0 to Proc^.FLabels.Count -1 do
  7594.   begin
  7595.     s := Proc^.FLabels.GetItem(i);
  7596.     if Longint((@s[1])^) = -1 then
  7597.     begin
  7598.       delete(s, 1, 8);
  7599.       MakeError('', ecUnSetLabel, s);
  7600.       Result := False;
  7601.       exit;
  7602.     end;
  7603.   end;
  7604.   for i := proc^.FGotos.Count -1 downto 0 do
  7605.   begin
  7606.     s := proc^.FGotos.GetItem(I);
  7607.     s2 := Proc^.FLabels.GetItem(Cardinal((@s[5])^));
  7608.     Cardinal((@Proc^.Data[Cardinal((@s[1])^)-3])^) :=  Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
  7609.   end;
  7610.   Result := True;
  7611. end;
  7612.  
  7613.  
  7614.  
  7615. function TIFPSPascalCompiler.Compile(const s: string): Boolean;
  7616. var
  7617.   Position: Byte;
  7618.   i: Longint;
  7619.  
  7620.   procedure FreeAll;
  7621.   var
  7622.     I, I2: Longint;
  7623.     PPV: PIFPSProcVar;
  7624.     PT: PIFPSType;
  7625.     pp: PIFPSProcedure;
  7626.     pc: PIFPSConstant;
  7627.     ppe: PIFPSUsedRegProc;
  7628.     pv: PIFPSVar;
  7629.     pr: PIFPSRegProc;
  7630.     pn: PIFPSProceduralType;
  7631.  
  7632.     procedure FreeRecord(v: TIfList);
  7633.     var
  7634.       I: Longint;
  7635.       p: PIFPSRecordType;
  7636.     begin
  7637.       for I := 0 to v.Count - 1 do
  7638.       begin
  7639.         p := v.GetItem(I);
  7640.         p^.FieldName := '';
  7641.         Dispose(p);
  7642.       end;
  7643.       v.Free;
  7644.     end;
  7645.   begin
  7646.     for I := 0 to FRegProcs.Count - 1 do
  7647.     begin
  7648.       pr := FRegProcs.GetItem(I);
  7649.       Dispose(pr);
  7650.     end;
  7651.     FRegProcs.Free;
  7652.     for i := 0 to FConstants.Count -1 do
  7653.     begin
  7654.       pc := FConstants.GetItem(I);
  7655.       Dispose(pc);
  7656.     end;
  7657.     Fconstants.Free;
  7658.     for I := 0 to FVars.Count - 1 do
  7659.     begin
  7660.       pv := FVars.GetItem(I);
  7661.       Dispose(pv);
  7662.     end;
  7663.     FVars.Free;
  7664.     for I := 0 to FProcs.Count - 1 do
  7665.     begin
  7666.       ppe := FProcs.GetItem(I);
  7667.       if ppe^.Internal then
  7668.       begin
  7669.         pp := Pointer(ppe);
  7670.         for I2 := 0 to pp^.ProcVars.Count - 1 do
  7671.         begin
  7672.           PPV := pp^.ProcVars.GetItem(I2);
  7673.           Dispose(PPV);
  7674.         end;
  7675.         pp^.ProcVars.Free;
  7676.         pp^.FGotos.Free;
  7677.         pp^.FLabels.Free;
  7678.         Dispose(pp);
  7679.       end
  7680.       else
  7681.       begin
  7682.         Dispose(ppe);
  7683.       end;
  7684.  
  7685.     end;
  7686.     FProcs.Free;
  7687.     FProcs := nil;
  7688.     for I := 0 to FAvailableTypes.Count - 1 do
  7689.     begin
  7690.       PT := FAvailableTypes.GetItem(I);
  7691.       if pt^.BaseType = btProcPtr then
  7692.       begin
  7693.         pn := pt^.Ext;
  7694.         Dispose(pn);
  7695.       end else if PT^.BaseType = btRecord then
  7696.         FreeRecord(PT^.RecordSubVals)
  7697.       else if (pt^.BaseType = btClass) and (pt^.Ext <> nil) then
  7698.       begin
  7699.         TIFPSExternalClass(pt^.Ext).Free;
  7700.       end;
  7701.       Dispose(PT);
  7702.     end;
  7703.     FAvailableTypes.Free;
  7704.     FUsedTypes.Free;
  7705.   end;
  7706.  
  7707.  
  7708.  
  7709.   procedure MakeOutput;
  7710.  
  7711.     procedure WriteByte(b: Byte);
  7712.     begin
  7713.       FOutput := FOutput + Char(b);
  7714.     end;
  7715.  
  7716.     procedure WriteData(const Data; Len: Longint);
  7717.     begin
  7718.       SetLength(FOutput, Length(FOutput) + Len);
  7719.       Move(Data, FOutput[Length(FOutput) - Len + 1], Len);
  7720.     end;
  7721.  
  7722.     procedure WriteLong(l: Cardinal);
  7723.     begin
  7724.       WriteData(l, 4);
  7725.     end;
  7726.  
  7727.  
  7728.     procedure WriteTypes;
  7729.     var
  7730.       l, n: Longint;
  7731.       Tmp: Cardinal;
  7732.       x: PIFPSType;
  7733.       xxp: PIFPSProceduralType;
  7734.       FExportName: string;
  7735.     begin
  7736.       for l := 0 to FUsedTypes.Count - 1 do
  7737.       begin
  7738.         x := FUsedTypes.GetItem(l);
  7739.         if x^.BaseType = btChar then x^.BaseType := btu8;
  7740.         if x^.FExport then
  7741.           FExportName := x^.Name
  7742.         else
  7743.           FExportName := '';
  7744.         if x^.BaseType = btClass then
  7745.         begin
  7746.           x := GetTypeCopyLink(FAvailableTypes.GetItem(TIFPSExternalClass(x^.Ext).SelfType));
  7747.         end;
  7748.         if (x^.BaseType = btString)and (x^.Ext = Pointer(1))then x^.BaseType := btPChar;
  7749.         if (x^.BaseType = btEnum) then begin
  7750.           if Longint(x^.Ext) <= 256 then
  7751.             x^.BaseType := btU8
  7752.           else if Longint(x^.Ext) <= 65536 then
  7753.             x^.BaseType := btU16
  7754.           else
  7755.             x^.BaseType := btU32;
  7756.         end;
  7757.         if x^.BaseType = btProcPtr then begin
  7758.           xxp := x^.Ext;
  7759.           Dispose(xxp);
  7760.           x^.Ext := nil;
  7761.           x^.BaseType := btu32;
  7762.         end;
  7763.         if FExportName <> '' then
  7764.         begin
  7765.           WriteByte(x^.BaseType + 128);
  7766.         end
  7767.         else
  7768.           WriteByte(X^.BaseType);
  7769.         if x^.BaseType = btArray then
  7770.         begin
  7771.           WriteLong(Longint(x^.Ext));
  7772.         end
  7773.         else if x^.BaseType = btRecord then
  7774.         begin
  7775.           n := x^.RecordSubVals.Count;
  7776.           WriteData(n, 4);
  7777.           for n := 0 to x^.RecordSubVals.Count - 1 do
  7778.           begin
  7779.             Tmp := PIFPSRecordType(x^.RecordSubVals.GetItem(n))^.FType;
  7780.             WriteData(Tmp, 4);
  7781.           end;
  7782.         end;
  7783.         if FExportName <> '' then
  7784.         begin
  7785.           WriteLong(Length(FExportName));
  7786.           WriteData(FExportName[1], length(FExportName));
  7787.         end;
  7788.       end;
  7789.     end;
  7790.  
  7791.     procedure WriteVars;
  7792.     var
  7793.       l: Longint;
  7794.       x: PIFPSVar;
  7795.     begin
  7796.       for l := 0 to FVars.Count - 1 do
  7797.       begin
  7798.         x := FVars.GetItem(l);
  7799.         WriteLong(x^.FType);
  7800.         if x^.exportname <> '' then
  7801.         begin
  7802.           WriteByte(1);
  7803.           WriteLong(Length(X^.ExportName));
  7804.           WriteData(X^.ExportName[1], length(X^.ExportName));
  7805.         end else
  7806.           WriteByte(0);
  7807.       end;
  7808.     end;
  7809.  
  7810.     procedure WriteProcs;
  7811.     var
  7812.       l: Longint;
  7813.       x: PIFPSProcedure;
  7814.       xp: PIFPSUsedRegProc;
  7815.       s: string;
  7816.     begin
  7817.       for l := 0 to FProcs.Count - 1 do
  7818.       begin
  7819.         x := FProcs.GetItem(l);
  7820.         if x^.Internal then
  7821.         begin
  7822.           x^.OutputDeclPosition := Length(FOutput);
  7823.           if x^.FExport <> 0 then
  7824.             WriteByte(2) // exported
  7825.           else
  7826.             WriteByte(0); // not imported
  7827.           WriteLong(0); // offset is unknown at this time
  7828.           WriteLong(0); // length is also unknown at this time
  7829.           if x^.FExport <> 0 then
  7830.           begin
  7831.             WriteLong(Length(x^.Name));
  7832.             WriteData(x^.Name[1], length(x^.Name));
  7833.             if x^.FExport = 1 then
  7834.             begin
  7835.               WriteLong(0);
  7836.             end else begin
  7837.               s := MakeExportDecl(x^.Decl);
  7838.               WriteLong(Length(s));
  7839.               WriteData(s[1], length(S));
  7840.             end;
  7841.           end;
  7842.         end
  7843.         else
  7844.         begin
  7845.           xp := Pointer(x);
  7846.           if xp^.RP^.ImportDecl <> '' then
  7847.           begin
  7848.             WriteByte(3); // imported
  7849.             if xp^.Rp^.FExportName then
  7850.             begin
  7851.               WriteByte(Length(xp^.RP^.Name));
  7852.               WriteData(xp^.RP^.Name[1], Length(xp^.RP^.Name) and $FF);
  7853.             end else begin
  7854.               WriteByte(0);
  7855.             end;
  7856.             WriteLong(Length(xp^.RP^.ImportDecl));
  7857.             WriteData(xp^.RP^.ImportDecl[1], Length(xp^.RP^.ImportDecl));
  7858.           end else begin
  7859.             WriteByte(1); // imported
  7860.             WriteByte(Length(xp^.RP^.Name));
  7861.             WriteData(xp^.RP^.Name[1], Length(xp^.RP^.Name) and $FF);
  7862.           end;
  7863.         end;
  7864.       end;
  7865.     end;
  7866.  
  7867.     procedure WriteProcs2;
  7868.     var
  7869.       l: Longint;
  7870.       L2: Cardinal;
  7871.       x: PIFPSProcedure;
  7872.     begin
  7873.       for l := 0 to FProcs.Count - 1 do
  7874.       begin
  7875.         x := FProcs.GetItem(l);
  7876.         if x^.Internal then
  7877.         begin
  7878.           L2 := Length(FOutput);
  7879.           Move(L2, FOutput[x^.OutputDeclPosition + 2], 4);
  7880.           // write position
  7881.           WriteData(x^.Data[1], Length(x^.Data));
  7882.           L2 := Cardinal(Length(FOutput)) - L2;
  7883.           Move(L2, FOutput[x^.OutputDeclPosition + 6], 4); // write length
  7884.         end;
  7885.       end;
  7886.     end;
  7887.  
  7888.     function FindMainProc: Cardinal;
  7889.     var
  7890.       l: Longint;
  7891.     begin
  7892.       for l := 0 to FProcs.Count - 1 do
  7893.       begin
  7894.         if (PIFPSProcedure(FProcs.GetItem(l))^.Internal) and
  7895.           (PIFPSProcedure(FProcs.GetItem(l))^.Name = IFPSMainProcName) then
  7896.         begin
  7897.           Result := l;
  7898.           exit;
  7899.         end;
  7900.       end;
  7901.       Result := Cardinal(-1);
  7902.     end;
  7903.     procedure CreateDebugData;
  7904.     var
  7905.       I: Longint;
  7906.       p: PIFPSProcedure;
  7907.       pv: PIFPSVar;
  7908.       s: string;
  7909.     begin
  7910.       s := #0;
  7911.       for I := 0 to FProcs.Count - 1 do
  7912.       begin
  7913.         p := FProcs.GetItem(I);
  7914.         if p^.Internal then
  7915.         begin
  7916.           if p^.Name = IFPSMainProcName then
  7917.             s := s + #1
  7918.           else
  7919.             s := s + p^.Name + #1;
  7920.         end
  7921.         else
  7922.         begin
  7923.           s := s+ PIFPSUsedRegProc(p)^.RP^.Name + #1;
  7924.         end;
  7925.       end;
  7926.       s := s + #0#1;
  7927.       for I := 0 to FVars.Count - 1 do
  7928.       begin
  7929.         pv := FVars.GetItem(I);
  7930.         s := s + pv.Name + #1;
  7931.       end;
  7932.       s := s + #0;
  7933.       WriteDebugData(s);
  7934.     end;
  7935.   begin
  7936.     CreateDebugData;
  7937.     WriteLong(IFPSValidHeader);
  7938.     WriteLong(IFPSCurrentBuildNo);
  7939.     WriteLong(FUsedTypes.Count);
  7940.     WriteLong(FProcs.Count);
  7941.     WriteLong(FVars.Count);
  7942.     WriteLong(FindMainProc);
  7943.     WriteLong(0);
  7944.     WriteTypes;
  7945.     WriteProcs;
  7946.     WriteVars;
  7947.     WriteProcs2;
  7948.   end;
  7949.  
  7950.   function CheckExports: Boolean;
  7951.   var
  7952.     i: Longint;
  7953.     p: PIFPSProcedure;
  7954.   begin
  7955.     if @FOnExportCheck = nil then
  7956.     begin
  7957.       result := true;
  7958.       exit;
  7959.     end;
  7960.     for i := 0 to FProcs.Count -1 do
  7961.     begin
  7962.       p := FProcs.GetItem(i);
  7963.       if p^.Internal then
  7964.       begin
  7965.         if not FOnExportCheck(Self, p, MakeDecl(p^.Decl)) then
  7966.         begin
  7967.           Result := false;
  7968.           exit;
  7969.         end;
  7970.       end;
  7971.     end;
  7972.     Result := True;
  7973.   end;
  7974.   function DoConstBlock: Boolean;
  7975.   var
  7976.     CName: string;
  7977.     CValue: PIFRVariant;
  7978.     Cp: PIFPSConstant;
  7979.   begin
  7980.     FParser.Next;
  7981.     repeat
  7982.       if FParser.CurrTokenID <> CSTI_Identifier then
  7983.       begin
  7984.         MakeError('', ecIdentifierExpected, '');
  7985.         Result := False;
  7986.         Exit;
  7987.       end;
  7988.       CName := FParser.GetToken;
  7989.       if IsDuplicate(CName) then
  7990.       begin
  7991.         MakeError('', ecDuplicateIdentifier, '');
  7992.         Result := False;
  7993.         exit;
  7994.       end;
  7995.       FParser.Next;
  7996.       if FParser.CurrTokenID <> CSTI_Equal then
  7997.       begin
  7998.         MakeError('', ecIsExpected, '');
  7999.         Result := False;
  8000.         Exit;
  8001.       end;
  8002.       FParser.Next;
  8003.       CValue := ReadConstant(CSTI_SemiColon);
  8004.       if CValue = nil then
  8005.       begin
  8006.         Result := False;
  8007.         Exit;
  8008.       end;
  8009.       if FParser.CurrTokenID <> CSTI_Semicolon then
  8010.       begin
  8011.         MakeError('', ecSemicolonExpected, '');
  8012.         Result := False;
  8013.         exit;
  8014.       end;
  8015.       New(cp);
  8016.       cp^.NameHash := MakeHash(CName);
  8017.       cp^.Name := CName;
  8018.       cp^.Value.FType := CValue^.FType;
  8019.       cp^.Value.Value := CValue^.Value;
  8020.       FConstants.Add(cp);
  8021.       DisposeVariant(CValue);
  8022.       FParser.Next;
  8023.     until FParser.CurrTokenId <> CSTI_Identifier;
  8024.     Result := True;
  8025.   end;
  8026.   function ProcessUses: Boolean;
  8027.   var
  8028.     FUses: TIfStringList;
  8029.     I: Longint;
  8030.     s: string;
  8031.   begin
  8032.     FParser.Next;
  8033.     FUses := TIfStringList.Create;
  8034.     repeat
  8035.       if FParser.CurrTokenID <> CSTI_Identifier then
  8036.       begin
  8037.         MakeError('', ecIdentifierExpected, '');
  8038.         FUses.Free;
  8039.         Result := False;
  8040.         exit;
  8041.       end;
  8042.       s := FParser.GetToken;
  8043.       for i := 0 to FUses.Count -1 do
  8044.       begin
  8045.         if FUses.GetItem(I) = s then
  8046.         begin
  8047.           MakeError('', ecDuplicateIdentifier, s);
  8048.           FUses.Free;
  8049.           Result := False;
  8050.           exit;
  8051.         end;
  8052.       end;
  8053.       FUses.Add(s);
  8054.       if @FOnUses <> nil then
  8055.       begin
  8056.         try
  8057.           if not OnUses(Self, FParser.GetToken) then
  8058.           begin
  8059.             FUses.Free;
  8060.             Result := False;
  8061.             exit;
  8062.           end;
  8063.         except
  8064.           on e: Exception do
  8065.           begin
  8066.             MakeError('', ecCustomError, e.Message);
  8067.             FUses.Free;
  8068.             Result := False;
  8069.             exit;
  8070.           end;
  8071.         end;
  8072.       end;
  8073.       FParser.Next;
  8074.       if FParser.CurrTokenID = CSTI_Semicolon then break
  8075.       else if FParser.CurrTokenId <> CSTI_Comma then
  8076.       begin
  8077.         MakeError('', ecSemicolonExpected, '');
  8078.         Result := False;
  8079.         FUses.Free;
  8080.         exit;
  8081.       end;
  8082.       FParser.Next;
  8083.     until False;
  8084.     FParser.next;
  8085.     Result := True;
  8086.   end;
  8087. var
  8088.   Proc: PIFPSProcedure;
  8089.  
  8090. begin
  8091.   FIsUnit := False;
  8092.   Result := False;
  8093.   Clear;
  8094.   FParser.SetText(s);
  8095.  
  8096.   FProcs := TIfList.Create;
  8097.   FConstants := TIFList.Create;
  8098.   FVars := TIfList.Create;
  8099.   FAvailableTypes := TIfList.Create;
  8100.   FUsedTypes := TIfList.Create;
  8101.   FRegProcs := TIfList.Create;
  8102.   DefineStandardTypes;
  8103.   if @FOnUses <> nil then
  8104.   begin
  8105.     try
  8106.       if not OnUses(Self, 'SYSTEM') then
  8107.       begin
  8108.         FreeAll;
  8109.         exit;
  8110.       end;
  8111.     except
  8112.       on e: Exception do
  8113.       begin
  8114.         MakeError('', ecCustomError, e.Message);
  8115.         FreeAll;
  8116.         exit;
  8117.       end;
  8118.     end;
  8119.   end;
  8120.   Position := 0;
  8121.   Proc := NewProc(IFPSMainProcName);
  8122.   repeat
  8123.     if FParser.CurrTokenId = CSTI_EOF then
  8124.     begin
  8125.       if FAllowNoEnd then
  8126.         Break
  8127.       else
  8128.       begin
  8129.         MakeError('', ecUnexpectedEndOfFile, '');
  8130.         FreeAll;
  8131.         exit;
  8132.       end;
  8133.     end;
  8134.     if (FParser.CurrTokenId = CSTII_Program) and (Position = 0) then
  8135.     begin
  8136.       Position := 1;
  8137.       FParser.Next;
  8138.       if FParser.CurrTokenId <> CSTI_Identifier then
  8139.       begin
  8140.         MakeError('', ecIdentifierExpected, '');
  8141.         FreeAll;
  8142.         exit;
  8143.       end;
  8144.       FParser.Next;
  8145.       if FParser.CurrTokenId <> CSTI_Semicolon then
  8146.       begin
  8147.         MakeError('', ecSemicolonExpected, '');
  8148.         FreeAll;
  8149.         exit;
  8150.       end;
  8151.       FParser.Next;
  8152.     end else
  8153.     if (FParser.CurrTokenId = CSTII_Unit) and (Position = 0) and (FAllowUnit) then
  8154.     begin
  8155.       Position := 1;
  8156.       FIsUnit := True;
  8157.       FParser.Next;
  8158.       if FParser.CurrTokenId <> CSTI_Identifier then
  8159.       begin
  8160.         MakeError('', ecIdentifierExpected, '');
  8161.         FreeAll;
  8162.         exit;
  8163.       end;
  8164.       FParser.Next;
  8165.       if FParser.CurrTokenId <> CSTI_Semicolon then
  8166.       begin
  8167.         MakeError('', ecSemicolonExpected, '');
  8168.         FreeAll;
  8169.         exit;
  8170.       end;
  8171.       FParser.Next;
  8172.     end
  8173.     else if (FParser.CurrTokenID = CSTII_Uses) and (Position < 2) then
  8174.     begin
  8175.       Position := 2;
  8176.       if not ProcessUses then
  8177.       begin
  8178.         FreeAll;
  8179.         exit;
  8180.       end;
  8181.     end else if (FParser.CurrTokenId = CSTII_Procedure) or
  8182.       (FParser.CurrTokenId = CSTII_Function) then
  8183.     begin
  8184.       Position := 2;
  8185.       if not ProcessFunction then
  8186.       begin
  8187.         FreeAll;
  8188.         exit;
  8189.       end;
  8190.     end
  8191.     else if (FParser.CurrTokenId = CSTII_Label) then
  8192.     begin
  8193.       Position := 2;
  8194.       if not ProcessLabel(Proc) then
  8195.       begin
  8196.         FreeAll;
  8197.         exit;
  8198.       end;
  8199.     end
  8200.     else if (FParser.CurrTokenId = CSTII_Var) then
  8201.     begin
  8202.       Position := 2;
  8203.       if not DoVarBlock(nil) then
  8204.       begin
  8205.         FreeAll;
  8206.         exit;
  8207.       end;
  8208.     end
  8209.     else if (FParser.CurrTokenId = CSTII_Const) then
  8210.     begin
  8211.       Position := 2;
  8212.       if not DoConstBlock then
  8213.       begin
  8214.         FreeAll;
  8215.         exit;
  8216.       end;
  8217.     end
  8218.     else if (FParser.CurrTokenId = CSTII_Type) then
  8219.     begin
  8220.       Position := 2;
  8221.       if not DoTypeBlock(FParser) then
  8222.       begin
  8223.         FreeAll;
  8224.         exit;
  8225.       end;
  8226.     end
  8227.     else if (FParser.CurrTokenId = CSTII_Begin) then
  8228.     begin
  8229.       if ProcessSub(tMainBegin, 0, Proc) then
  8230.       begin
  8231.         break;
  8232.       end
  8233.       else
  8234.       begin
  8235.         FreeAll;
  8236.         exit;
  8237.       end;
  8238.     end
  8239.     else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
  8240.     begin
  8241.       FParser.Next;
  8242.       if FParser.CurrTokenID <> CSTI_Period then
  8243.       begin
  8244.         MakeError('', ecPeriodExpected, '');
  8245.         FreeAll;
  8246.         exit;
  8247.       end;
  8248.       break;
  8249.     end else 
  8250.     begin
  8251.       MakeError('', ecBeginExpected, '');
  8252.       FreeAll;
  8253.       exit;
  8254.     end;
  8255.   until False;
  8256.   if not ProcessLabelForwards(Proc) then
  8257.   begin
  8258.     FreeAll;
  8259.     exit;
  8260.   end;
  8261.   for i := 0 to FProcs.Count -1 do
  8262.   begin
  8263.     Proc := FProcs.GetItem(i);
  8264.     if Proc^.Internal and Proc^.Forwarded then
  8265.     begin
  8266.       MakeError('', ecUnsatisfiedForward, Proc^.Name)^.Position := Proc^.DeclarePosition;
  8267.       FreeAll;
  8268.       Exit;
  8269.     end;
  8270.   end;
  8271.   if not CheckExports then
  8272.   begin
  8273.     FreeAll;
  8274.     exit;
  8275.   end;
  8276.   for i := 0 to FVars.Count -1 do
  8277.   begin
  8278.     if not PIFPSVar(FVars.GetItem(I))^.Used then
  8279.     begin
  8280.       MakeHint('', ehVariableNotUsed, PIFPSVar(FVars.GetItem(I))^.Name)^.Position := PIFPSVar(FVars.GetItem(I))^.DeclarePosition;
  8281.     end;
  8282.   end;
  8283.   MakeOutput;
  8284.   FreeAll;
  8285.   Result := True;
  8286. end;
  8287.  
  8288. constructor TIFPSPascalCompiler.Create;
  8289. begin
  8290.   inherited Create;
  8291.   FParser := TIfPascalParser.Create;
  8292.   FParser.OnParserError := ParserError;
  8293.   FAutoFreeList := TIfList.Create;
  8294.   FOutput := '';
  8295.   FMessages := TIfList.Create;
  8296. end;
  8297.  
  8298. destructor TIFPSPascalCompiler.Destroy;
  8299. begin
  8300.   Clear;
  8301.   FAutoFreeList.Free;
  8302.  
  8303.   FMessages.Free;
  8304.   FParser.Free;
  8305.   inherited Destroy;
  8306. end;
  8307.  
  8308. function TIFPSPascalCompiler.GetOutput(var s: string): Boolean;
  8309. begin
  8310.   if Length(FOutput) <> 0 then
  8311.   begin
  8312.     s := FOutput;
  8313.     Result := True;
  8314.   end
  8315.   else
  8316.     Result := False;
  8317. end;
  8318.  
  8319. function TIFPSPascalCompiler.GetMsg(l: Longint):
  8320.   PIFPSPascalCompilerMessage;
  8321. begin
  8322.   Result := FMessages.GetItem(l);
  8323. end;
  8324.  
  8325. function TIFPSPascalCompiler.GetMsgCount: Longint;
  8326. begin
  8327.   Result := FMessages.Count;
  8328. end;
  8329.  
  8330. procedure TIFPSPascalCompiler.DefineStandardTypes;
  8331. begin
  8332.   AddType('BYTE', btU8);
  8333.   AddTypeS('BOOLEAN', '(False, True)');
  8334.   FBooleanType := FAvailableTypes.Count -1;
  8335.   AddType('CHAR', btChar);
  8336.   AddType('SHORTINT', btS8);
  8337.   AddType('WORD', btU16);
  8338.   AddType('SMALLINT', btS16);
  8339.   AddType('INTEGER', BtTypeCopy)^.Ext := AddType('LONGINT', btS32);
  8340.   AddType('CARDINAL', BtTypeCopy)^.Ext := AddType('LONGWORD', btU32);
  8341.   AddType('STRING', btString);
  8342.   AddType('PCHAR', btString)^.Ext := Pointer(1);
  8343.   AddType('SINGLE', btSingle);
  8344.   AddType('DOUBLE', btDouble);
  8345.   AddType('EXTENDED', btExtended);
  8346.   AddType('VARIANT', btVariant);
  8347.   AddType('TVARIANTARRAY', btArray)^.Ext := Pointer(FindType('VARIANT'));
  8348.   {$IFNDEF NOINT64}
  8349.   AddType('INT64', btS64);
  8350.   {$ENDIF}
  8351.   with AddFunction('function Assigned(I: Longint): Boolean;')^ do
  8352.   begin
  8353.     Name := '!ASSIGNED';
  8354.     NameHash := MakeHash(Name);
  8355.   end;
  8356. end;
  8357.  
  8358. procedure TIFPSPascalCompiler.UpdateRecordFields(r: Pointer);
  8359. var
  8360.   I: Longint;
  8361.  
  8362. begin
  8363.   if PIFPSType(r)^.BaseType = btProcPtr then
  8364.   begin
  8365.     ReplaceTypes(PIFPSProceduralType(PIFPSType(r)^.Ext)^.ProcDef);
  8366.  
  8367.   end else if PIFPSType(r)^.BaseType = btRecord then
  8368.   begin
  8369.     for I := 0 to PIFPSType(r)^.RecordSubVals.Count - 1 do
  8370.     begin
  8371.       PIFPSRecordType(PIFPSType(r)^.RecordSubVals.GetItem(I))^.FType := at2ut(PIFPSRecordType(PIFPSType(r)^.RecordSubVals.GetItem(I))^.FType);
  8372.     end;
  8373.   end
  8374.   else if PIFPSType(r)^.BaseType = btArray then
  8375.   begin
  8376.     if PIFPSType(r)^.Ext <> Pointer(Cardinal(-1)) then
  8377.       PIFPSType(r)^.Ext := Pointer(at2ut(Cardinal(PIFPSType(r)^.Ext)));
  8378.   end;
  8379. end;
  8380.  
  8381.  
  8382. function TIFPSPascalCompiler.FindType(const Name: string): Cardinal;
  8383. var
  8384.   i, n: Longint;
  8385.   p: PIFPSType;
  8386.   RName: string;
  8387. begin
  8388.   if FProcs = nil then begin Result := Cardinal(-1); exit;end;
  8389.   RName := Fastuppercase(Name);
  8390.   n := makehash(rname);
  8391.   for i := 0 to FAvailableTypes.Count - 1 do
  8392.   begin
  8393.     p := FAvailableTypes.GetItem(I);
  8394.     if (p^.NameHash = n) and (p^.name = rname) then
  8395.     begin
  8396.       result := I;
  8397.       exit;
  8398.     end;
  8399.   end;
  8400.   result := Cardinal(-1);
  8401. end;
  8402.  
  8403. function TIFPSPascalCompiler.AddConstant(const Name: string; FType: Cardinal): PIFPSConstant;
  8404. var
  8405.   pc: PIFPSConstant;
  8406. begin
  8407.   if FProcs = nil then begin Result := nil; exit;end;
  8408.   if FType = Cardinal(-1) then begin Result := nil; exit; end; 
  8409.   new(pc);
  8410.   pc^.Name := FastUppercase(name);
  8411.   pc^.NameHash := makehash(pc^.name);
  8412.   pc^.Value.FType := FType;
  8413.   FConstants.Add(pc);
  8414.   result := pc;
  8415. end;
  8416.  
  8417. type
  8418.   PConstantVal = ^TConstantVal;
  8419.   TConstantVal = record
  8420.     b: Boolean;
  8421.     case boolean  of
  8422.     true: (Rec: PIfRVariant; DeclPos: Cardinal; Modifiers: Byte);
  8423.     false: (c: byte);
  8424.   end;
  8425.  
  8426. function TIFPSPascalCompiler.ReadConstant(StopOn: TIfPasToken): PIfRVariant;
  8427. var
  8428.   Items: TIfList;
  8429.   tmp: PConstantVal;
  8430.   Val: PIfRVariant;
  8431.   c,
  8432.   modifiers: byte;
  8433.  
  8434.     function GetType(BaseType: TIFPSBaseType): Cardinal;
  8435.     var
  8436.       l: Longint;
  8437.       x: PIFPSType;
  8438.     begin
  8439.       for l := 0 to FAvailableTypes.Count - 1 do
  8440.       begin
  8441.         if PIFPSType(FAvailableTypes.GetItem(l))^.BaseType = BaseType then
  8442.         begin
  8443.           Result := l;
  8444.           exit;
  8445.         end;
  8446.       end;
  8447.       New(x);
  8448.       x^.Name := '';
  8449.       x^.NameHash := MakeHash(x^.Name);
  8450.       x^.BaseType := BaseType;
  8451.       x^.TypeSize := 1;
  8452.       x^.DeclarePosition := Cardinal(-1);
  8453.       FAvailableTypes.Add(x);
  8454.       FUsedTypes.Add(x);
  8455.       Result := FUsedTypes.Count - 1;
  8456.     end;
  8457.  
  8458.   procedure Cleanup;
  8459.   var
  8460.     p: PConstantVal;
  8461.     l: Longint;
  8462.   begin
  8463.     for l := 0 to Items.Count - 1 do
  8464.     begin
  8465.       p := Items.GetItem(l);
  8466.       if not p^.b then
  8467.       begin
  8468.         DisposeVariant(p^.Rec);
  8469.       end;
  8470.       Dispose(p);
  8471.     end;
  8472.     Items.Free;
  8473.   end;
  8474.  
  8475.   function SortItems: Boolean;
  8476.   var
  8477.     l: Longint;
  8478.     p, p1, P2: PConstantVal;
  8479.   begin
  8480.     SortItems := False;
  8481.     if Items.Count = 1 then
  8482.     begin
  8483.       p1 := Items.GetItem(0);
  8484.  
  8485.       if (p1^.Rec^.FType = CVAL_Data) then
  8486.       begin
  8487.  
  8488.         if p1^.Modifiers = 1 then // not
  8489.         begin
  8490.           case PIFPSType(FUsedTypes.GetItem(p1^.Rec^.FType))^.BaseType of
  8491.             btU8: TbtU8((@p1^.Rec^.Value[1])^) := tbtu8(TbtU8((@p1^.Rec^.Value[1])^) = 0);
  8492.             btS8: TbtS8((@p1^.Rec^.Value[1])^) := tbts8(TbtS8((@p1^.Rec^.Value[1])^) = 0);
  8493.             btU16: TbtU16((@p1^.Rec^.Value[1])^) := tbtu16(TbtU16((@p1^.Rec^.Value[1])^) = 0);
  8494.             btS16: TbtS16((@p1^.Rec^.Value[1])^) := tbts16(TbtS16((@p1^.Rec^.Value[1])^) = 0);
  8495.             btU32: TbtU32((@p1^.Rec^.Value[1])^) := tbtu32(TbtU32((@p1^.Rec^.Value[1])^) = 0);
  8496.             btS32: TbtS32((@p1^.Rec^.Value[1])^) := tbts32(TbtS32((@p1^.Rec^.Value[1])^) = 0);
  8497.           end;
  8498.         end else
  8499.         if p1^.Modifiers = 2 then // minus
  8500.         begin
  8501.           case PIFPSType(FUsedTypes.GetItem(p1^.Rec^.FType))^.BaseType of
  8502.             btU8: TbtU8((@p1^.Rec^.Value[1])^) := - TbtU8((@p1^.Rec^.Value[1])^);
  8503.             btS8: TbtS8((@p1^.Rec^.Value[1])^) := - TbtS8((@p1^.Rec^.Value[1])^);
  8504.             btU16: TbtU16((@p1^.Rec^.Value[1])^) := - TbtU16((@p1^.Rec^.Value[1])^);
  8505.             btS16: TbtS16((@p1^.Rec^.Value[1])^) := - TbtS16((@p1^.Rec^.Value[1])^);
  8506.             btU32: TbtU32((@p1^.Rec^.Value[1])^) := - TbtU32((@p1^.Rec^.Value[1])^);
  8507.             btS32: TbtS32((@p1^.Rec^.Value[1])^) := - TbtS32((@p1^.Rec^.Value[1])^);
  8508.             btSingle: TbtSingle((@p1^.Rec^.Value[1])^) := - TbtSingle((@p1^.Rec^.Value[1])^);
  8509.             btDouble: TbtDouble((@p1^.Rec^.Value[1])^) := - TbtDouble((@p1^.Rec^.Value[1])^);
  8510.             btExtended: TbtExtended((@p1^.Rec^.Value[1])^) := - tbtExtended((@p1^.Rec^.Value[1])^);
  8511.           end;
  8512.         end;
  8513.       end;
  8514.  
  8515.       SortItems := True;
  8516.       exit;
  8517.     end;
  8518.     l := 0;
  8519.     while l < Longint(Items.Count - 1) div 2 do
  8520.     begin
  8521.       p := Items.GetItem((l shl 1) + 1);
  8522.       p1 := Items.GetItem((l shl 1));
  8523.       P2 := Items.GetItem((l shl 1) + 2);
  8524.       case p^.c of
  8525.         2, 3, 4, 5, 6, 7: {*}
  8526.           begin
  8527.             if not PreCalc(FAvailableTypes, p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
  8528.             begin
  8529.               exit;
  8530.             end;
  8531.             Items.Delete((l shl 1) + 1);
  8532.             Items.Delete((l shl 1) + 1);
  8533.             DisposeVariant(p2^.Rec);
  8534.             Dispose(P2);
  8535.             Dispose(p);
  8536.           end;
  8537.       else
  8538.         Inc(l);
  8539.       end;
  8540.     end;
  8541.     l := 0;
  8542.     while l < Longint(Items.Count - 1) div 2 do
  8543.     begin
  8544.       p := Items.GetItem((l shl 1) + 1);
  8545.       p1 := Items.GetItem((l shl 1));
  8546.       P2 := Items.GetItem((l shl 1) + 2);
  8547.       case p^.c of
  8548.         0, 1, 8, 9:
  8549.           begin
  8550.             if not PreCalc(FAvailableTypes,p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
  8551.             begin
  8552.               exit;
  8553.             end;
  8554.             Items.Delete((l shl 1) + 1);
  8555.             Items.Delete((l shl 1) + 1);
  8556.             DisposeVariant(p2^.Rec);
  8557.             Dispose(P2);
  8558.             Dispose(p);
  8559.           end;
  8560.       else
  8561.         Inc(l);
  8562.       end;
  8563.     end;
  8564.     l := 0;
  8565.     while l < Longint(Items.Count - 1) div 2 do
  8566.     begin
  8567.       p := Items.GetItem((l shl 1) + 1);
  8568.       p1 := Items.GetItem((l shl 1));
  8569.       P2 := Items.GetItem((l shl 1) + 2);
  8570.       case p^.c of
  8571.         10, 11, 12, 13, 14, 15:
  8572.           begin
  8573.             if not PreCalc(FAvailableTypes,p1^.Modifiers, p1^.Rec, p2^.Modifiers, P2^.Rec, p^.c, p2^.DeclPos) then
  8574.             begin
  8575.               exit;
  8576.             end;
  8577.             Items.Delete((l shl 1) + 1);
  8578.             Items.Delete((l shl 1) + 1);
  8579.             DisposeVariant(p2^.Rec);
  8580.             Dispose(P2);
  8581.             Dispose(p);
  8582.           end;
  8583.       else
  8584.         Inc(l);
  8585.       end;
  8586.     end;
  8587.     SortItems := True;
  8588.   end;
  8589.   function ReadReal(const s: string): PIfRVariant;
  8590.   var
  8591.     C: Integer;
  8592.   begin
  8593.     New(Result);
  8594.     Result^.FType := GetType(btExtended);
  8595.     SetLength(Result^.Value, SizeOf(TbtExtended));
  8596.     System.Val(s, TbtExtended((@Result^.Value[1])^), C);
  8597.   end;
  8598.   function ReadInteger(const s: string): PIfRVariant;
  8599.   var
  8600.     C: Integer;
  8601.   begin
  8602.     New(Result);
  8603.     Result^.FType := GetType(btS32);
  8604.     SetLength(Result^.Value, SizeOf(TbtS32));
  8605.     System.Val(s, TbtS32((@Result^.Value[1])^), C);
  8606.     if TbtS32((@Result^.Value[1])^) < 0 then
  8607.     begin
  8608.       System.Val(s, TbtU32((@Result^.Value[1])^), C);
  8609.     end;
  8610.   end;
  8611.   function ReadString: PIfRVariant;
  8612.  
  8613.     function ParseString: string;
  8614.     var
  8615.       temp3: string;
  8616.  
  8617.       function ChrToStr(s: string): Char;
  8618.       begin
  8619.         Delete(s, 1, 1); {First char : #}
  8620.         ChrToStr := Chr(StrToInt(s));
  8621.       end;
  8622.  
  8623.       function PString(s: string): string;
  8624.       begin
  8625.         s := copy(s, 2, Length(s) - 2);
  8626.         PString := s;
  8627.       end;
  8628.     begin
  8629.       temp3 := '';
  8630.       while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId =
  8631.         CSTI_Char) do
  8632.       begin
  8633.         if FParser.CurrTokenId = CSTI_String then
  8634.         begin
  8635.           temp3 := temp3 + PString(FParser.GetToken);
  8636.           FParser.Next;
  8637.           if FParser.CurrTokenId = CSTI_String then
  8638.             temp3 := temp3 + #39;
  8639.         end {if}
  8640.         else
  8641.         begin
  8642.           temp3 := temp3 + ChrToStr(FParser.GetToken);
  8643.           FParser.Next;
  8644.         end; {else if}
  8645.       end; {while}
  8646.       ParseString := temp3;
  8647.     end;
  8648.   begin
  8649.     New(Result);
  8650.     Result^.FType := GetType(btString);
  8651.     Result^.Value := ParseString;
  8652.   end;
  8653.   function GetConstantIdentifier: PIfRVariant;
  8654.   var
  8655.     s: string;
  8656.     sh: Longint;
  8657.     i: Longint;
  8658.     p: PIFPSConstant;
  8659.   begin
  8660.     s := FParser.GetToken;
  8661.     sh := MakeHash(s);
  8662.     for i := FConstants.Count -1 downto 0 do
  8663.     begin
  8664.       p := FConstants.GetItem(I);
  8665.       if (p^.NameHash = sh) and (p^.Name = s) then
  8666.       begin
  8667.         New(Result);
  8668.         Result^.FType := p^.Value.FType;
  8669.         Result^.Value := p^.Value.Value;
  8670.         FParser.Next;
  8671.         exit;
  8672.       end;
  8673.     end;
  8674.     MakeError('', ecUnknownIdentifier, '');
  8675.     Result := nil;
  8676.  
  8677.   end;
  8678. begin
  8679.   Items := TIfList.Create;
  8680.   ReadConstant := nil;
  8681.   while True do
  8682.   begin
  8683.     modifiers := 0;
  8684.     if Items.Count and 1 = 0 then
  8685.     begin
  8686.       if fParser.CurrTokenID = CSTII_Not then
  8687.       begin
  8688.         FParser.Next;
  8689.         modifiers := 1;
  8690.       end else // only allow one of these two
  8691.       if fParser.CurrTokenID = CSTI_Minus then
  8692.       begin
  8693.         FParser.Next;
  8694.         modifiers := 2;
  8695.       end;
  8696.       case FParser.CurrTokenId of
  8697.         CSTI_EOF:
  8698.           begin
  8699.             MakeError('', ecUnexpectedEndOfFile, '');
  8700.             Cleanup;
  8701.             exit;
  8702.           end;
  8703.         CSTI_OpenRound:
  8704.           begin
  8705.             FParser.Next;
  8706.  
  8707.             val := ReadConstant(CSTI_CloseRound);
  8708.             if val = nil then
  8709.             begin
  8710.               Cleanup;
  8711.               exit;
  8712.             end;
  8713.             if FParser.CurrTokenId <> CSTI_CloseRound then
  8714.             begin
  8715.               MakeError('', ecCloseRoundExpected, '');
  8716.               Cleanup;
  8717.               exit;
  8718.             end;
  8719.             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
  8720.             begin
  8721.               DisposeVariant(val);
  8722.               MakeError('', ecTypeMismatch, '');
  8723.               Cleanup;
  8724.               exit;
  8725.             end;
  8726.             new(tmp);
  8727.             tmp^.b := False;
  8728.             tmp^.Rec := Val;
  8729.             tmp^.DeclPos := FParser.CurrTokenPos;
  8730.             tmp^.Modifiers := modifiers;
  8731.             Items.Add(tmp);
  8732.             FParser.Next;
  8733.           end;
  8734.         CSTI_Char, CSTI_String:
  8735.           begin
  8736.             if (Modifiers <> 0) then
  8737.             begin
  8738.               MakeError('', ecTypeMismatch, '');
  8739.               Cleanup;
  8740.               exit;
  8741.             end;
  8742.             val := ReadString;
  8743.             new(tmp);
  8744.             tmp^.b := False;
  8745.             tmp^.Rec := Val;
  8746.             tmp^.DeclPos := FParser.CurrTokenPos;
  8747.             tmp^.Modifiers := modifiers;
  8748.             Items.Add(tmp);
  8749.           end;
  8750.         CSTI_HexInt, CSTI_Integer:
  8751.           begin
  8752.             Val := ReadInteger(FParser.GetToken);
  8753.             new(tmp);
  8754.             tmp^.b := False;
  8755.             tmp^.Rec := Val;
  8756.             tmp^.DeclPos := FParser.CurrTokenPos;
  8757.             tmp^.Modifiers := modifiers;
  8758.             Items.Add(tmp);
  8759.             FParser.Next;
  8760.           end;
  8761.         CSTI_Real:
  8762.           begin
  8763.             if ((Modifiers and 1) <> 0)  then
  8764.             begin
  8765.               MakeError('', ecTypeMismatch, '');
  8766.               Cleanup;
  8767.               exit;
  8768.             end;
  8769.             Val := ReadReal(FParser.GetToken);
  8770.             new(tmp);
  8771.             tmp^.b := False;
  8772.             tmp^.Rec := Val;
  8773.             tmp^.DeclPos := FParser.CurrTokenPos;
  8774.             tmp^.Modifiers := modifiers;
  8775.             Items.Add(tmp);
  8776.             FParser.Next;
  8777.           end;
  8778.         CSTI_Identifier:
  8779.           begin
  8780.             val := GetConstantIdentifier;
  8781.             if val = nil then
  8782.             begin
  8783.               Cleanup;
  8784.               exit;
  8785.             end
  8786.             else
  8787.             begin
  8788.               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))
  8789.               then
  8790.               begin
  8791.                 DisposeVariant(val);
  8792.                 MakeError('', ecTypeMismatch, '');
  8793.                 Cleanup;
  8794.                 exit;
  8795.               end;
  8796.               new(tmp);
  8797.               tmp^.b := False;
  8798.               tmp^.Rec := Val;
  8799.               tmp^.DeclPos := FParser.CurrTokenPos;
  8800.               tmp^.Modifiers := modifiers;
  8801.               Items.Add(tmp);
  8802.             end;
  8803.           end;
  8804.       else
  8805.         begin
  8806.           MakeError('', ecSyntaxError, '');
  8807.           Cleanup;
  8808.           exit;
  8809.         end;
  8810.       end; {case}
  8811.     end
  8812.     else {Items.Count and 1 = 1}
  8813.     begin
  8814.       if FParser.CurrTokenId = StopOn then
  8815.         break;
  8816.       C := 0;
  8817.       case FParser.CurrTokenId of
  8818.         CSTI_EOF:
  8819.           begin
  8820.             MakeError('', ecUnexpectedEndOfFile, '');
  8821.             Cleanup;
  8822.             exit;
  8823.           end;
  8824.         CSTI_CloseBlock,
  8825.           CSTII_To,
  8826.           CSTI_CloseRound,
  8827.           CSTI_Semicolon,
  8828.           CSTII_Else,
  8829.           CSTII_End,
  8830.           CSTI_Comma: break;
  8831.         CSTI_Plus: ;
  8832.         CSTI_Minus: C := 1;
  8833.         CSTI_Multiply: C := 2;
  8834.         CSTI_Divide: C := 3;
  8835.         CSTII_mod: C := 4;
  8836.         CSTII_shl: C := 5;
  8837.         CSTII_shr: C := 6;
  8838.         CSTII_and: C := 7;
  8839.         CSTII_or: C := 8;
  8840.         CSTII_xor: C := 9;
  8841.         CSTI_GreaterEqual: C := 10;
  8842.         CSTI_LessEqual: C := 11;
  8843.         CSTI_Greater: C := 12;
  8844.         CSTI_Less: C := 13;
  8845.         CSTI_NotEqual: C := 14;
  8846.         CSTI_Equal: C := 15;
  8847.       else
  8848.         begin
  8849.           MakeError('', ecSyntaxError, '');
  8850.           Cleanup;
  8851.           exit;
  8852.         end;
  8853.       end; {case}
  8854.       new(tmp);
  8855.       tmp^.b := True;
  8856.       tmp^.c := C;
  8857.       Items.Add(tmp);
  8858.       FParser.Next;
  8859.     end;
  8860.   end;
  8861.   if not SortItems then
  8862.   begin
  8863.     Cleanup;
  8864.     exit;
  8865.   end;
  8866.   if Items.Count = 1 then
  8867.   begin
  8868.     tmp := Items.GetItem(0);
  8869.     Result := tmp^.Rec;
  8870.     Dispose(tmp);
  8871.     Items.Free;
  8872.   end
  8873.   else
  8874.   begin
  8875.     MakeError('', ecInternalError, '0001B');
  8876.     Cleanup;
  8877.     Exit;
  8878.   end;
  8879. end;
  8880.  
  8881. procedure TIFPSPascalCompiler.WriteDebugData(const s: string);
  8882. begin
  8883.   FDebugOutput := FDebugOutput + s;
  8884. end;
  8885.  
  8886. function TIFPSPascalCompiler.GetDebugOutput(var s: string): Boolean;
  8887. begin
  8888.   if Length(FDebugOutput) <> 0 then
  8889.   begin
  8890.     s := FDebugOutput;
  8891.     Result := True;
  8892.   end
  8893.   else
  8894.     Result := False;
  8895. end;
  8896.  
  8897. function TIFPSPascalCompiler.AddUsedFunction(var Proc: PIFPSProcedure): Cardinal;
  8898. begin
  8899.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8900.   New(Proc);
  8901.   FProcs.Add(Proc);
  8902.   Result := FProcs.Count - 1;
  8903. end;
  8904.  
  8905. function TIFPSPascalCompiler.GetAvailableType(No: Cardinal): PIFPSType;
  8906. begin
  8907.   if FProcs = nil then begin Result := nil; exit;end;
  8908.   Result := FAvailableTypes.GetItem(No);
  8909. end;
  8910.  
  8911. function TIFPSPascalCompiler.GetAvailableTypeCount: Cardinal;
  8912. begin
  8913.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8914.   Result := FAvailableTypes.Count;
  8915. end;
  8916.  
  8917. function TIFPSPascalCompiler.GetProc(No: Cardinal): PIFPSProcedure;
  8918. begin
  8919.   if FProcs = nil then begin Result := nil; exit;end;
  8920.   Result := FProcs.GetItem(No);
  8921. end;
  8922.  
  8923. function TIFPSPascalCompiler.GetProcCount: Cardinal;
  8924. begin
  8925.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8926.   Result := FProcs.Count;
  8927. end;
  8928.  
  8929. function TIFPSPascalCompiler.GetUsedType(No: Cardinal): PIFPSType;
  8930. begin
  8931.   if FProcs = nil then begin Result := nil; exit;end;
  8932.   Result := FUsedTypes.GetItem(No);
  8933. end;
  8934.  
  8935. function TIFPSPascalCompiler.GetUsedTypeCount: Cardinal;
  8936. begin
  8937.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8938.   Result := FUsedTypes.Count;
  8939. end;
  8940.  
  8941. function TIFPSPascalCompiler.UseAvailableType(No: Cardinal): Cardinal;
  8942. var
  8943.   I: Longint;
  8944.   p: PIFPSType;
  8945. begin
  8946.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8947.   p := FAvailableTypes.GetItem(No);
  8948.   if p = nil then
  8949.   begin
  8950.     Result := Cardinal(-1);
  8951.     Exit;
  8952.   end;
  8953.  
  8954.   for I := 0 to FUsedTypes.Count - 1 do
  8955.   begin
  8956.     if FUsedTypes.GetItem(I) = p then
  8957.     begin
  8958.       Result := I;
  8959.       exit;
  8960.     end;
  8961.   end;
  8962.   UpdateRecordFields(p);
  8963.   FUsedTypes.Add(p);
  8964.   Result := FUsedTypes.Count - 1;
  8965. end;
  8966.  
  8967. function TIFPSPascalCompiler.AddUsedFunction2(var Proc: PIFPSUsedRegProc): Cardinal;
  8968. begin
  8969.   if FProcs = nil then begin Result := Cardinal(-1);exit;end;
  8970.   New(Proc);
  8971.   Proc^.Internal := False;
  8972.   FProcs.Add(Proc);
  8973.   Result := FProcs.Count -1;
  8974. end;
  8975.  
  8976. function TIFPSPascalCompiler.AddVariable(const Name: string; FType: Cardinal): PIFPSVar;
  8977. var
  8978.   P: PIFPSVar;
  8979. begin
  8980.   if FProcs = nil then begin Result := nil; exit;end;
  8981.   if FType = Cardinal(-1) then begin Result := nil; exit; end;
  8982.   New(p);
  8983.   p^.Name := Fastuppercase(Name);
  8984.   p^.Namehash := MakeHash(p^.Name);
  8985.   p^.FType := AT2UT(FType);
  8986.   p^.Used := False;
  8987.   p^.DeclarePosition := 0;
  8988.   FVars.Add(p);
  8989.   Result := P;
  8990. end;
  8991.  
  8992. function TIFPSPascalCompiler.GetVariable(No: Cardinal): PIFPSVar;
  8993. begin
  8994.   if FProcs = nil then begin Result := nil; exit;end;
  8995.   Result := FVars.GetItem(No);
  8996. end;
  8997.  
  8998. function TIFPSPascalCompiler.GetVariableCount: Cardinal;
  8999. begin
  9000.   if FProcs = nil then begin Result := 0; exit;end;
  9001.   Result := FVars.Count;
  9002. end;
  9003.  
  9004.  
  9005. procedure TIFPSPascalCompiler.AddToFreeList(Obj: TObject);
  9006. begin
  9007.   FAutoFreeList.Add(Obj);
  9008. end;
  9009.  
  9010. function TIFPSPascalCompiler.AddConstantN(const Name,
  9011.   FType: string): PIFPSConstant;
  9012. var
  9013.   L: Cardinal;
  9014. begin
  9015.   L := FindType(FType);
  9016.   if l = Cardinal(-1) then
  9017.     Result := nil
  9018.   else
  9019.     Result := AddConstant(Name, L);
  9020. end;
  9021.  
  9022. function TIFPSPascalCompiler.AddTypeCopy(const Name: string;
  9023.   TypeNo: Cardinal): PIFPSType;
  9024. begin
  9025.   Result := AddType(Name, BtTypeCopy);
  9026.   Result.Ext := Pointer(TypeNo);
  9027. end;
  9028.  
  9029. function TIFPSPascalCompiler.AddTypeCopyN(const Name,
  9030.   FType: string): PIFPSType;
  9031. var
  9032.   L: Cardinal;
  9033. begin
  9034.   L := FindType(FType);
  9035.   if L = Cardinal(-1) then
  9036.     Result := nil
  9037.   else
  9038.     Result := AddTypeCopy(Name, L);
  9039. end;
  9040.  
  9041.  
  9042. function TIFPSPascalCompiler.AddUsedVariable(const Name: string;
  9043.   FType: Cardinal): PIFPSVar;
  9044. begin
  9045.   Result := AddVariable(Name, FType);
  9046.   if Result <> nil then
  9047.     Result^.Used := True;
  9048. end;
  9049.  
  9050. function TIFPSPascalCompiler.AddUsedVariableN(const Name,
  9051.   FType: string): PIFPSVar;
  9052. begin
  9053.   Result := AddVariable(Name, FindType(FType));
  9054.   if Result <> nil then
  9055.     Result^.Used := True;
  9056. end;
  9057.  
  9058. function TIFPSPascalCompiler.AddVariableN(const Name,
  9059.   FType: string): PIFPSVar;
  9060. begin
  9061.   Result := AddVariable(Name, FindType(FType));
  9062. end;
  9063.  
  9064. function TIFPSPascalCompiler.AddTypeS(const Name, Decl: string): PIFPSType;
  9065. var
  9066.   Parser: TIfPascalParser;
  9067. begin
  9068.   Parser := TIfPascalParser.Create;
  9069.   Parser.SetText(Decl);
  9070.   Result := FAvailableTypes.GetItem(ReadType(FastUppercase(Name), Parser));
  9071.   Parser.Free;
  9072. end;
  9073.  
  9074.  
  9075. function TIFPSPascalCompiler.CheckCompatProc(FTypeNo,
  9076.   ProcNo: Cardinal): Boolean;
  9077. var
  9078.   s1,s2: string;
  9079.   P: PIFPSType;
  9080.  
  9081.   function c(const e1,e2: string): Boolean;
  9082.   begin
  9083.     Result := (Length(e1) = 0) or (Length(e2) = 0) or (e1[1] <> e2[1]);  
  9084.   end;
  9085. begin
  9086.   P := FUsedTypes.GetItem(FTypeNo);
  9087.   if p^.BaseType <> btProcPtr then begin
  9088.     Result := False;
  9089.     Exit;
  9090.   end;
  9091.  
  9092.   S1 := PIFPSProceduralType(p^.Ext)^.ProcDef;
  9093.  
  9094.   if PIFPSProcedure(FProcs.GetItem(ProcNo))^.Internal then
  9095.     s2 := PIFPSProcedure(FProcs.GetItem(ProcNo))^.Decl
  9096.   else
  9097.     s2 := PIFPSUsedRegProc(FProcs.GetItem(ProcNo))^.RP^.Decl;
  9098.   if GRFW(s1) <> GRFW(s2) then begin
  9099.     Result := False;
  9100.     Exit;
  9101.   end;
  9102.   while Length(s1) > 0 do
  9103.   begin
  9104.     if c(GRFW(s1), GRFW(s2)) or (GRFW(s1) <> GRFW(s2)) then begin
  9105.       Result := False;
  9106.       Exit;
  9107.     end;
  9108.   end;
  9109.   Result := True;
  9110. end;
  9111.  
  9112. function TIFPSPascalCompiler.MakeExportDecl(decl: string): string;
  9113. var
  9114.   c: char;
  9115. begin
  9116.   result := grfw(decl);
  9117.   while length(decl) > 0 do
  9118.   begin
  9119.     c := grfw(decl)[1];
  9120.     result := result +' '+c+grfw(decl);
  9121.   end;
  9122. end;
  9123.  
  9124.  
  9125. function TIFPSPascalCompiler.IsIntBoolType(FTypeNo: Cardinal): Boolean;
  9126. var
  9127.   f: PIFPSType;
  9128. begin
  9129.   if FTypeNo = at2ut(FBooleanType) then begin Result := True; exit;end;
  9130.   f := FUsedTypes.GetItem(FTypeNo);
  9131.   
  9132.   case f^.BaseType of
  9133.     btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF NOINT64}, btS64{$ENDIF}: Result := True;
  9134.   else
  9135.     Result := False;
  9136.   end;
  9137. end;
  9138.  
  9139. function TIFPSPascalCompiler.AddExportVariableN(const Name,
  9140.   FType: string): PIFPSVar;
  9141. begin
  9142.   Result := AddVariableN(Name, FType);
  9143.   if Result <> nil then
  9144.     Result^.exportname := FastUppercase(Name);
  9145. end;
  9146.  
  9147. function TIFPSPascalCompiler.AddUsedExportVariableN(const Name,
  9148.   FType: string): PIFPSVar;
  9149. begin
  9150.   Result := AddUsedVariableN(Name, FType);
  9151.   if Result <> nil then
  9152.     Result^.exportname := FastUppercase(Name);
  9153. end;
  9154.  
  9155. procedure TIFPSPascalCompiler.ParserError(Parser: TObject;
  9156.   Kind: TIFParserErrorKind; Position: Cardinal);
  9157. begin
  9158.   case Kind of
  9159.     ICOMMENTERROR: MakeError('', ecCommentError, '')^.Position := Position;
  9160.     ISTRINGERROR: MakeError('', ecStringError, '')^.Position := Position;
  9161.     ICHARERROR: MakeError('', ecCharError, '')^.Position := Position;
  9162.   else
  9163.     MakeError('', ecSyntaxError, '')^.Position := Position;
  9164.   end;
  9165. end;
  9166.  
  9167. { TIFPSExternalClass }
  9168. function TIFPSExternalClass.SetNil(TypeNo: Cardinal; var ProcNo: Cardinal): Boolean;
  9169. begin
  9170.   Result := False;
  9171. end;
  9172.  
  9173. function TIFPSExternalClass.ClassFunc_Call(Index: Cardinal;
  9174.   var ProcNo: Cardinal): Boolean;
  9175. begin
  9176.   Result := False;
  9177. end;
  9178.  
  9179. function TIFPSExternalClass.ClassFunc_Find(const Name: string;
  9180.   var Index: Cardinal): Boolean;
  9181. begin
  9182.   Result := False;
  9183. end;
  9184.  
  9185. constructor TIFPSExternalClass.Create(Se: TIFPSPascalCompiler);
  9186. begin
  9187.   inherited Create;
  9188.   Self.SE := se;
  9189. end;
  9190.  
  9191. function TIFPSExternalClass.Func_Call(Index: Cardinal;
  9192.   var ProcNo: Cardinal): Boolean;
  9193. begin
  9194.   Result := False;
  9195. end;
  9196.  
  9197. function TIFPSExternalClass.Func_Find(const Name: string;
  9198.   var Index: Cardinal): Boolean;
  9199. begin
  9200.   Result := False;
  9201. end;
  9202.  
  9203.  
  9204. function TIFPSExternalClass.IsCompatibleWith(
  9205.   Cl: TIFPSExternalClass): Boolean;
  9206. begin
  9207.   Result := False;
  9208. end;
  9209.  
  9210. function TIFPSExternalClass.Property_Find(const Name: string;
  9211.   var Index: Cardinal): Boolean;
  9212. begin
  9213.   Result := False;
  9214. end;
  9215.  
  9216. function TIFPSExternalClass.Property_Get(Index: Cardinal;
  9217.   var ProcNo: Cardinal): Boolean;
  9218. begin
  9219.   Result := False;
  9220. end;
  9221.  
  9222.  
  9223. function TIFPSExternalClass.Property_GetHeader(Index: Cardinal;
  9224.   var s: string): Boolean;
  9225. begin
  9226.   Result := False;
  9227. end;
  9228.  
  9229. function TIFPSExternalClass.Property_Set(Index: Cardinal;
  9230.   var ProcNo: Cardinal): Boolean;
  9231. begin
  9232.   Result := False;
  9233. end;
  9234.  
  9235. function TIFPSExternalClass.SelfType: Cardinal;
  9236. begin
  9237.   Result := Cardinal(-1);
  9238. end;
  9239.  
  9240. function TIFPSExternalClass.CastToType(TypeNo, IntoType: Cardinal;
  9241.   var ProcNo: Cardinal): Boolean;
  9242. begin
  9243.   Result := False;
  9244. end;
  9245.  
  9246. function TIFPSExternalClass.CompareClass(OtherTypeNo: Cardinal;
  9247.   var ProcNo: Cardinal): Boolean;
  9248. begin
  9249.   Result := false;
  9250. end;
  9251.  
  9252. {  }
  9253.  
  9254. function TransDoubleToStr(D: Double): string;
  9255. begin
  9256.   SetLength(Result, SizeOf(Double));
  9257.   Double((@Result[1])^) := D;
  9258. end;
  9259.  
  9260. function TransSingleToStr(D: Single): string;
  9261. begin
  9262.   SetLength(Result, SizeOf(Single));
  9263.   Single((@Result[1])^) := D;
  9264. end;
  9265.  
  9266. function TransExtendedToStr(D: Extended): string;
  9267. begin
  9268.   SetLength(Result, SizeOf(Extended));
  9269.   Extended((@Result[1])^) := D;
  9270. end;
  9271.  
  9272. function TransLongintToStr(D: Longint): string;
  9273. begin
  9274.   SetLength(Result, SizeOf(Longint));
  9275.   Longint((@Result[1])^) := D;
  9276. end;
  9277.  
  9278. function TransCardinalToStr(D: Cardinal): string;
  9279. begin
  9280.   SetLength(Result, SizeOf(Cardinal));
  9281.   Cardinal((@Result[1])^) := D;
  9282. end;
  9283.  
  9284. function TransWordToStr(D: Word): string;
  9285. begin
  9286.   SetLength(Result, SizeOf(Word));
  9287.   Word((@Result[1])^) := D;
  9288. end;
  9289.  
  9290. function TransSmallIntToStr(D: SmallInt): string;
  9291. begin
  9292.   SetLength(Result, SizeOf(SmallInt));
  9293.   SmallInt((@Result[1])^) := D;
  9294. end;
  9295.  
  9296. function TransByteToStr(D: Byte): string;
  9297. begin
  9298.   SetLength(Result, SizeOf(Byte));
  9299.   Byte((@Result[1])^) := D;
  9300. end;
  9301.  
  9302. function TransShortIntToStr(D: ShortInt): string;
  9303. begin
  9304.   SetLength(Result, SizeOf(ShortInt));
  9305.   ShortInt((@Result[1])^) := D;
  9306. end;
  9307.  
  9308. {
  9309.  
  9310. Internal error counter: 0001D (increase and then use)
  9311.  
  9312. }
  9313.  
  9314.  
  9315.  
  9316. end.
  9317.  
  9318.  
  9319.