Parser.pas

// Based on XD Pascal (2020) original code by Vasiliy Tereshkov
// Refactoring and extensions by Wanderlan
{$I-,H-}
unit Parser;

interface

uses
  SysUtils, Common, Scanner, CodeGen, Linker;

function Compile(const Name: TString): Integer;

implementation

type
  TParserState = record
    IsUnit, IsInterfaceSection: Boolean;
    UnitStatus: TUnitStatus;
  end;

var
  ParserState: TParserState;

procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Integer); forward;
function CompileDesignator(var ValType: Integer; AllowConst: Boolean = True): Boolean; forward;
procedure CompileExpression(var ValType: Integer); forward;
procedure CompileStatement(LoopNesting: Integer); forward;
procedure CompileType(var DataType: Integer); forward;

procedure DeclareIdent(const IdentName: TString; IdentKind: TIdentKind; TotalParamDataSize: Integer; IdentIsInCStack: Boolean; IdentDataType: Integer;
  IdentPassMethod: TPassMethod; IdentOrdConstValue: Longint; IdentRealConstValue: Double; const IdentStrConstValue: TString;
  const IdentSetConstValue: TByteSet; IdentPredefProc: TPredefProc; const IdentReceiverName: TString; IdentReceiverType: Integer);
var
  i, AdditionalStackItems, IdentTypeSize: Integer;
  IdentScope: TScope;
begin
  if BlockStack[BlockStackTop].Index = 1 then
    IdentScope := GLOBAL
  else
    IdentScope := LOCAL;
  i := GetIdentUnsafe(IdentName, False, IdentReceiverType);
  if (i > 0) and (Ident[i].UnitIndex = ParserState.UnitStatus.Index) and (Ident[i].Block = BlockStack[BlockStackTop].Index) then
    Error('Duplicate identifier ' + IdentName);
  Inc(NumIdent);
  if NumIdent > MAXIDENTS then
    Error('Maximum number of identifiers exceeded');
  with Ident[NumIdent] do begin
    Kind           := IdentKind;
    Name           := IdentName;
    Address        := 0;
    Scope          := IdentScope;
    RelocType      := UNINITDATARELOC;
    DataType       := IdentDataType;
    UnitIndex      := ParserState.UnitStatus.Index;
    Block          := BlockStack[BlockStackTop].Index;
    NestingLevel   := BlockStackTop;
    ReceiverName   := IdentReceiverName;
    ReceiverType   := IdentReceiverType;
    Signature.NumParams := 0;
    Signature.CallConv := DEFAULTCONV;
    PassMethod     := IdentPassMethod;
    IsUsed         := False;
    IsUnresolvedForward := False;
    IsExported     := ParserState.IsInterfaceSection and (IdentScope = GLOBAL);
    IsTypedConst   := False;
    IsInCStack     := IdentIsInCStack;
    ForLoopNesting := 0;
  end;
  case IdentKind of
    PROC, FUNC: begin
      Ident[NumIdent].Signature.ResultType := IdentDataType;
      if IdentPredefProc = EMPTYPROC then begin
        Ident[NumIdent].Address    := GetCodeSize;                            // Routine entry point address
        Ident[NumIdent].PredefProc := EMPTYPROC;
      end
      else begin
        Ident[NumIdent].Address    := 0;
        Ident[NumIdent].PredefProc := IdentPredefProc;                     // Predefined routine index
      end;
    end;
    VARIABLE: case IdentScope of
        GLOBAL: begin
          IdentTypeSize := TypeSize(IdentDataType);
          if IdentTypeSize > MAXUNINITIALIZEDDATASIZE - UninitializedGlobalDataSize then
            Error('Not enough memory for global variable');
          Ident[NumIdent].Address     := UninitializedGlobalDataSize;                                 // Variable address (relocatable)
          UninitializedGlobalDataSize := UninitializedGlobalDataSize + IdentTypeSize;
        end;// else
        LOCAL: if TotalParamDataSize > 0 then               // Declare parameter (always 4 bytes, except structures in the C stack and doubles)
          begin
            if Ident[NumIdent].NestingLevel = 2 then                                            // Inside a non-nested routine
              AdditionalStackItems := 1                                                         // Return address
            else                                                                                // Inside a nested routine
              AdditionalStackItems := 2;                                                        // Return address, static link (hidden parameter)
            with BlockStack[BlockStackTop] do begin
              if (IdentIsInCStack or (Types[IdentDataType].Kind = REALTYPE)) and (IdentPassMethod = VALPASSING) then
                IdentTypeSize := Align(TypeSize(IdentDataType), SizeOf(Longint))
              else
                IdentTypeSize := SizeOf(Longint);
              if IdentTypeSize > MAXSTACKSIZE - ParamDataSize then
                Error('Not enough memory for parameter');
              Ident[NumIdent].Address := AdditionalStackItems * SizeOf(Longint) + TotalParamDataSize - ParamDataSize - (IdentTypeSize - SizeOf(Longint));
              // Parameter offset from EBP (>0)
              ParamDataSize           := ParamDataSize + IdentTypeSize;
            end;
          end
          else
            with BlockStack[BlockStackTop] do          // Declare local variable
            begin
              IdentTypeSize := TypeSize(IdentDataType);
              if IdentTypeSize > MAXSTACKSIZE - LocalDataSize then
                Error('Not enough memory for local variable');
              Ident[NumIdent].Address := -LocalDataSize - IdentTypeSize;                          // Local variable offset from EBP (<0)
              LocalDataSize           := LocalDataSize + IdentTypeSize;
            end;
      end; // case

    CONSTANT: if IdentPassMethod = EMPTYPASSING then                              // Untyped constant
        case Types[IdentDataType].Kind of
          SETTYPE: begin
            Ident[NumIdent].ConstVal.SetValue := IdentSetConstValue;
            DefineStaticSet(Ident[NumIdent].ConstVal.SetValue, Ident[NumIdent].Address);
          end;
          ARRAYTYPE: begin
            Ident[NumIdent].ConstVal.StrValue := IdentStrConstValue;
            DefineStaticString(Ident[NumIdent].ConstVal.StrValue, Ident[NumIdent].Address);
          end;
          REALTYPE: Ident[NumIdent].ConstVal.RealValue := IdentRealConstValue;       // Real constant value
          else Ident[NumIdent].ConstVal.OrdValue := IdentOrdConstValue;              // Ordinal constant value
        end
      else                                                                // Typed constant (actually an initialized global variable)
      begin
        with Ident[NumIdent] do begin
          Kind         := VARIABLE;
          Scope        := GLOBAL;
          RelocType    := INITDATARELOC;
          PassMethod   := EMPTYPASSING;
          IsTypedConst := True;
        end;
        IdentTypeSize := TypeSize(IdentDataType);
        if IdentTypeSize > MAXINITIALIZEDDATASIZE - InitializedGlobalDataSize then
          Error('Not enough memory for initialized global variable');
        Ident[NumIdent].Address   := InitializedGlobalDataSize;               // Typed constant address (relocatable)
        InitializedGlobalDataSize := InitializedGlobalDataSize + IdentTypeSize;
      end;
    GOTOLABEL: Ident[NumIdent].IsUnresolvedForward := True;
  end;// case
end;  // DeclareIdent

procedure DeclareType(TypeKind: TTypeKind);
begin
  Inc(NumTypes);
  if NumTypes > MAXTYPES then
    Error('Maximum number of types exceeded');
  with Types[NumTypes] do begin
    Kind  := TypeKind;
    Block := BlockStack[BlockStackTop].Index;
  end;
end; // DeclareType  

procedure DeclarePredefinedIdents;
begin
  // Constants
  DeclareIdent('TRUE', CONSTANT, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 1, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('FALSE', CONSTANT, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  // Types
  DeclareIdent('INTEGER', USERTYPE, 0, False, INTEGERTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('SMALLINT', USERTYPE, 0, False, SMALLINTTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('SHORTINT', USERTYPE, 0, False, SHORTINTTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('WORD', USERTYPE, 0, False, WORDTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('BYTE', USERTYPE, 0, False, BYTETYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('CHAR', USERTYPE, 0, False, CHARTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('BOOLEAN', USERTYPE, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('REAL', USERTYPE, 0, False, REALTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('SINGLE', USERTYPE, 0, False, SINGLETYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  DeclareIdent('POINTER', USERTYPE, 0, False, POINTERTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
  // Procedures
  DeclareIdent('INC', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], INCPROC, '', 0);
  DeclareIdent('DEC', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], DECPROC, '', 0);
  DeclareIdent('READ', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], READPROC, '', 0);
  DeclareIdent('WRITE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], WRITEPROC, '', 0);
  DeclareIdent('READLN', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], READLNPROC, '', 0);
  DeclareIdent('WRITELN', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], WRITELNPROC, '', 0);
  DeclareIdent('NEW', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], NEWPROC, '', 0);
  DeclareIdent('DISPOSE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], DISPOSEPROC, '', 0);
  DeclareIdent('BREAK', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], BREAKPROC, '', 0);
  DeclareIdent('CONTINUE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], CONTINUEPROC, '', 0);
  DeclareIdent('EXIT', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EXITPROC, '', 0);
  DeclareIdent('HALT', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], HALTPROC, '', 0);
  // Functions
  DeclareIdent('SIZEOF', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SIZEOFFUNC, '', 0);
  DeclareIdent('ORD', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ORDFUNC, '', 0);
  DeclareIdent('CHR', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], CHRFUNC, '', 0);
  DeclareIdent('LOW', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], LOWFUNC, '', 0);
  DeclareIdent('HIGH', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], HIGHFUNC, '', 0);
  DeclareIdent('PRED', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], PREDFUNC, '', 0);
  DeclareIdent('SUCC', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SUCCFUNC, '', 0);
  DeclareIdent('ROUND', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ROUNDFUNC, '', 0);
  DeclareIdent('TRUNC', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], TRUNCFUNC, '', 0);
  DeclareIdent('ABS', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ABSFUNC, '', 0);
  DeclareIdent('SQR', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SQRFUNC, '', 0);
  DeclareIdent('SIN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SINFUNC, '', 0);
  DeclareIdent('COS', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], COSFUNC, '', 0);
  DeclareIdent('ARCTAN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ARCTANFUNC, '', 0);
  DeclareIdent('EXP', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EXPFUNC, '', 0);
  DeclareIdent('LN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], LNFUNC, '', 0);
  DeclareIdent('SQRT', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SQRTFUNC, '', 0);
end;// DeclarePredefinedIdents

procedure DeclarePredefinedTypes;
begin
  NumTypes := STRINGTYPEINDEX;
  Types[ANYTYPEINDEX].Kind := ANYTYPE;
  Types[INTEGERTYPEINDEX].Kind := INTEGERTYPE;
  Types[SMALLINTTYPEINDEX].Kind := SMALLINTTYPE;
  Types[SHORTINTTYPEINDEX].Kind := SHORTINTTYPE;
  Types[WORDTYPEINDEX].Kind := WORDTYPE;
  Types[BYTETYPEINDEX].Kind := BYTETYPE;
  Types[CHARTYPEINDEX].Kind := CHARTYPE;
  Types[BOOLEANTYPEINDEX].Kind := BOOLEANTYPE;
  Types[REALTYPEINDEX].Kind := REALTYPE;
  Types[SINGLETYPEINDEX].Kind := SINGLETYPE;
  Types[POINTERTYPEINDEX].Kind := POINTERTYPE;
  Types[FILETYPEINDEX].Kind := FILETYPE;
  Types[STRINGTYPEINDEX].Kind := ARRAYTYPE;
  Types[POINTERTYPEINDEX].BaseType := ANYTYPEINDEX;
  Types[FILETYPEINDEX].BaseType := ANYTYPEINDEX;
  // Add new anonymous type: 1 .. MAXSTRLENGTH + 1
  DeclareType(SUBRANGETYPE);
  Types[NumTypes].BaseType := INTEGERTYPEINDEX;
  Types[NumTypes].Low      := 1;
  Types[NumTypes].High     := MAXSTRLENGTH + 1;
  Types[STRINGTYPEINDEX].BaseType := CHARTYPEINDEX;
  Types[STRINGTYPEINDEX].IndexType := NumTypes;
  Types[STRINGTYPEINDEX].IsOpenArray := False;
end;// DeclarePredefinedTypes

function AllocateTempStorage(Size: Integer): Integer;
begin
  with BlockStack[BlockStackTop] do begin
    TempDataSize := TempDataSize + Size;
    Result       := -LocalDataSize - TempDataSize;
  end;
end; // AllocateTempStorage

procedure PushTempStoragePtr(Addr: Integer);
begin
  PushVarPtr(Addr, LOCAL, 0, UNINITDATARELOC);
end; // PushTempStoragePtr

procedure PushVarIdentPtr(IdentIndex: Integer);
begin
  PushVarPtr(Ident[IdentIndex].Address, Ident[IdentIndex].Scope, BlockStackTop - Ident[IdentIndex].NestingLevel, Ident[IdentIndex].RelocType);
  Ident[IdentIndex].IsUsed := True;
end; // PushVarIdentPtr

procedure ConvertConstIntegerToReal(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
begin
  // Try to convert an integer (right-hand side) into a real
  if (Types[DestType].Kind in [REALTYPE, SINGLETYPE]) and ((Types[SrcType].Kind in IntegerTypes) or ((Types[SrcType].Kind = SUBRANGETYPE) and
    (Types[Types[SrcType].BaseType].Kind in IntegerTypes))) then begin
    ConstVal.RealValue := ConstVal.OrdValue;
    SrcType := REALTYPEINDEX;
  end;
end; // ConvertConstIntegerToReal

procedure ConvertIntegerToReal(DestType: Integer; var SrcType: Integer; Depth: Integer);
begin
  // Try to convert an integer (right-hand side) into a real
  if (Types[DestType].Kind in [REALTYPE, SINGLETYPE]) and ((Types[SrcType].Kind in IntegerTypes) or ((Types[SrcType].Kind = SUBRANGETYPE) and
    (Types[Types[SrcType].BaseType].Kind in IntegerTypes))) then begin
    GenerateDoubleFromInteger(Depth);
    SrcType := REALTYPEINDEX;
  end;
end; // ConvertIntegerToReal

procedure ConvertConstRealToReal(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
begin
  // Try to convert a single (right-hand side) into a double or vice versa
  if (Types[DestType].Kind = REALTYPE) and (Types[SrcType].Kind = SINGLETYPE) then begin
    ConstVal.RealValue := ConstVal.SingleValue;
    SrcType := REALTYPEINDEX;
  end
  else
    if (Types[DestType].Kind = SINGLETYPE) and (Types[SrcType].Kind = REALTYPE) then begin
      ConstVal.SingleValue := ConstVal.RealValue;
      SrcType := SINGLETYPEINDEX;
    end;
end; // ConvertConstRealToReal

procedure ConvertRealToReal(DestType: Integer; var SrcType: Integer);
begin
  // Try to convert a single (right-hand side) into a double or vice versa
  if (Types[DestType].Kind = REALTYPE) and (Types[SrcType].Kind = SINGLETYPE) then begin
    GenerateDoubleFromSingle;
    SrcType := REALTYPEINDEX;
  end
  else
    if (Types[DestType].Kind = SINGLETYPE) and (Types[SrcType].Kind = REALTYPE) then begin
      GenerateSingleFromDouble;
      SrcType := SINGLETYPEINDEX;
    end;
end; // ConvertRealToReal

procedure ConvertConstCharToString(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
var
  ch: TCharacter;
begin
  if IsString(DestType) and ((Types[SrcType].Kind = CHARTYPE) or ((Types[SrcType].Kind = SUBRANGETYPE) and (Types[Types[SrcType].BaseType].Kind = CHARTYPE))) then begin
    ch      := Char(ConstVal.OrdValue);
    ConstVal.StrValue := ch;
    SrcType := STRINGTYPEINDEX;
  end;
end; // ConvertConstCharToString

procedure ConvertCharToString(DestType: Integer; var SrcType: Integer; Depth: Integer);
var
  TempStorageAddr: Longint;
begin
  // Try to convert a character (right-hand side) into a 2-character temporary string
  if IsString(DestType) and ((Types[SrcType].Kind = CHARTYPE) or ((Types[SrcType].Kind = SUBRANGETYPE) and (Types[Types[SrcType].BaseType].Kind = CHARTYPE))) then begin
    TempStorageAddr := AllocateTempStorage(2 * SizeOf(TCharacter));
    PushTempStoragePtr(TempStorageAddr);
    GetCharAsTempString(Depth);
    SrcType := STRINGTYPEINDEX;
  end;
end; // ConvertCharToString

procedure ConvertStringToPChar(DestType: Integer; var SrcType: Integer);
begin
  // Try to convert a string (right-hand side) into a pointer to character
  if (Types[DestType].Kind = POINTERTYPE) and (Types[Types[DestType].BaseType].Kind = CHARTYPE) and IsString(SrcType) then
    SrcType := DestType;
end; // ConvertStringToPChar

procedure ConvertToInterface(DestType: Integer; var SrcType: Integer);
var
  SrcField, DestField:     PField;
  TempStorageAddr:         Longint;
  FieldIndex, MethodIndex: Integer;
begin
  // Try to convert a concrete or interface type to an interface type
  if (Types[DestType].Kind = INTERFACETYPE) and (DestType <> SrcType) then begin
    // Allocate new interface variable
    TempStorageAddr := AllocateTempStorage(TypeSize(DestType));
    // Set interface's Self pointer (offset 0) to the concrete/interface data
    if Types[SrcType].Kind = INTERFACETYPE then begin
      DuplicateStackTop;
      DerefPtr(POINTERTYPEINDEX);
      GenerateInterfaceFieldAssignment(TempStorageAddr, True, 0, UNINITDATARELOC);
      DiscardStackTop(1);
    end
    else
      GenerateInterfaceFieldAssignment(TempStorageAddr, True, 0, UNINITDATARELOC);
    // Set interface's procedure pointers to the concrete/interface methods
    for FieldIndex := 2 to Types[DestType].NumFields do begin
      DestField := Types[DestType].Field[FieldIndex];
      if Types[SrcType].Kind = INTERFACETYPE then       // Interface to interface
      begin
        SrcField := Types[SrcType].Field[GetField(SrcType, DestField^.Name)];
        CheckSignatures(Types[SrcField^.DataType].Signature, Types[DestField^.DataType].Signature, SrcField^.Name, False);
        DuplicateStackTop;
        GetFieldPtr(SrcField^.Offset);
        DerefPtr(POINTERTYPEINDEX);
        GenerateInterfaceFieldAssignment(TempStorageAddr + (FieldIndex - 1) * POINTER_SIZE, True, 0, CODERELOC);
        DiscardStackTop(1);
      end
      else                                              // Concrete to interface
      begin
        MethodIndex := GetMethod(SrcType, DestField^.Name);
        CheckSignatures(Ident[MethodIndex].Signature, Types[DestField^.DataType].Signature, Ident[MethodIndex].Name, False);
        GenerateInterfaceFieldAssignment(TempStorageAddr + (FieldIndex - 1) * POINTER_SIZE, False, Ident[MethodIndex].Address, CODERELOC);
      end;
    end; // for  
    DiscardStackTop(1);                                       // Remove source pointer
    PushTempStoragePtr(TempStorageAddr);   // Push destination pointer
    SrcType := DestType;
  end;
end; // ConvertToInterface

procedure CompileConstPredefinedFunc(func: TPredefProc; var ConstVal: TConst; var ConstValType: Integer);
var
  IdentIndex: Integer;
begin
  NextTok;
  EatTok(OPARTOK);
  case func of
    SIZEOFFUNC: begin
      AssertIdent;
      IdentIndex := GetIdentUnsafe(Tok.Name);
      if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then   // Type name
      begin
        NextTok;
        ConstVal.OrdValue := TypeSize(Ident[IdentIndex].DataType);
      end
      else                                                                // Variable name
        Error('Type name expected');
      ConstValType := INTEGERTYPEINDEX;
    end;
    ROUNDFUNC, TRUNCFUNC: begin
      CompileConstExpression(ConstVal, ConstValType);
      if not (Types[ConstValType].Kind in IntegerTypes) then begin
        GetCompatibleType(ConstValType, REALTYPEINDEX);
        if func = TRUNCFUNC then
          ConstVal.OrdValue := Trunc(ConstVal.RealValue)
        else
          ConstVal.OrdValue := Round(ConstVal.RealValue);
      end;
      ConstValType := INTEGERTYPEINDEX;
    end;
    ORDFUNC: begin
      CompileConstExpression(ConstVal, ConstValType);
      if not (Types[ConstValType].Kind in OrdinalTypes) then
        Error('Ordinal type expected');
      ConstValType := INTEGERTYPEINDEX;
    end;
    CHRFUNC: begin
      CompileConstExpression(ConstVal, ConstValType);
      GetCompatibleType(ConstValType, INTEGERTYPEINDEX);
      ConstValType := CHARTYPEINDEX;
    end;
    LOWFUNC, HIGHFUNC: begin
      AssertIdent;
      IdentIndex := GetIdentUnsafe(Tok.Name);
      if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then   // Type name
      begin
        NextTok;
        ConstValType := Ident[IdentIndex].DataType;
      end
      else                                                                // Variable name
        Error('Type name expected');
      if (Types[ConstValType].Kind = ARRAYTYPE) and not Types[ConstValType].IsOpenArray then
        ConstValType := Types[ConstValType].IndexType;
      if func = HIGHFUNC then
        ConstVal.OrdValue := HighBound(ConstValType)
      else
        ConstVal.OrdValue := LowBound(ConstValType);
    end;
    PREDFUNC, SUCCFUNC: begin
      CompileConstExpression(ConstVal, ConstValType);
      if not (Types[ConstValType].Kind in OrdinalTypes) then
        Error('Ordinal type expected');
      if func = SUCCFUNC then
        Inc(ConstVal.OrdValue)
      else
        Dec(ConstVal.OrdValue);
    end;
    ABSFUNC, SQRFUNC, SINFUNC, COSFUNC, ARCTANFUNC, EXPFUNC, LNFUNC, SQRTFUNC: begin
      CompileConstExpression(ConstVal, ConstValType);
      if (func = ABSFUNC) or (func = SQRFUNC) then                          // Abs and Sqr accept real or integer parameters
      begin
        if not ((Types[ConstValType].Kind in NumericTypes) or ((Types[ConstValType].Kind = SUBRANGETYPE) and
          (Types[Types[ConstValType].BaseType].Kind in NumericTypes))) then
          Error('Numeric type expected');
        if Types[ConstValType].Kind = REALTYPE then
          if func = ABSFUNC then
            ConstVal.RealValue := abs(ConstVal.RealValue)
          else
            ConstVal.RealValue := sqr(ConstVal.RealValue)
        else
          if func = ABSFUNC then
            ConstVal.OrdValue := abs(ConstVal.OrdValue)
          else
            ConstVal.OrdValue := sqr(ConstVal.OrdValue);
      end
      else
        Error('Function is not allowed in constant expressions');
    end;
  end;
  EatTok(CPARTOK);
end;

procedure CompileConstSetConstructor(var ConstVal: TConst; var ConstValType: Integer);
var
  ElementVal, ElementVal2: TConst;
  ElementValType: Integer;
  ElementIndex: Integer;
begin
  ConstVal.SetValue := [];
  // Add new anonymous type
  DeclareType(SETTYPE);
  Types[NumTypes].BaseType := ANYTYPEINDEX;
  ConstValType := NumTypes;
  // Compile constructor
  EatTok(OBRACKETTOK);
  if Tok.Kind <> CBRACKETTOK then
    repeat
      CompileConstExpression(ElementVal, ElementValType);
      if Types[ConstValType].BaseType = ANYTYPEINDEX then begin
        if not (Types[ElementValType].Kind in OrdinalTypes) then
          Error('Ordinal type expected');
        Types[ConstValType].BaseType := ElementValType;
      end
      else
        GetCompatibleType(ElementValType, Types[ConstValType].BaseType);
      if Tok.Kind = RANGETOK then begin
        NextTok;
        CompileConstExpression(ElementVal2, ElementValType);
        GetCompatibleType(ElementValType, Types[ConstValType].BaseType);
      end
      else
        ElementVal2 := ElementVal;
      if (ElementVal.OrdValue < 0) or (ElementVal.OrdValue >= MAXSETELEMENTS) or (ElementVal2.OrdValue < 0) or (ElementVal2.OrdValue >= MAXSETELEMENTS) then
        Error('Set elements must be between 0 and ' + IntToStr(MAXSETELEMENTS - 1));
      for ElementIndex := ElementVal.OrdValue to ElementVal2.OrdValue do
        ConstVal.SetValue := ConstVal.SetValue + [ElementIndex];
      if Tok.Kind <> COMMATOK then
        Break;
      NextTok;
    until False;
  EatTok(CBRACKETTOK);
end; // CompileConstSetConstructor

procedure CompileConstFactor(var ConstVal: TConst; var ConstValType: Integer);
var
  NotOpTok:   TToken;
  IdentIndex: Integer;
begin
  case Tok.Kind of
    IDENTTOK: begin
      IdentIndex := GetIdent(Tok.Name);
      case Ident[IdentIndex].Kind of
        GOTOLABEL: Error('Constant expression expected but label ' + Ident[IdentIndex].Name + ' found');
        PROC: Error('Constant expression expected but procedure ' + Ident[IdentIndex].Name + ' found');
        FUNC: if Ident[IdentIndex].PredefProc <> EMPTYPROC then
            CompileConstPredefinedFunc(Ident[IdentIndex].PredefProc, ConstVal, ConstValType)
          else
            Error('Function ' + Ident[IdentIndex].Name + ' is not allowed in constant expressions');
        VARIABLE: Error('Constant expression expected but variable ' + Ident[IdentIndex].Name + ' found');
        CONSTANT: begin
          ConstValType := Ident[IdentIndex].DataType;
          case Types[ConstValType].Kind of
            SETTYPE: ConstVal.SetValue   := Ident[IdentIndex].ConstVal.SetValue;
            ARRAYTYPE: ConstVal.StrValue := Ident[IdentIndex].ConstVal.StrValue;
            REALTYPE: ConstVal.RealValue := Ident[IdentIndex].ConstVal.RealValue;
            else ConstVal.OrdValue := Ident[IdentIndex].ConstVal.OrdValue;
          end;
          NextTok;
        end;
        USERTYPE: Error('Constant expression expected but type ' + Ident[IdentIndex].Name + ' found');
        else Error('Internal fault: Illegal identifier');
      end; // case Ident[IdentIndex].Kind
    end;
    INTNUMBERTOK: begin
      ConstVal.OrdValue := Tok.OrdValue;
      ConstValType      := INTEGERTYPEINDEX;
      NextTok;
    end;
    REALNUMBERTOK: begin
      ConstVal.RealValue := Tok.RealValue;
      ConstValType       := REALTYPEINDEX;
      NextTok;
    end;
    CHARLITERALTOK: begin
      ConstVal.OrdValue := Tok.OrdValue;
      ConstValType      := CHARTYPEINDEX;
      NextTok;
    end;
    STRINGLITERALTOK: begin
      ConstVal.StrValue := Tok.Name;
      ConstValType      := STRINGTYPEINDEX;
      NextTok;
    end;
    OPARTOK: begin
      NextTok;
      CompileConstExpression(ConstVal, ConstValType);
      EatTok(CPARTOK);
    end;
    NOTTOK: begin
      NotOpTok := Tok;
      NextTok;
      CompileConstFactor(ConstVal, ConstValType);
      CheckOperator(NotOpTok, ConstValType);
      ConstVal.OrdValue := not ConstVal.OrdValue;
      if Types[ConstValType].Kind = BOOLEANTYPE then
        ConstVal.OrdValue := ConstVal.OrdValue and 1;
    end;
    OBRACKETTOK: CompileConstSetConstructor(ConstVal, ConstValType);
    else Error('Expression expected but ' + GetTokSpelling(Tok.Kind) + ' found');
  end;// case
end;  // CompileConstFactor
procedure CompileConstTerm(var ConstVal: TConst; var ConstValType: Integer);
var
  OpTok:         TToken;
  RightConstVal: TConst;
  RightConstValType: Integer;
begin
  CompileConstFactor(ConstVal, ConstValType);
  while Tok.Kind in MultiplicativeOperators do begin
    OpTok := Tok;
    NextTok;
    CompileConstFactor(RightConstVal, RightConstValType);
    // Try to convert integer to real
    ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
    ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
    // Special case: real division of two integers
    if OpTok.Kind = DIVTOK then begin
      ConvertConstIntegerToReal(REALTYPEINDEX, ConstValType, ConstVal);
      ConvertConstIntegerToReal(REALTYPEINDEX, RightConstValType, RightConstVal);
    end;
    ConstValType := GetCompatibleType(ConstValType, RightConstValType);
    // Special case: set intersection
    if (OpTok.Kind = MULTOK) and (Types[ConstValType].Kind = SETTYPE) then
      ConstVal.SetValue := ConstVal.SetValue * RightConstVal.SetValue
    // General rule
    else begin
      CheckOperator(OpTok, ConstValType);
      if Types[ConstValType].Kind = REALTYPE then        // Real constants
        case OpTok.Kind of
          MULTOK: ConstVal.RealValue := ConstVal.RealValue * RightConstVal.RealValue;
          DIVTOK: if RightConstVal.RealValue <> 0 then
              ConstVal.RealValue := ConstVal.RealValue / RightConstVal.RealValue
            else
              Error('Constant division by zero')
        end
      else                                               // Integer constants
      begin
        case OpTok.Kind of
          MULTOK: ConstVal.OrdValue := ConstVal.OrdValue * RightConstVal.OrdValue;
          IDIVTOK: if RightConstVal.OrdValue <> 0 then
              ConstVal.OrdValue := ConstVal.OrdValue div RightConstVal.OrdValue
            else
              Error('Constant division by zero');
          MODTOK: if RightConstVal.OrdValue <> 0 then
              ConstVal.OrdValue := ConstVal.OrdValue mod RightConstVal.OrdValue
            else
              Error('Constant division by zero');
          SHLTOK: ConstVal.OrdValue := ConstVal.OrdValue shl RightConstVal.OrdValue;
          SHRTOK: ConstVal.OrdValue := ConstVal.OrdValue shr RightConstVal.OrdValue;
          ANDTOK: ConstVal.OrdValue := ConstVal.OrdValue and RightConstVal.OrdValue;
        end;
        if Types[ConstValType].Kind = BOOLEANTYPE then
          ConstVal.OrdValue := ConstVal.OrdValue and 1;
      end; // else
    end;   // else
  end;// while
end;// CompileConstTerm
procedure CompileSimpleConstExpression(var ConstVal: TConst; var ConstValType: Integer);
var
  UnaryOpTok, OpTok: TToken;
  RightConstVal:     TConst;
  RightConstValType: Integer;
begin
  UnaryOpTok := Tok;
  if UnaryOpTok.Kind in UnaryOperators then
    NextTok;
  CompileConstTerm(ConstVal, ConstValType);
  if UnaryOpTok.Kind in UnaryOperators then
    CheckOperator(UnaryOpTok, ConstValType);
  if UnaryOpTok.Kind = MINUSTOK then      // Unary minus
    if Types[ConstValType].Kind = REALTYPE then
      ConstVal.RealValue := -ConstVal.RealValue
    else
      ConstVal.OrdValue  := -ConstVal.OrdValue;
  while Tok.Kind in AdditiveOperators do begin
    OpTok := Tok;
    NextTok;
    CompileConstTerm(RightConstVal, RightConstValType);
    // Try to convert integer to real
    ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
    ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
    // Try to convert character to string
    ConvertConstCharToString(RightConstValType, ConstValType, ConstVal);
    ConvertConstCharToString(ConstValType, RightConstValType, RightConstVal);
    ConstValType := GetCompatibleType(ConstValType, RightConstValType);
    // Special case: string concatenation
    if (OpTok.Kind = PLUSTOK) and IsString(ConstValType) and IsString(RightConstValType) then
      ConstVal.StrValue := ConstVal.StrValue + RightConstVal.StrValue
    // Special case: set union or difference
    else
      if (OpTok.Kind in [PLUSTOK, MINUSTOK]) and (Types[ConstValType].Kind = SETTYPE) then
        ConstVal.SetValue := ConstVal.SetValue + RightConstVal.SetValue
      // General rule
      else begin
        CheckOperator(OpTok, ConstValType);
        if Types[ConstValType].Kind = REALTYPE then       // Real constants
          case OpTok.Kind of
            PLUSTOK: ConstVal.RealValue  := ConstVal.RealValue + RightConstVal.RealValue;
            MINUSTOK: ConstVal.RealValue := ConstVal.RealValue - RightConstVal.RealValue;
          end
        else                                                  // Integer constants
        begin
          case OpTok.Kind of
            PLUSTOK: ConstVal.OrdValue  := ConstVal.OrdValue + RightConstVal.OrdValue;
            MINUSTOK: ConstVal.OrdValue := ConstVal.OrdValue - RightConstVal.OrdValue;
            ORTOK: ConstVal.OrdValue    := ConstVal.OrdValue or RightConstVal.OrdValue;
            XORTOK: ConstVal.OrdValue   := ConstVal.OrdValue xor RightConstVal.OrdValue;
          end;
          if Types[ConstValType].Kind = BOOLEANTYPE then
            ConstVal.OrdValue := ConstVal.OrdValue and 1;
        end;
      end;
  end;// while
end;  // CompileSimpleConstExpression
procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Integer);
var
  OpTok:         TToken;
  RightConstVal: TConst;
  RightConstValType: Integer;
  Yes:           Boolean;
begin
  Yes := False;
  CompileSimpleConstExpression(ConstVal, ConstValType);
  if Tok.Kind in RelationOperators then begin
    OpTok := Tok;
    NextTok;
    CompileSimpleConstExpression(RightConstVal, RightConstValType);
    // Try to convert integer to real
    ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
    ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
    // Try to convert character to string
    ConvertConstCharToString(RightConstValType, ConstValType, ConstVal);
    ConvertConstCharToString(ConstValType, RightConstValType, RightConstVal);
    GetCompatibleType(ConstValType, RightConstValType);
    // Special case: string comparison
    if IsString(ConstValType) and IsString(RightConstValType) then
      case OpTok.Kind of
        EQTOK: Yes := ConstVal.StrValue = RightConstVal.StrValue;
        NETOK: Yes := ConstVal.StrValue <> RightConstVal.StrValue;
        LTTOK: Yes := ConstVal.StrValue < RightConstVal.StrValue;
        LETOK: Yes := ConstVal.StrValue <= RightConstVal.StrValue;
        GTTOK: Yes := ConstVal.StrValue > RightConstVal.StrValue;
        GETOK: Yes := ConstVal.StrValue >= RightConstVal.StrValue;
      end
    // Special case: set comparison
    else
      if (OpTok.Kind in [EQTOK, NETOK, GETOK, LETOK]) and (Types[ConstValType].Kind = SETTYPE) then
        case OpTok.Kind of
          EQTOK: Yes := ConstVal.SetValue = RightConstVal.SetValue;
          NETOK: Yes := ConstVal.SetValue <> RightConstVal.SetValue;
          LETOK: Yes := ConstVal.SetValue <= RightConstVal.SetValue;
          GETOK: Yes := ConstVal.SetValue >= RightConstVal.SetValue;
        end
      // General rule
      else begin
        CheckOperator(OpTok, ConstValType);
        if Types[ConstValType].Kind = REALTYPE then
          case OpTok.Kind of
            EQTOK: Yes := ConstVal.RealValue = RightConstVal.RealValue;
            NETOK: Yes := ConstVal.RealValue <> RightConstVal.RealValue;
            LTTOK: Yes := ConstVal.RealValue < RightConstVal.RealValue;
            LETOK: Yes := ConstVal.RealValue <= RightConstVal.RealValue;
            GTTOK: Yes := ConstVal.RealValue > RightConstVal.RealValue;
            GETOK: Yes := ConstVal.RealValue >= RightConstVal.RealValue;
          end
        else
          case OpTok.Kind of
            EQTOK: Yes := ConstVal.OrdValue = RightConstVal.OrdValue;
            NETOK: Yes := ConstVal.OrdValue <> RightConstVal.OrdValue;
            LTTOK: Yes := ConstVal.OrdValue < RightConstVal.OrdValue;
            LETOK: Yes := ConstVal.OrdValue <= RightConstVal.OrdValue;
            GTTOK: Yes := ConstVal.OrdValue > RightConstVal.OrdValue;
            GETOK: Yes := ConstVal.OrdValue >= RightConstVal.OrdValue;
          end;
      end;
    if Yes then
      ConstVal.OrdValue := 1
    else
      ConstVal.OrdValue := 0;
    ConstValType := BOOLEANTYPEINDEX;
  end;
end;// CompileConstExpression
procedure CompilePredefinedProc(proc: TPredefProc; LoopNesting: Integer);
  function GetReadProcIdent(DataType: Integer): Integer;
  begin
    Result := 0;
    with Types[DataType] do
      if (Kind = INTEGERTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = INTEGERTYPE)) then
        Result := GetIdent('READINT')                 // Integer argument
      else
        if (Kind = SMALLINTTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = SMALLINTTYPE)) then
          Result := GetIdent('READSMALLINT')            // Small integer argument
        else
          if (Kind = SHORTINTTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = SHORTINTTYPE)) then
            Result := GetIdent('READSHORTINT')            // Short integer argument
          else
            if (Kind = WORDTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = WORDTYPE)) then
              Result := GetIdent('READWORD')                // Word argument
            else
              if (Kind = BYTETYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BYTETYPE)) then
                Result := GetIdent('READBYTE')                // Byte argument
              else
                if (Kind = BOOLEANTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BOOLEANTYPE)) then
                  Result := GetIdent('READBOOLEAN')             // Boolean argument
                else
                  if (Kind = CHARTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = CHARTYPE)) then
                    Result := GetIdent('READCH')                  // Character argument
                  else
                    if Kind = REALTYPE then
                      Result := GetIdent('READREAL')                // Real argument
                    else
                      if Kind = SINGLETYPE then
                        Result := GetIdent('READSINGLE')              // Single argument
                      else
                        if (Kind = ARRAYTYPE) and (BaseType = CHARTYPEINDEX) then
                          Result := GetIdent('READSTRING')              // String argument
                        else
                          Error('Cannot read ' + GetTypeSpelling(DataType));
  end; // GetReadProcIdent
  function GetWriteProcIdent(DataType: Integer): Integer;
  begin
    Result := 0;
    with Types[DataType] do
      if (Kind in IntegerTypes) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind in IntegerTypes)) then
        Result := GetIdent('WRITEINTF')                 // Integer argument
      else
        if (Kind = BOOLEANTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BOOLEANTYPE)) then
          Result := GetIdent('WRITEBOOLEANF')             // Boolean argument
        else
          if Kind = REALTYPE then
            Result := GetIdent('WRITEREALF')                // Real argument
          else
            if Kind = POINTERTYPE then
              Result := GetIdent('WRITEPOINTERF')             // Pointer argument
            else
              if (Kind = ARRAYTYPE) and (BaseType = CHARTYPEINDEX) then
                Result := GetIdent('WRITESTRINGF')              // String argument
              else
                Error('Cannot write ' + GetTypeSpelling(DataType));
  end; // GetWriteProcIdentIndex
var
  DesignatorType, FileVarType, ExpressionType, FormatterType: Integer;
  LibProcIdentIndex, ConsoleIndex: Integer;
  IsFirstParam: Boolean;
begin // CompilePredefinedProc
  NextTok;
  case proc of
    INCPROC, DECPROC: begin
      EatTok(OPARTOK);
      CompileDesignator(DesignatorType, False);
      if (Types[DesignatorType].Kind = POINTERTYPE) and (Types[DesignatorType].BaseType <> ANYTYPEINDEX) then     // Special case: typed pointer
        GenerateIncDec(proc, TypeSize(DesignatorType), TypeSize(Types[DesignatorType].BaseType))
      else                                                                                                        // General rule
      begin
        GetCompatibleType(DesignatorType, INTEGERTYPEINDEX);
        GenerateIncDec(proc, TypeSize(DesignatorType));
      end;
      EatTok(CPARTOK);
    end;
    READPROC, READLNPROC: begin
      ConsoleIndex := GetIdent('STDINPUTFILE');
      FileVarType  := ANYTYPEINDEX;
      IsFirstParam := True;
      if Tok.Kind = OPARTOK then begin
        NextTok;
        repeat
          // 1st argument - file handle
          if FileVarType <> ANYTYPEINDEX then
            DuplicateStackTop
          else
            PushVarIdentPtr(ConsoleIndex);
          // 2nd argument - stream handle
          PushConst(0);
          // 3rd argument - designator
          CompileDesignator(DesignatorType, False);
          if Types[DesignatorType].Kind = FILETYPE then               // File handle
          begin
            if not IsFirstParam or ((proc = READLNPROC) and (Types[DesignatorType].BaseType <> ANYTYPEINDEX)) then
              Error('Cannot read ' + GetTypeSpelling(DesignatorType));
            FileVarType := DesignatorType;
          end
          else                                                        // Any input variable
          begin
            // Select input subroutine
            if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then      // Read from typed file
            begin
              GetCompatibleRefType(Types[FileVarType].BaseType, DesignatorType);
              // 4th argument - record length
              PushConst(TypeSize(Types[FileVarType].BaseType));
              LibProcIdentIndex := GetIdent('READREC');
            end
            else                                                                                                // Read from text file
              LibProcIdentIndex := GetReadProcIdent(DesignatorType);
            // Call selected input subroutine. Interface: FileHandle; StreamHandle; var Designator [; Length]
            GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
          end; // else
          IsFirstParam := False;
          if Tok.Kind <> COMMATOK then
            Break;
          NextTok;
        until False;
        EatTok(CPARTOK);
      end; // if OPARTOR
           // Add CR+LF, if necessary
      if proc = READLNPROC then begin
        // 1st argument - file handle
        if FileVarType <> ANYTYPEINDEX then
          DuplicateStackTop
        else
          PushVarIdentPtr(ConsoleIndex);
        // 2nd argument - stream handle
        PushConst(0);
        LibProcIdentIndex := GetIdent('READNEWLINE');
        GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      end;
      // Remove first 3 arguments if they correspond to a file variable
      if FileVarType <> ANYTYPEINDEX then
        DiscardStackTop(3);
    end;// READPROC, READLNPROC
    WRITEPROC, WRITELNPROC: begin
      ConsoleIndex := GetIdent('STDOUTPUTFILE');
      FileVarType  := ANYTYPEINDEX;
      IsFirstParam := True;
      if Tok.Kind = OPARTOK then begin
        NextTok;
        repeat
          // 1st argument - file handle
          if FileVarType <> ANYTYPEINDEX then
            DuplicateStackTop
          else
            PushVarIdentPtr(ConsoleIndex);
          // 2nd argument - stream handle
          PushConst(0);
          // 3rd argument - expression (for untyped/text files) or designator (for typed files)
          if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then
            CompileDesignator(ExpressionType)
          else begin
            CompileExpression(ExpressionType);
            // Try to convert single to double
            ConvertRealToReal(REALTYPEINDEX, ExpressionType);
            // Try to convert character to string
            ConvertCharToString(STRINGTYPEINDEX, ExpressionType, 0);
          end;
          if Types[ExpressionType].Kind = FILETYPE then           // File handle
          begin
            if not IsFirstParam or ((proc = WRITELNPROC) and (Types[ExpressionType].BaseType <> ANYTYPEINDEX)) then
              Error('Cannot write ' + GetTypeSpelling(ExpressionType));
            FileVarType := ExpressionType;
          end
          else                                                    // Any output expression
          begin
            // 4th argument - minimum width
            if Tok.Kind = COLONTOK then begin
              if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then
                Error('Format specifiers are not allowed for typed files');
              NextTok;
              CompileExpression(FormatterType);
              GetCompatibleType(FormatterType, INTEGERTYPEINDEX);
              // 5th argument - number of decimal places
              if (Tok.Kind = COLONTOK) and (Types[ExpressionType].Kind = REALTYPE) then begin
                NextTok;
                CompileExpression(FormatterType);
                GetCompatibleType(FormatterType, INTEGERTYPEINDEX);
              end
              else
                PushConst(0);
            end
            else begin
              PushConst(0);
              PushConst(0);
            end;
            // Select output subroutine
            if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then // Write to typed file
            begin
              GetCompatibleRefType(Types[FileVarType].BaseType, ExpressionType);
              // Discard 4th and 5th arguments - format specifiers
              DiscardStackTop(2);
              // 4th argument - record length
              PushConst(TypeSize(Types[FileVarType].BaseType));
              LibProcIdentIndex := GetIdent('WRITEREC');
            end
            else                                                                                                // Write to text file
              LibProcIdentIndex := GetWriteProcIdent(ExpressionType);
            // Call selected output subroutine. Interface: FileHandle; StreamHandle; (Designator | Expression); (Length; | MinWidth; DecPlaces)
            GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
          end; // else
          IsFirstParam := False;
          if Tok.Kind <> COMMATOK then
            Break;
          NextTok;
        until False;
        EatTok(CPARTOK);
      end; // if OPARTOR
           // Add CR+LF, if necessary
      if proc = WRITELNPROC then begin
        LibProcIdentIndex := GetIdent('WRITENEWLINE');
        // 1st argument - file handle
        if FileVarType <> ANYTYPEINDEX then
          DuplicateStackTop
        else
          PushVarIdentPtr(ConsoleIndex);
        // 2nd argument - stream handle
        PushConst(0);
        GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      end;
      // Remove first 3 arguments if they correspond to a file variable
      if FileVarType <> ANYTYPEINDEX then
        DiscardStackTop(3);
    end;// WRITEPROC, WRITELNPROC
    NEWPROC, DISPOSEPROC: begin
      EatTok(OPARTOK);
      CompileDesignator(DesignatorType, False);
      GetCompatibleType(DesignatorType, POINTERTYPEINDEX);
      if proc = NEWPROC then begin
        PushConst(TypeSize(Types[DesignatorType].BaseType));
        LibProcIdentIndex := GetIdent('GETMEM');
      end
      else
        LibProcIdentIndex := GetIdent('FREEMEM');
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      EatTok(CPARTOK);
    end;
    BREAKPROC: begin
      if LoopNesting < 1 then
        Error('BREAK outside of loop is not allowed');
      GenerateBreakCall(LoopNesting);
    end;
    CONTINUEPROC: begin
      if LoopNesting < 1 then
        Error('CONTINUE outside of loop is not allowed');
      GenerateContinueCall(LoopNesting);
    end;
    EXITPROC: GenerateExitCall;
    HALTPROC: begin
      if Tok.Kind = OPARTOK then begin
        NextTok;
        CompileExpression(ExpressionType);
        GetCompatibleType(ExpressionType, INTEGERTYPEINDEX);
        EatTok(CPARTOK);
      end
      else
        PushConst(0);
      LibProcIdentIndex := GetIdent('EXITPROCESS');
      GenerateCall(Ident[LibProcIdentIndex].Address, 1, 1);
    end;
  end;// case
end;  // CompilePredefinedProc
procedure CompilePredefinedFunc(func: TPredefProc; var ValType: Integer);
var
  IdentIndex: Integer;
begin
  NextTok;
  EatTok(OPARTOK);
  case func of
    SIZEOFFUNC: begin
      AssertIdent;
      IdentIndex := GetIdentUnsafe(Tok.Name);
      if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then   // Type name
      begin
        NextTok;
        PushConst(TypeSize(Ident[IdentIndex].DataType));
      end
      else                                                                // Variable name
      begin
        CompileDesignator(ValType);
        DiscardStackTop(1);
        PushConst(TypeSize(ValType));
      end;
      ValType := INTEGERTYPEINDEX;
    end;
    ROUNDFUNC, TRUNCFUNC: begin
      CompileExpression(ValType);
      // Try to convert integer to real
      ConvertIntegerToReal(REALTYPEINDEX, ValType, 0);
      GetCompatibleType(ValType, REALTYPEINDEX);
      GenerateRound(func = TRUNCFUNC);
      ValType := INTEGERTYPEINDEX;
    end;
    ORDFUNC: begin
      CompileExpression(ValType);
      if not (Types[ValType].Kind in OrdinalTypes) then
        Error('Ordinal type expected');
      ValType := INTEGERTYPEINDEX;
    end;
    CHRFUNC: begin
      CompileExpression(ValType);
      GetCompatibleType(ValType, INTEGERTYPEINDEX);
      ValType := CHARTYPEINDEX;
    end;
    LOWFUNC, HIGHFUNC: begin
      AssertIdent;
      IdentIndex := GetIdentUnsafe(Tok.Name);
      if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then   // Type name
      begin
        NextTok;
        ValType := Ident[IdentIndex].DataType;
      end
      else                                                                // Variable name
      begin
        CompileDesignator(ValType);
        DiscardStackTop(1);
      end;
      if (Types[ValType].Kind = ARRAYTYPE) and not Types[ValType].IsOpenArray then
        ValType := Types[ValType].IndexType;
      if func = HIGHFUNC then
        PushConst(HighBound(ValType))
      else
        PushConst(LowBound(ValType));
    end;
    PREDFUNC, SUCCFUNC: begin
      CompileExpression(ValType);
      if not (Types[ValType].Kind in OrdinalTypes) then
        Error('Ordinal type expected');
      if func = SUCCFUNC then
        PushConst(1)
      else
        PushConst(-1);
      GenerateBinaryOperator(PLUSTOK, INTEGERTYPEINDEX);
    end;
    ABSFUNC, SQRFUNC, SINFUNC, COSFUNC, ARCTANFUNC, EXPFUNC, LNFUNC, SQRTFUNC: begin
      CompileExpression(ValType);
      if (func = ABSFUNC) or (func = SQRFUNC) then                          // Abs and Sqr accept real or integer parameters
      begin
        if not ((Types[ValType].Kind in NumericTypes) or ((Types[ValType].Kind = SUBRANGETYPE) and (Types[Types[ValType].BaseType].Kind in NumericTypes))) then
          Error('Numeric type expected');
      end
      else begin
        // Try to convert integer to real
        ConvertIntegerToReal(REALTYPEINDEX, ValType, 0);
        GetCompatibleType(ValType, REALTYPEINDEX);
      end;
      GenerateMathFunction(func, ValType);
    end;
  end;// case
  EatTok(CPARTOK);
end;// CompilePredefinedFunc
procedure CompileTypeIdent(var DataType: Integer; AllowForwardReference: Boolean);
var
  IdentIndex: Integer;
begin
  // STRING, FILE or type name allowed
  case Tok.Kind of
    STRINGTOK: DataType := STRINGTYPEINDEX;
    FILETOK: DataType   := FILETYPEINDEX
    else AssertIdent;
      if AllowForwardReference then
        IdentIndex := GetIdentUnsafe(Tok.Name, AllowForwardReference)
      else
        IdentIndex := GetIdent(Tok.Name, AllowForwardReference);
      if AllowForwardReference and ((IdentIndex = 0) or (Ident[IdentIndex].Block <> BlockStack[BlockStackTop].Index)) then begin
        // Add new forward-referenced type
        DeclareType(FORWARDTYPE);
        Types[NumTypes].TypeIdentName := Tok.Name;
        DataType := NumTypes;
      end
      else begin
        // Use existing type
        if Ident[IdentIndex].Kind <> USERTYPE then
          Error('Type name expected');
        DataType := Ident[IdentIndex].DataType;
      end;
  end; // case
  NextTok;
end; // CompileTypeIdent
procedure CompileFormalParametersAndResult(IsFunction: Boolean; var Signature: TSignature);
var
  IdentInListName: array [1..MAXPARAMS] of TString;
  NumIdentInList, IdentInListIndex: Integer;
  ParamType, DefaultValueType: Integer;
  ListPassMethod:  TPassMethod;
  IsOpenArrayList, StringByValFound: Boolean;
  Default:         TConst;
begin
  Signature.NumParams        := 0;
  Signature.NumDefaultParams := 0;
  StringByValFound           := False;
  if Tok.Kind = OPARTOK then begin
    NextTok;
    repeat
      NumIdentInList := 0;
      ListPassMethod := VALPASSING;
      if Tok.Kind = CONSTTOK then begin
        ListPassMethod := CONSTPASSING;
        NextTok;
      end
      else
        if Tok.Kind = VARTOK then begin
          ListPassMethod := VARPASSING;
          NextTok;
        end;
      repeat
        AssertIdent;
        Inc(NumIdentInList);
        IdentInListName[NumIdentInList] := Tok.Name;
        NextTok;
        if Tok.Kind <> COMMATOK then
          Break;
        NextTok;
      until False;
      // Formal parameter list type
      if Tok.Kind = COLONTOK then                       // Typed parameters
      begin
        NextTok;
        // Special case: open array parameters
        if Tok.Kind = ARRAYTOK then begin
          NextTok;
          EatTok(OFTOK);
          IsOpenArrayList := True;
        end
        else
          IsOpenArrayList := False;
        // Type itself
        CompileTypeIdent(ParamType, False);
        // Special case: open array parameters
        if IsOpenArrayList then begin
          // Add new anonymous type 0..0 for array index
          DeclareType(SUBRANGETYPE);
          Types[NumTypes].BaseType := INTEGERTYPEINDEX;
          Types[NumTypes].Low      := 0;
          Types[NumTypes].High     := 0;
          // Add new anonymous type for array itself
          DeclareType(ARRAYTYPE);
          Types[NumTypes].BaseType := ParamType;
          Types[NumTypes].IndexType := NumTypes - 1;
          Types[NumTypes].IsOpenArray := True;
          ParamType := NumTypes;
        end;
      end
      else                                              // Untyped parameters (CONST or VAR only)
        ParamType := ANYTYPEINDEX;
      if (ListPassMethod <> VARPASSING) and (ParamType = ANYTYPEINDEX) then
        Error('Untyped parameters require VAR');
      if (ListPassMethod = VALPASSING) and IsString(ParamType) then
        StringByValFound := True;
      // Default parameter value
      if (Tok.Kind = EQTOK) or (Signature.NumDefaultParams > 0) then begin
        EatTok(EQTOK);
        if not (Types[ParamType].Kind in OrdinalTypes + [REALTYPE]) then
          Error('Ordinal or real type expected for default parameter');
        if ListPassMethod <> VALPASSING then
          Error('Default parameters cannot be passed by reference');
        CompileConstExpression(Default, DefaultValueType);
        GetCompatibleType(ParamType, DefaultValueType);
        Inc(Signature.NumDefaultParams);
      end;
      for IdentInListIndex := 1 to NumIdentInList do begin
        Inc(Signature.NumParams);
        if Signature.NumParams > MAXPARAMS then
          Error('Too many formal parameters');
        New(Signature.Param[Signature.NumParams]);
        with Signature, Param[NumParams]^ do begin
          Name       := IdentInListName[IdentInListIndex];
          DataType   := ParamType;
          PassMethod := ListPassMethod;
          Default.OrdValue := 0;
        end;
        // Default parameter value
        if (Signature.NumDefaultParams > 0) and (IdentInListIndex = 1) then begin
          if NumIdentInList > 1 then
            Error('Default parameters cannot be grouped');
          Signature.Param[Signature.NumParams]^.Default := Default;
        end;
      end;// for
      if Tok.Kind <> SEMICOLONTOK then
        Break;
      NextTok;
    until False;
    EatTok(CPARTOK);
  end;// if Tok.Kind = OPARTOK
      // Function result type
  Signature.ResultType := 0;
  if IsFunction then begin
    EatTok(COLONTOK);
    CompileTypeIdent(Signature.ResultType, False);
  end;
  // Call modifier
  if (Tok.Kind = IDENTTOK) and (Tok.Name = 'STDCALL') then begin
    Signature.CallConv := STDCALLCONV;
    NextTok;
  end
  else
    if (Tok.Kind = IDENTTOK) and (Tok.Name = 'CDECL') then begin
      Signature.CallConv := CDECLCONV;
      NextTok;
    end
    else
      Signature.CallConv := DEFAULTCONV;
  if (Signature.CallConv <> DEFAULTCONV) and StringByValFound then
    Error('Strings cannot be passed by value to STDCALL/CDECL procedures');
end; // CompileFormalParametersAndResult
procedure CompileActualParameters(const Signature: TSignature; var StructuredResultAddr: Longint);
  procedure CompileExpressionCopy(var ValType: Integer; CallConv: TCallConv);
  var
    TempStorageAddr:   Integer;
    LibProcIdentIndex: Integer;
  begin
    CompileExpression(ValType);
    // Copy structured parameter passed by value (for STDCALL/CDECL functions there is no need to do it here since it will be done in MakeCStack)
    if (Types[ValType].Kind in StructuredTypes) and (CallConv = DEFAULTCONV) then begin
      SaveStackTopToEAX;
      TempStorageAddr := AllocateTempStorage(TypeSize(ValType));
      PushTempStoragePtr(TempStorageAddr);
      RestoreStackTopFromEAX;
      if IsString(ValType) then begin
        LibProcIdentIndex := GetIdent('ASSIGNSTR');
        GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      end
      else
        GenerateStructuredAssignment(ValType);
      PushTempStoragePtr(TempStorageAddr);
    end;
  end; // CompileExpressionCopy
var
  NumActualParams:   Integer;
  ActualParamType:   Integer;
  DefaultParamIndex: Integer;
  CurParam:          PParam;
begin
  // Allocate space for structured Result as a hidden VAR parameter (except STDCALL/CDECL functions returning small structures in EDX:EAX)
  with Signature do
    if (ResultType <> 0) and (Types[ResultType].Kind in StructuredTypes) and ((CallConv = DEFAULTCONV) or (TypeSize(ResultType) > 2 * SizeOf(Longint))) then begin
      StructuredResultAddr := AllocateTempStorage(TypeSize(ResultType));
      PushTempStoragePtr(StructuredResultAddr);
    end
    else
      StructuredResultAddr := 0;
  NumActualParams          := 0;
  if Tok.Kind = OPARTOK then                            // Actual parameter list found
  begin
    NextTok;
    if Tok.Kind <> CPARTOK then
      repeat
        if NumActualParams + 1 > Signature.NumParams then
          Error('Too many actual parameters');
        CurParam := Signature.Param[NumActualParams + 1];
        case CurParam^.PassMethod of
          VALPASSING: CompileExpressionCopy(ActualParamType, Signature.CallConv);
          CONSTPASSING: CompileExpression(ActualParamType);
          VARPASSING: CompileDesignator(ActualParamType, CurParam^.DataType = ANYTYPEINDEX);
          else Error('Internal fault: Illegal parameter passing method');
        end;
        Inc(NumActualParams);
        // Try to convert integer to double, single to double or double to single
        if CurParam^.PassMethod <> VARPASSING then begin
          ConvertIntegerToReal(CurParam^.DataType, ActualParamType, 0);
          ConvertRealToReal(CurParam^.DataType, ActualParamType);
        end;
        // Try to convert character to string
        ConvertCharToString(CurParam^.DataType, ActualParamType, 0);
        // Try to convert string to pointer to character
        ConvertStringToPChar(CurParam^.DataType, ActualParamType);
        // Try to convert a concrete type to an interface type
        ConvertToInterface(CurParam^.DataType, ActualParamType);
        if CurParam^.PassMethod = VARPASSING then
          GetCompatibleRefType(CurParam^.DataType, ActualParamType)
        // Strict type checking for parameters passed by reference, except for open array parameters and untyped parameters
        else
          GetCompatibleType(CurParam^.DataType, ActualParamType);    // Relaxed type checking for parameters passed by value
        if Tok.Kind <> COMMATOK then
          Break;
        NextTok;
      until False;
    EatTok(CPARTOK);
  end;// if Tok.Kind = OPARTOK
  if NumActualParams < Signature.NumParams - Signature.NumDefaultParams then
    Error('Too few actual parameters');
  // Push default parameters
  for DefaultParamIndex := NumActualParams + 1 to Signature.NumParams do begin
    CurParam := Signature.Param[DefaultParamIndex];
    PushConst(CurParam^.Default.OrdValue);
  end; // for
end;   // CompileActualParameters
procedure MakeCStack(const Signature: TSignature);
var
  ParamIndex:       Integer;
  SourceStackDepth: Integer;
begin
  InitializeCStack;
  // Push explicit parameters
  SourceStackDepth := 0;
  for ParamIndex := Signature.NumParams downto 1 do
    with Signature.Param[ParamIndex]^ do begin
      PushToCStack(SourceStackDepth, DataType, PassMethod = VALPASSING);
      if (Types[DataType].Kind = REALTYPE) and (PassMethod = VALPASSING) then
        SourceStackDepth := SourceStackDepth + Align(TypeSize(DataType), SizeOf(Longint))
      else
        SourceStackDepth := SourceStackDepth + SizeOf(Longint);
    end;
  // Push structured Result onto the C stack, except STDCALL/CDECL functions returning small structures in EDX:EAX
  with Signature do
    if (ResultType <> 0) and (Types[ResultType].Kind in StructuredTypes) and ((CallConv = DEFAULTCONV) or (TypeSize(ResultType) > 2 * SizeOf(Longint))) then
      PushToCStack(NumParams * SizeOf(Longint), ResultType, False);
end; // MakeCStack
procedure ConvertResultFromCToPascal(const Signature: TSignature; StructuredResultAddr: Longint);
begin
  with Signature do
    if (ResultType <> 0) and (CallConv <> DEFAULTCONV) then
      if Types[ResultType].Kind in StructuredTypes then
        if TypeSize(ResultType) <= 2 * SizeOf(Longint) then begin
          // For small structures returned by STDCALL/CDECL functions, allocate structured result pointer and load structure from EDX:EAX
          StructuredResultAddr := AllocateTempStorage(TypeSize(ResultType));
          ConvertSmallStructureToPointer(StructuredResultAddr, TypeSize(ResultType));
        end
        else begin
          // Save structured result pointer to EAX (not all external functions do it themselves)
          PushTempStoragePtr(StructuredResultAddr);
          SaveStackTopToEAX;
        end
      else
        if Types[ResultType].Kind in [REALTYPE, SINGLETYPE] then
          // STDCALL/CDECL functions generally return real result in ST(0), but we do it in EAX or EDX:EAX
          MoveFunctionResultFromFPUToEDXEAX(ResultType);
end; // ConvertResultFromCToPascal
procedure ConvertResultFromPascalToC(const Signature: TSignature);
begin
  with Signature do
    if (ResultType <> 0) and (CallConv <> DEFAULTCONV) then
      if (Types[ResultType].Kind in StructuredTypes) and (TypeSize(ResultType) <= 2 * SizeOf(Longint)) then
        // In STDCALL/CDECL functions, return small structure in EDX:EAX
        ConvertPointerToSmallStructure(TypeSize(ResultType))
      else
        if Types[ResultType].Kind in [REALTYPE, SINGLETYPE] then
          // STDCALL/CDECL functions generally return real result in ST(0), but we do it in EAX or EDX:EAX
          MoveFunctionResultFromEDXEAXToFPU(ResultType);
end; // ConvertResultFromCPascalToC
procedure CompileCall(IdentIndex: Integer);
var
  TotalPascalParamSize, TotalCParamSize: Integer;
  StructuredResultAddr: Longint;
begin
  TotalPascalParamSize := GetTotalParamSize(Ident[IdentIndex].Signature, False, True);
  TotalCParamSize      := GetTotalParamSize(Ident[IdentIndex].Signature, False, False);
  CompileActualParameters(Ident[IdentIndex].Signature, StructuredResultAddr);
  // Convert stack to C format
  if (Ident[IdentIndex].Signature.CallConv <> DEFAULTCONV) and (TotalPascalParamSize > 0) then
    MakeCStack(Ident[IdentIndex].Signature);
  GenerateCall(Ident[IdentIndex].Address, BlockStackTop - 1, Ident[IdentIndex].NestingLevel);
  // Free C stack for a CDECL function
  if (Ident[IdentIndex].Signature.CallConv = CDECLCONV) and (TotalPascalParamSize > 0) then
    DiscardStackTop(TotalCParamSize div SizeOf(Longint));
  // Free original stack
  if (Ident[IdentIndex].Signature.CallConv <> DEFAULTCONV) and (TotalPascalParamSize > 0) then
    DiscardStackTop(TotalPascalParamSize div SizeOf(Longint));
  // Treat special cases in STDCALL/CDECL functions
  ConvertResultFromCToPascal(Ident[IdentIndex].Signature, StructuredResultAddr);
end; // CompileCall
procedure CompileMethodCall(ProcVarType: Integer);
var
  MethodIndex:          Integer;
  StructuredResultAddr: Longint;
begin
  MethodIndex := Types[ProcVarType].MethodIdentIndex;
  // Self pointer has already been passed as the first (hidden) argument
  CompileActualParameters(Ident[MethodIndex].Signature, StructuredResultAddr);
  GenerateCall(Ident[MethodIndex].Address, BlockStackTop - 1, Ident[MethodIndex].NestingLevel);
end; // CompileMethodCall
procedure CompileIndirectCall(ProcVarType: Integer);
var
  TotalPascalParamSize, TotalCParamSize, CallAddrDepth: Integer;
  StructuredResultAddr: Longint;
begin
  TotalPascalParamSize := GetTotalParamSize(Types[ProcVarType].Signature, Types[ProcVarType].SelfPointerOffset <> 0, True);
  TotalCParamSize      := GetTotalParamSize(Types[ProcVarType].Signature, Types[ProcVarType].SelfPointerOffset <> 0, False);
  if Types[ProcVarType].SelfPointerOffset <> 0 then   // Interface method found
  begin
    if Types[ProcVarType].Signature.CallConv <> DEFAULTCONV then
      Error('STDCALL/CDECL is not allowed for methods');
    // Push Self pointer as a first (hidden) VAR parameter
    DuplicateStackTop;
    GetFieldPtr(Types[ProcVarType].SelfPointerOffset);
    DerefPtr(POINTERTYPEINDEX);
  end;
  CompileActualParameters(Types[ProcVarType].Signature, StructuredResultAddr);
  // Convert stack to C format
  if (Types[ProcVarType].Signature.CallConv <> DEFAULTCONV) and (TotalPascalParamSize > 0) then begin
    MakeCStack(Types[ProcVarType].Signature);
    CallAddrDepth := TotalPascalParamSize + TotalCParamSize;
  end
  else
    CallAddrDepth := TotalPascalParamSize;
  GenerateIndirectCall(CallAddrDepth);
  // Free C stack for a CDECL function
  if (Types[ProcVarType].Signature.CallConv = CDECLCONV) and (TotalPascalParamSize > 0) then
    DiscardStackTop(TotalCParamSize div SizeOf(Longint));
  // Free original stack
  if (Types[ProcVarType].Signature.CallConv <> DEFAULTCONV) and (TotalPascalParamSize > 0) then
    DiscardStackTop(TotalPascalParamSize div SizeOf(Longint));
  // Remove call address
  DiscardStackTop(1);
  // Treat special cases in STDCALL/CDECL functions
  ConvertResultFromCToPascal(Types[ProcVarType].Signature, StructuredResultAddr);
end; // CompileIndirectCall
function CompileMethodOrProceduralVariableCall(var ValType: Integer; FunctionOnly, DesignatorOnly: Boolean): Boolean;
var
  ResultType: Integer;
begin
  if Types[ValType].Kind = METHODTYPE then
    ResultType := Ident[Types[ValType].MethodIdentIndex].Signature.ResultType
  else
    if Types[ValType].Kind = PROCEDURALTYPE then
      ResultType := Types[ValType].Signature.ResultType
    else begin
      ResultType := 0;
      Error('Procedure or function expected');
    end;
  Result := False;
  if not DesignatorOnly or ((ResultType <> 0) and (Types[ResultType].Kind in StructuredTypes)) then  begin
    if FunctionOnly and (ResultType = 0) then
      Error('Function expected');
    if Types[ValType].Kind = METHODTYPE then
      CompileMethodCall(ValType)
    else
      CompileIndirectCall(ValType);
    ValType := ResultType;
    Result  := True;
  end;
end; // CompileMethodOrProceduralVariableCall
procedure CompileFieldOrMethodInsideWith(var ValType: Integer; var IsConst: Boolean);
var
  FieldIndex, MethodIndex: Integer;
  RecType:         Integer;
  TempStorageAddr: Integer;
begin
  AssertIdent;
  FieldIndex := GetFieldInsideWith(TempStorageAddr, RecType, IsConst, Tok.Name);
  if FieldIndex <> 0 then begin
    PushTempStoragePtr(TempStorageAddr);
    DerefPtr(POINTERTYPEINDEX);
    GetFieldPtr(Types[RecType].Field[FieldIndex]^.Offset);
    ValType := Types[RecType].Field[FieldIndex]^.DataType;
    Exit;
  end;
  MethodIndex := GetMethodInsideWith(TempStorageAddr, RecType, IsConst, Tok.Name);
  if MethodIndex <> 0 then begin
    PushTempStoragePtr(TempStorageAddr);
    DerefPtr(POINTERTYPEINDEX);
    // Add new anonymous 'method' type
    DeclareType(METHODTYPE);
    Types[NumTypes].MethodIdentIndex := MethodIndex;
    ValType := NumTypes;
    Exit;
  end;
  ValType := 0;
end; // CompileFieldOrMethodInsideWith
procedure CompileSetConstructor(var ValType: Integer);
var
  ElementType:       Integer;
  LibProcIdentIndex: Integer;
  TempStorageAddr:   Integer;
begin
  // Add new anonymous type
  DeclareType(SETTYPE);
  Types[NumTypes].BaseType := ANYTYPEINDEX;
  ValType         := NumTypes;
  // Allocate temporary storage
  TempStorageAddr := AllocateTempStorage(TypeSize(ValType));
  PushTempStoragePtr(TempStorageAddr);
  // Initialize set
  LibProcIdentIndex := GetIdent('INITSET');
  GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
  // Compile constructor
  LibProcIdentIndex := GetIdent('ADDTOSET');
  NextTok;
  if Tok.Kind <> CBRACKETTOK then
    repeat
      PushTempStoragePtr(TempStorageAddr);
      CompileExpression(ElementType);
      if Types[ValType].BaseType = ANYTYPEINDEX then begin
        if not (Types[ElementType].Kind in OrdinalTypes) then
          Error('Ordinal type expected');
        Types[ValType].BaseType := ElementType;
      end
      else
        GetCompatibleType(ElementType, Types[ValType].BaseType);
      if Tok.Kind = RANGETOK then begin
        NextTok;
        CompileExpression(ElementType);
        GetCompatibleType(ElementType, Types[ValType].BaseType);
      end
      else
        PushConst(-1);
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      if Tok.Kind <> COMMATOK then
        Break;
      NextTok;
    until False;
  EatTok(CBRACKETTOK);
  PushTempStoragePtr(TempStorageAddr);
end; // CompileSetConstructor
function DereferencePointerAsDesignator(var ValType: Integer; MustDereferenceAnyPointer: Boolean): Boolean;
begin
  // If a pointer-type result is immediately followed by dereferencing, treat it as a designator that has the pointer's base type
  Result := False;
  if Types[ValType].Kind = POINTERTYPE then
    if Types[ValType].BaseType <> ANYTYPEINDEX then begin
      if Tok.Kind = DEREFERENCETOK then begin
        ValType := Types[ValType].BaseType;
        Result  := True;
        NextTok;
      end
      else
        if MustDereferenceAnyPointer then
          CheckTok(DEREFERENCETOK);
    end
    else
      if MustDereferenceAnyPointer then
        Error('Typed pointer expected');
end; // DereferencePointerAsDesignator
function CompileSelectors(var ValType: Integer; BasicDesignatorIsStatement: Boolean = False): Boolean;
var
  FieldIndex, MethodIndex: Integer;
  ArrayIndexType: Integer;
  Field: PField;
begin
  // A selector is only applicable to a memory location
  // A function call can be part of a selector only if it returns an address (i.e. a structured result), not an immediate value
  // All other calls are part of a factor or a statement
  // Returns TRUE if constitutes a statement, i.e., ends with a function call
  Result := BasicDesignatorIsStatement;
  while Tok.Kind in [DEREFERENCETOK, OBRACKETTOK, PERIODTOK, OPARTOK] do begin
    Result := False;
    case Tok.Kind of
      DEREFERENCETOK:                                   // Pointer dereferencing
      begin
        if (Types[ValType].Kind <> POINTERTYPE) or (Types[ValType].BaseType = ANYTYPEINDEX) then
          Error('Typed pointer expected');
        DerefPtr(ValType);
        ValType := Types[ValType].BaseType;
        NextTok;
      end;
      OBRACKETTOK:                                      // Array element access
      begin
        repeat
          // Convert a pointer to an array if needed (C style)
          if (Types[ValType].Kind = POINTERTYPE) and (Types[ValType].BaseType <> ANYTYPEINDEX) then begin
            DerefPtr(ValType);
            // Add new anonymous type 0..0 for array index
            DeclareType(SUBRANGETYPE);
            Types[NumTypes].BaseType := INTEGERTYPEINDEX;
            Types[NumTypes].Low      := 0;
            Types[NumTypes].High     := 0;
            // Add new anonymous type for array itself
            DeclareType(ARRAYTYPE);
            Types[NumTypes].BaseType := Types[ValType].BaseType;
            Types[NumTypes].IndexType := NumTypes - 1;
            ValType := NumTypes;
          end;
          if Types[ValType].Kind <> ARRAYTYPE then
            Error('Array expected');
          NextTok;
          CompileExpression(ArrayIndexType);            // Array index
          GetCompatibleType(ArrayIndexType, Types[ValType].IndexType);
          GetArrayElementPtr(ValType);
          ValType := Types[ValType].BaseType;
        until Tok.Kind <> COMMATOK;
        EatTok(CBRACKETTOK);
      end;
      PERIODTOK:                                        // Method or record field access
      begin
        NextTok;
        AssertIdent;
        // First search for a method
        MethodIndex := GetMethodUnsafe(ValType, Tok.Name);
        if MethodIndex <> 0 then begin
          // Add new anonymous 'method' type
          DeclareType(METHODTYPE);
          Types[NumTypes].MethodIdentIndex := MethodIndex;
          ValType := NumTypes;
        end
        // If unsuccessful, search for a record field
        else begin
          if not (Types[ValType].Kind in [RECORDTYPE, INTERFACETYPE]) then
            Error('Record or interface expected');
          FieldIndex := GetField(ValType, Tok.Name);
          Field      := Types[ValType].Field[FieldIndex];
          GetFieldPtr(Field^.Offset);
          ValType := Field^.DataType;
        end;
        NextTok;
      end;
      OPARTOK: begin
        if not CompileMethodOrProceduralVariableCall(ValType, True, True) then
          Break;  // Not a designator
        PushFunctionResult(ValType);
        Result := True;
      end;
    end; // case
  end;   // while
end; // CompileSelectors
function CompileBasicDesignator(var ValType: Integer; var IsConst: Boolean): Boolean;
var
  ResultType: Integer;
  IdentIndex: Integer;
begin
  // A designator always designates a memory location
  // A function call can be part of a designator only if it returns an address (i.e. a structured result or a pointer), not an immediate value
  // All other calls are part of a factor or a statement
  // Returns TRUE if constitutes a statement, i.e., ends with a function call
  Result  := False;
  IsConst := False;
  AssertIdent;
  // First search among records in WITH blocks
  CompileFieldOrMethodInsideWith(ValType, IsConst);
  // If unsuccessful, search among ordinary identifiers
  if ValType = 0 then begin
    IdentIndex := GetIdent(Tok.Name);
    case Ident[IdentIndex].Kind of
      FUNC: begin
        ResultType := Ident[IdentIndex].Signature.ResultType;
        if not (Types[ResultType].Kind in StructuredTypes + [POINTERTYPE]) then   // Only allow a function that returns a designator
          Error('Function must return pointer or structured result');
        NextTok;
        CompileCall(IdentIndex);
        PushFunctionResult(ResultType);
        Result  := True;
        ValType := ResultType;
        if DereferencePointerAsDesignator(ValType, True) then
          Result := False;
      end;
      VARIABLE: begin
        PushVarIdentPtr(IdentIndex);
        ValType := Ident[IdentIndex].DataType;
        IsConst := Ident[IdentIndex].IsTypedConst or (Ident[IdentIndex].PassMethod = CONSTPASSING);
        // Structured CONST parameters are passed by reference, scalar CONST parameters are passed by value
        if (Ident[IdentIndex].PassMethod = VARPASSING) or ((Ident[IdentIndex].PassMethod <> VALPASSING) and (Types[ValType].Kind in StructuredTypes) and
          Ident[IdentIndex].IsInCStack) or ((Ident[IdentIndex].PassMethod <> EMPTYPASSING) and (Types[ValType].Kind in StructuredTypes) and
          not Ident[IdentIndex].IsInCStack) then
          DerefPtr(POINTERTYPEINDEX);
        NextTok;
      end;
      USERTYPE:                                                                       // Type cast
      begin
        NextTok;
        EatTok(OPARTOK);
        CompileExpression(ValType);
        EatTok(CPARTOK);
        if not (Types[Ident[IdentIndex].DataType].Kind in StructuredTypes + [POINTERTYPE]) then   // Only allow a typecast that returns a designator
          Error('Typecast must return pointer or structured result');
        if (Ident[IdentIndex].DataType <> ValType) and not ((Types[Ident[IdentIndex].DataType].Kind in CastableTypes) and (Types[ValType].Kind in CastableTypes)) then
          Error('Invalid typecast');
        ValType := Ident[IdentIndex].DataType;
        DereferencePointerAsDesignator(ValType, True);
      end
      else Error('Variable or function expected but ' + GetTokSpelling(Tok.Kind) + ' found');
    end; // case
  end
  else
    NextTok;
end; // CompileBasicDesignator
function CompileDesignator(var ValType: Integer; AllowConst: Boolean = True): Boolean;
var
  IsConst: Boolean;
begin
  // Returns TRUE if constitutes a statement, i.e., ends with a function call
  Result := CompileBasicDesignator(ValType, IsConst);
  if IsConst and not AllowConst then
    Error('Constant value cannot be modified');
  Result := CompileSelectors(ValType, Result);
end; // CompileDesignator
procedure CompileFactor(var ValType: Integer);
  procedure CompileDereferenceOrCall(var ValType: Integer);
  begin
    if Tok.Kind = OPARTOK then   // Method or procedural variable call (parentheses are required even for empty parameter list)
    begin
      CompileMethodOrProceduralVariableCall(ValType, True, False);
      PushFunctionResult(ValType);
    end
    else                         // Usual variable
      if not (Types[ValType].Kind in StructuredTypes) then  // Structured expressions are stored as pointers to them
        DerefPtr(ValType);
    ConvertRealToReal(REALTYPEINDEX, ValType);              // Real expressions must be double, not single
  end; // CompileDereferenceOrCall
var
  IdentIndex: Integer;
  NotOpTok:   TToken;
begin // CompileFactor
  case Tok.Kind of
    IDENTTOK: if FieldOrMethodInsideWithFound(Tok.Name) then                                      // Record field or method inside a WITH block
      begin
        CompileDesignator(ValType);
        CompileDereferenceOrCall(ValType);
      end
      else                                                                                // Ordinary identifier
      begin
        IdentIndex := GetIdent(Tok.Name);
        case Ident[IdentIndex].Kind of
          GOTOLABEL: Error('Expression expected but label ' + Ident[IdentIndex].Name + ' found');
          PROC: Error('Expression expected but procedure ' + Ident[IdentIndex].Name + ' found');
          FUNC:                                                                           // Function call
            if Ident[IdentIndex].PredefProc <> EMPTYPROC then                             // Predefined function call
              CompilePredefinedFunc(Ident[IdentIndex].PredefProc, ValType)
            else                                                                          // User-defined function call
            begin
              NextTok;
              ValType := Ident[IdentIndex].Signature.ResultType;
              CompileCall(IdentIndex);
              PushFunctionResult(ValType);
              ConvertRealToReal(REALTYPEINDEX, ValType);              // Real expressions must be double, not single
              if (Types[ValType].Kind in StructuredTypes) or DereferencePointerAsDesignator(ValType, False) then begin
                CompileSelectors(ValType);
                CompileDereferenceOrCall(ValType);
              end;
            end;
          VARIABLE:                                                                       // Variable
          begin
            CompileDesignator(ValType);
            CompileDereferenceOrCall(ValType);
          end;
          CONSTANT:                                                                       // Constant
          begin
            if Types[Ident[IdentIndex].DataType].Kind in StructuredTypes then
              PushVarPtr(Ident[IdentIndex].Address, GLOBAL, 0, INITDATARELOC)
            else
              if Types[Ident[IdentIndex].DataType].Kind = REALTYPE then
                PushRealConst(Ident[IdentIndex].ConstVal.RealValue)
              else
                PushConst(Ident[IdentIndex].ConstVal.OrdValue);
            ValType := Ident[IdentIndex].DataType;
            NextTok;
            if Types[Ident[IdentIndex].DataType].Kind in StructuredTypes then begin
              CompileSelectors(ValType);
              CompileDereferenceOrCall(ValType);
            end;
          end;
          USERTYPE:                                                                       // Type cast
          begin
            NextTok;
            EatTok(OPARTOK);
            CompileExpression(ValType);
            EatTok(CPARTOK);
            if (Ident[IdentIndex].DataType <> ValType) and not ((Types[Ident[IdentIndex].DataType].Kind in CastableTypes) and (Types[ValType].Kind in CastableTypes))
            then
              Error('Invalid typecast');
            ValType := Ident[IdentIndex].DataType;
            if (Types[ValType].Kind = POINTERTYPE) and (Types[Types[ValType].BaseType].Kind in StructuredTypes) then begin
              if DereferencePointerAsDesignator(ValType, False) then begin
                CompileSelectors(ValType);
                CompileDereferenceOrCall(ValType);
              end;
            end
            else
              CompileSelectors(ValType);
          end
          else Error('Internal fault: Illegal identifier');
        end; // case Ident[IdentIndex].Kind
      end;   // else
    ADDRESSTOK: begin
      NextTok;
      if FieldOrMethodInsideWithFound(Tok.Name) then         // Record field inside a WITH block
      begin
        CompileDesignator(ValType);
        DeclareType(POINTERTYPE);
        Types[NumTypes].BaseType := ValType;
      end
      else                                                    // Ordinary identifier
      begin
        IdentIndex := GetIdent(Tok.Name);
        if Ident[IdentIndex].Kind in [PROC, FUNC] then begin
          if (Ident[IdentIndex].PredefProc <> EMPTYPROC) or (Ident[IdentIndex].Block <> 1) then
            Error('Procedure or function cannot be predefined or nested');
          PushRelocConst(Ident[IdentIndex].Address, CODERELOC); // To be resolved later when the code section origin is known
          NextTok;
          DeclareType(PROCEDURALTYPE);
          Types[NumTypes].Signature := Ident[IdentIndex].Signature;
          CopyParams(Types[NumTypes].Signature, Ident[IdentIndex].Signature);
        end
        else begin
          CompileDesignator(ValType);
          DeclareType(POINTERTYPE);
          Types[NumTypes].BaseType := ValType;
        end;
      end;
      ValType := NumTypes;
    end;
    INTNUMBERTOK: begin
      PushConst(Tok.OrdValue);
      ValType := INTEGERTYPEINDEX;
      NextTok;
    end;
    REALNUMBERTOK: begin
      PushRealConst(Tok.RealValue);
      ValType := REALTYPEINDEX;
      NextTok;
    end;
    CHARLITERALTOK: begin
      PushConst(Tok.OrdValue);
      ValType := CHARTYPEINDEX;
      NextTok;
    end;
    STRINGLITERALTOK: begin
      PushVarPtr(Tok.StrAddress, GLOBAL, 0, INITDATARELOC);
      ValType := STRINGTYPEINDEX;
      NextTok;
    end;
    OPARTOK: begin
      NextTok;
      CompileExpression(ValType);
      EatTok(CPARTOK);
    end;
    NOTTOK: begin
      NotOpTok := Tok;
      NextTok;
      CompileFactor(ValType);
      CheckOperator(NotOpTok, ValType);
      GenerateUnaryOperator(NOTTOK, ValType);
    end;
    OBRACKETTOK: CompileSetConstructor(ValType);
    NILTOK: begin
      PushConst(0);
      ValType := POINTERTYPEINDEX;
      NextTok;
    end
    else Error('Expression expected but ' + GetTokSpelling(Tok.Kind) + ' found');
  end;// case
end;  // CompileFactor
procedure CompileTerm(var ValType: Integer);
var
  OpTok:           TToken;
  RightValType:    Integer;
  LibProcIdentIndex: Integer;
  TempStorageAddr: Integer;
  UseShortCircuit: Boolean;
begin
  CompileFactor(ValType);
  while Tok.Kind in MultiplicativeOperators do begin
    OpTok := Tok;
    NextTok;
    UseShortCircuit := (OpTok.Kind = ANDTOK) and (Types[ValType].Kind = BOOLEANTYPE);
    if UseShortCircuit then
      GenerateShortCircuitProlog(OpTok.Kind);
    CompileFactor(RightValType);
    // Try to convert integer to real
    ConvertIntegerToReal(ValType, RightValType, 0);
    ConvertIntegerToReal(RightValType, ValType, SizeOf(Double));
    // Special case: real division of two integers
    if OpTok.Kind = DIVTOK then begin
      ConvertIntegerToReal(REALTYPEINDEX, RightValType, 0);
      ConvertIntegerToReal(REALTYPEINDEX, ValType, SizeOf(Double));
    end;
    // Special case: set intersection
    if (OpTok.Kind = MULTOK) and (Types[ValType].Kind = SETTYPE) then  begin
      ValType           := GetCompatibleType(ValType, RightValType);
      LibProcIdentIndex := GetIdent('SETINTERSECTION');
      TempStorageAddr   := AllocateTempStorage(TypeSize(ValType));
      PushTempStoragePtr(TempStorageAddr);
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      PushTempStoragePtr(TempStorageAddr);
    end
    // General rule
    else begin
      ValType := GetCompatibleType(ValType, RightValType);
      CheckOperator(OpTok, ValType);
      if UseShortCircuit then
        GenerateShortCircuitEpilog
      else
        GenerateBinaryOperator(OpTok.Kind, ValType);
    end;
  end;// while
end;  // CompileTerm
procedure CompileSimpleExpression(var ValType: Integer);
var
  UnaryOpTok, OpTok: TToken;
  RightValType:      Integer;
  LibProcIdentIndex: Integer;
  TempStorageAddr:   Integer;
  UseShortCircuit:   Boolean;
begin
  UnaryOpTok := Tok;
  if UnaryOpTok.Kind in UnaryOperators then
    NextTok;
  CompileTerm(ValType);
  if UnaryOpTok.Kind in UnaryOperators then
    CheckOperator(UnaryOpTok, ValType);
  if UnaryOpTok.Kind = MINUSTOK then
    GenerateUnaryOperator(MINUSTOK, ValType);     // Unary minus
  while Tok.Kind in AdditiveOperators do begin
    OpTok := Tok;
    NextTok;
    UseShortCircuit := (OpTok.Kind = ORTOK) and (Types[ValType].Kind = BOOLEANTYPE);
    if UseShortCircuit then
      GenerateShortCircuitProlog(OpTok.Kind);
    CompileTerm(RightValType);
    // Try to convert integer to real
    ConvertIntegerToReal(ValType, RightValType, 0);
    ConvertIntegerToReal(RightValType, ValType, SizeOf(Double));
    // Try to convert character to string
    ConvertCharToString(ValType, RightValType, 0);
    ConvertCharToString(RightValType, ValType, SizeOf(Longint));
    // Special case: string concatenation
    if (OpTok.Kind = PLUSTOK) and IsString(ValType) and IsString(RightValType) then begin
      LibProcIdentIndex := GetIdent('CONCATSTR');
      TempStorageAddr   := AllocateTempStorage(TypeSize(STRINGTYPEINDEX));
      PushTempStoragePtr(TempStorageAddr);
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      PushTempStoragePtr(TempStorageAddr);
      ValType := STRINGTYPEINDEX;
    end
    // Special case: set union or difference
    else
      if (OpTok.Kind in [PLUSTOK, MINUSTOK]) and (Types[ValType].Kind = SETTYPE) then  begin
        ValType := GetCompatibleType(ValType, RightValType);
        if OpTok.Kind = PLUSTOK then
          LibProcIdentIndex := GetIdent('SETUNION')
        else
          LibProcIdentIndex := GetIdent('SETDIFFERENCE');
        TempStorageAddr := AllocateTempStorage(TypeSize(ValType));
        PushTempStoragePtr(TempStorageAddr);
        GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
        PushTempStoragePtr(TempStorageAddr);
      end
      // General rule
      else begin
        ValType := GetCompatibleType(ValType, RightValType);
        CheckOperator(OpTok, ValType);
        if UseShortCircuit then
          GenerateShortCircuitEpilog
        else
          GenerateBinaryOperator(OpTok.Kind, ValType);
      end;
  end;// while
end;  // CompileSimpleExpression
procedure CompileExpression(var ValType: Integer);
var
  OpTok:        TToken;
  RightValType: Integer;
  LibProcIdentIndex: Integer;
begin // CompileExpression
  CompileSimpleExpression(ValType);
  if Tok.Kind in RelationOperators then begin
    OpTok := Tok;
    NextTok;
    CompileSimpleExpression(RightValType);
    // Try to convert integer to real
    ConvertIntegerToReal(ValType, RightValType, 0);
    ConvertIntegerToReal(RightValType, ValType, SizeOf(Double));
    // Try to convert character to string
    ConvertCharToString(ValType, RightValType, 0);
    ConvertCharToString(RightValType, ValType, SizeOf(Longint));
    // Special case: string comparison
    if IsString(ValType) and IsString(RightValType) then begin
      LibProcIdentIndex := GetIdent('COMPARESTR');
      ValType           := Ident[LibProcIdentIndex].Signature.ResultType;
      RightValType      := INTEGERTYPEINDEX;
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      PushFunctionResult(ValType);
      PushConst(0);
    end;
    // Special case: set comparison
    if (OpTok.Kind in [EQTOK, NETOK, GETOK, LETOK]) and (Types[ValType].Kind = SETTYPE) then begin
      GetCompatibleType(ValType, RightValType);
      case OpTok.Kind of
        GETOK: LibProcIdentIndex := GetIdent('TESTSUPERSET');    // Returns  1 if Val >= RightVal, -1 otherwise
        LETOK: LibProcIdentIndex := GetIdent('TESTSUBSET');      // Returns -1 if Val <= RightVal,  1 otherwise
        else LibProcIdentIndex := GetIdent('COMPARESETS');       // Returns  0 if Val  = RightVal,  1 otherwise
      end;
      ValType      := Ident[LibProcIdentIndex].Signature.ResultType;
      RightValType := INTEGERTYPEINDEX;
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      PushFunctionResult(ValType);
      PushConst(0);
    end;
    GetCompatibleType(ValType, RightValType);
    CheckOperator(OpTok, ValType);
    ValType := BOOLEANTYPEINDEX;
    GenerateRelation(OpTok.Kind, RightValType);
  end
  else
    if Tok.Kind = INTOK then begin
      NextTok;
      CompileSimpleExpression(RightValType);
      if Types[RightValType].Kind <> SETTYPE then
        Error('Set expected');
      if Types[RightValType].BaseType <> ANYTYPEINDEX then
        GetCompatibleType(ValType, Types[RightValType].BaseType)
      else
        if not (Types[ValType].Kind in OrdinalTypes) then
          Error('Ordinal type expected');
      LibProcIdentIndex := GetIdent('INSET');
      ValType           := Ident[LibProcIdentIndex].Signature.ResultType;
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
      PushFunctionResult(ValType);
    end;
end;// CompileExpression
procedure CompileStatementList(LoopNesting: Integer);
begin
  CompileStatement(LoopNesting);
  while Tok.Kind = SEMICOLONTOK do begin
    NextTok;
    CompileStatement(LoopNesting);
  end;
end; // CompileStatementList
procedure CompileCompoundStatement(LoopNesting: Integer);
begin
  EatTok(BEGINTOK);
  CompileStatementList(LoopNesting);
  EatTok(ENDTOK);
end; // CompileCompoundStatement
procedure CompileStatement(LoopNesting: Integer);
  procedure CompileLabel;
  var
    LabelIndex: Integer;
  begin
    if Tok.Kind = IDENTTOK then begin
      LabelIndex := GetIdentUnsafe(Tok.Name);
      if LabelIndex <> 0 then
        if Ident[LabelIndex].Kind = GOTOLABEL then begin
          if Ident[LabelIndex].Block <> BlockStack[BlockStackTop].Index then
            Error('Label is not declared in current procedure');
          Ident[LabelIndex].Address        := GetCodeSize;
          Ident[LabelIndex].IsUnresolvedForward := False;
          Ident[LabelIndex].ForLoopNesting := ForLoopNesting;
          NextTok;
          EatTok(COLONTOK);
        end;
    end;
  end; // CompileLabel
  procedure CompileAssignment(DesignatorType: Integer);
  var
    ExpressionType:    Integer;
    LibProcIdentIndex: Integer;
  begin
    NextTok;
    CompileExpression(ExpressionType);
    // Try to convert integer to double, single to double or double to single
    ConvertIntegerToReal(DesignatorType, ExpressionType, 0);
    ConvertRealToReal(DesignatorType, ExpressionType);
    // Try to convert character to string
    ConvertCharToString(DesignatorType, ExpressionType, 0);
    // Try to convert string to pointer to character
    ConvertStringToPChar(DesignatorType, ExpressionType);
    // Try to convert a concrete type to an interface type
    ConvertToInterface(DesignatorType, ExpressionType);
    GetCompatibleType(DesignatorType, ExpressionType);
    if IsString(DesignatorType) then begin
      LibProcIdentIndex := GetIdent('ASSIGNSTR');
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
    end
    else
      if Types[DesignatorType].Kind in StructuredTypes then
        GenerateStructuredAssignment(DesignatorType)
      else
        GenerateAssignment(DesignatorType);
  end; // CompileAssignment
  procedure CompileAssignmentOrCall(DesignatorType: Integer; DesignatorIsStatement: Boolean);
  begin
    if Tok.Kind = OPARTOK then            // Method or procedural variable call (parentheses are required even for empty parameter list)
      CompileMethodOrProceduralVariableCall(DesignatorType, False, False)
    else
      if DesignatorIsStatement then    // Optional assignment if designator already ends with a function call
        if Tok.Kind = ASSIGNTOK then
          CompileAssignment(DesignatorType)
        else
          DiscardStackTop(1)                // Nothing to do - remove designator
      else                                  // Mandatory assignment
      begin
        CheckTok(ASSIGNTOK);
        CompileAssignment(DesignatorType);
      end;
  end; // CompileAssignmentOrCall
  procedure CompileIfStatement(LoopNesting: Integer);
  var
    ExpressionType: Integer;
  begin
    NextTok;
    CompileExpression(ExpressionType);
    GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX);
    EatTok(THENTOK);
    GenerateIfCondition;              // Satisfied if expression is not zero
    GenerateIfProlog;
    CompileStatement(LoopNesting);
    if Tok.Kind = ELSETOK then begin
      NextTok;
      GenerateElseProlog;
      CompileStatement(LoopNesting);
    end;
    GenerateIfElseEpilog;
  end;

  procedure CompileCaseStatement(LoopNesting: Integer);
  var
    SelectorType, ConstValType: Integer;
    NumCaseStatements:          Integer;
    ConstVal, ConstVal2:        TConst;
  begin
    NextTok;
    CompileExpression(SelectorType);
    if not (Types[SelectorType].Kind in OrdinalTypes) then
      Error('Ordinal variable expected as CASE selector');
    EatTok(OFTOK);
    GenerateCaseProlog;
    NumCaseStatements := 0;
    repeat       // Loop over all cases
      repeat     // Loop over all constants for the current case
        CompileConstExpression(ConstVal, ConstValType);
        GetCompatibleType(ConstValType, SelectorType);
        if Tok.Kind = RANGETOK then                                      // Range check
        begin
          NextTok;
          CompileConstExpression(ConstVal2, ConstValType);
          GetCompatibleType(ConstValType, SelectorType);
          GenerateCaseRangeCheck(ConstVal.OrdValue, ConstVal2.OrdValue);
        end
        else
          GenerateCaseEqualityCheck(ConstVal.OrdValue);                     // Equality check
        if Tok.Kind <> COMMATOK then
          Break;
        NextTok;
      until False;
      EatTok(COLONTOK);
      GenerateCaseStatementProlog;
      CompileStatement(LoopNesting);
      GenerateCaseStatementEpilog;
      Inc(NumCaseStatements);
      if (Tok.Kind = ELSETOK) or (Tok.Kind = ENDTOK) then
        Break;
      EatTok(SEMICOLONTOK);
    until (Tok.Kind = ELSETOK) or (Tok.Kind = ENDTOK);
    // Default statements
    if Tok.Kind = ELSETOK then  begin
      NextTok;
      CompileStatementList(LoopNesting);
    end;
    EatTok(ENDTOK);
    GenerateCaseEpilog(NumCaseStatements);
  end;

  procedure CompileWhileStatement(LoopNesting: Integer);
  var
    ExpressionType: Integer;
  begin
    SaveCodePos;      // Save return address used by GenerateWhileEpilog
    NextTok;
    CompileExpression(ExpressionType);
    GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX);
    EatTok(DOTOK);
    GenerateBreakProlog(LoopNesting);
    GenerateContinueProlog(LoopNesting);
    GenerateWhileCondition;                         // Satisfied if expression is not zero
    GenerateWhileProlog;
    CompileStatement(LoopNesting);
    GenerateContinueEpilog(LoopNesting);
    GenerateWhileEpilog;
    GenerateBreakEpilog(LoopNesting);
  end;

  procedure CompileRepeatStatement(LoopNesting: Integer);
  var
    ExpressionType: Integer;
  begin
    GenerateBreakProlog(LoopNesting);
    GenerateContinueProlog(LoopNesting);
    GenerateRepeatProlog;
    NextTok;
    CompileStatementList(LoopNesting);
    EatTok(UNTILTOK);
    GenerateContinueEpilog(LoopNesting);
    CompileExpression(ExpressionType);
    GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX);
    GenerateRepeatCondition;
    GenerateRepeatEpilog;
    GenerateBreakEpilog(LoopNesting);
  end;

  procedure CompileForStatement(LoopNesting: Integer);
  var
    CounterIndex:   Integer;
    ExpressionType: Integer;
    Down:           Boolean;
  begin
    NextTok;
    AssertIdent;
    CounterIndex := GetIdent(Tok.Name);
    if (Ident[CounterIndex].Kind <> VARIABLE) or ((Ident[CounterIndex].NestingLevel <> 1) and (Ident[CounterIndex].NestingLevel <> BlockStackTop)) or
      (Ident[CounterIndex].PassMethod <> EMPTYPASSING) then
      Error('Simple local variable expected as FOR loop counter');
    if not (Types[Ident[CounterIndex].DataType].Kind in OrdinalTypes) then
      Error('Ordinal variable expected as FOR loop counter');
    PushVarIdentPtr(CounterIndex);
    NextTok;
    EatTok(ASSIGNTOK);
    // Initial counter value
    CompileExpression(ExpressionType);
    GetCompatibleType(ExpressionType, Ident[CounterIndex].DataType);
    if not (Tok.Kind in [TOTOK, DOWNTOTOK]) then
      CheckTok(TOTOK);
    Down := Tok.Kind = DOWNTOTOK;
    NextTok;
    // Final counter value
    CompileExpression(ExpressionType);
    GetCompatibleType(ExpressionType, Ident[CounterIndex].DataType);
    // Assign initial value to the counter, compute and save the total number of iterations
    GenerateForAssignmentAndNumberOfIterations(Ident[CounterIndex].DataType, Down);
    // Save return address used by GenerateForEpilog
    SaveCodePos;
    // Check the remaining number of iterations
    GenerateForCondition;
    EatTok(DOTOK);
    GenerateBreakProlog(LoopNesting);
    GenerateContinueProlog(LoopNesting);
    GenerateForProlog;
    CompileStatement(LoopNesting);
    GenerateContinueEpilog(LoopNesting);
    PushVarIdentPtr(CounterIndex);
    GenerateForEpilog(Ident[CounterIndex].DataType, Down);
    GenerateBreakEpilog(LoopNesting);
    // Pop and discard the remaining number of iterations (i.e. zero)
    DiscardStackTop(1);
  end;

  procedure CompileGotoStatement(LoopNesting: Integer);
  var
    LabelIndex: Integer;
  begin
    NextTok;
    AssertIdent;
    LabelIndex := GetIdent(Tok.Name);
    if Ident[LabelIndex].Kind <> GOTOLABEL then
      Error('Label expected');
    if Ident[LabelIndex].Block <> BlockStack[BlockStackTop].Index then
      Error('Label is not declared in current procedure');
    GenerateGoto(LabelIndex);
    NextTok;
  end;

  procedure CompileWithStatement(LoopNesting: Integer);
  var
    DesignatorType:   Integer;
    DeltaWithNesting: Integer;
    TempStorageAddr:  Integer;
    IsConst:          Boolean;
  begin
    NextTok;
    DeltaWithNesting := 0;
    repeat
      // Save designator pointer to temporary storage
      TempStorageAddr := AllocateTempStorage(TypeSize(POINTERTYPEINDEX));
      PushTempStoragePtr(TempStorageAddr);
      CompileBasicDesignator(DesignatorType, IsConst);
      CompileSelectors(DesignatorType);
      if not (Types[DesignatorType].Kind in [RECORDTYPE, INTERFACETYPE]) then
        Error('Record or interface expected');
      GenerateAssignment(POINTERTYPEINDEX);
      // Save designator info
      Inc(DeltaWithNesting);
      Inc(WithNesting);
      if WithNesting > MAXWITHNESTING then
        Error('Maximum WITH block nesting exceeded');
      WithStack[WithNesting].TempPointer := TempStorageAddr;
      WithStack[WithNesting].DataType    := DesignatorType;
      WithStack[WithNesting].IsConst     := IsConst;
      if Tok.Kind <> COMMATOK then
        Break;
      NextTok;
    until False;
    EatTok(DOTOK);
    CompileStatement(LoopNesting);
    WithNesting := WithNesting - DeltaWithNesting;
  end;

  function IsCurrentOrOuterFunc(FuncIdentIndex: Integer): Boolean;
  var
    BlockStackIndex: Integer;
  begin
    if Ident[FuncIdentIndex].Kind = FUNC then
      for BlockStackIndex := BlockStackTop downto 1 do
        if BlockStack[BlockStackIndex].Index = Ident[FuncIdentIndex].ProcAsBlock then begin
          Result := True;
          Exit;
        end;
    Result := False;
  end;

var
  IdentIndex:     Integer;
  DesignatorType: Integer;
  DesignatorIsStatement: Boolean;
begin // CompileStatement
  CompileLabel;
  case Tok.Kind of
    IDENTTOK: if FieldOrMethodInsideWithFound(Tok.Name) then                      // Record field or method inside a WITH block
      begin
        DesignatorIsStatement := CompileDesignator(DesignatorType, False);
        CompileAssignmentOrCall(DesignatorType, DesignatorIsStatement);
      end
      else                                                                // Ordinary identifier
      begin
        IdentIndex := GetIdent(Tok.Name);
        case Ident[IdentIndex].Kind of
          VARIABLE, USERTYPE:                                             // Assignment or procedural variable call
          begin
            DesignatorIsStatement := CompileDesignator(DesignatorType, False);
            CompileAssignmentOrCall(DesignatorType, DesignatorIsStatement);
          end;
          PROC, FUNC:                                                     // Procedure or function call (returned result discarded)
            if Ident[IdentIndex].PredefProc <> EMPTYPROC then             // Predefined procedure
            begin
              if Ident[IdentIndex].Kind <> PROC then
                Error('Procedure expected but predefined function ' + Ident[IdentIndex].Name + ' found');
              CompilePredefinedProc(Ident[IdentIndex].PredefProc, LoopNesting);
            end
            else                                                          // User-defined procedure or function
            begin
              NextTok;
              if Tok.Kind = ASSIGNTOK then                                // Special case: assignment to a function name
              begin
                if not IsCurrentOrOuterFunc(IdentIndex) then
                  Error('Function name expected but ' + Ident[IdentIndex].Name + ' found');
                // Push pointer to Result
                PushVarIdentPtr(Ident[IdentIndex].ResultIdentIndex);
                DesignatorType := Ident[Ident[IdentIndex].ResultIdentIndex].DataType;
                if Ident[Ident[IdentIndex].ResultIdentIndex].PassMethod = VARPASSING then
                  DerefPtr(POINTERTYPEINDEX);
                CompileAssignment(DesignatorType);
              end
              else                                                        // General rule: procedure or function call
              begin
                CompileCall(IdentIndex);
                DesignatorType := Ident[IdentIndex].Signature.ResultType;
                if (Ident[IdentIndex].Kind = FUNC) and (Tok.Kind in [DEREFERENCETOK, OBRACKETTOK, PERIODTOK, OPARTOK]) and
                  ((Types[DesignatorType].Kind in StructuredTypes) or DereferencePointerAsDesignator(DesignatorType, False)) then begin
                  PushFunctionResult(DesignatorType);
                  DesignatorIsStatement := CompileSelectors(DesignatorType, True);
                  CompileAssignmentOrCall(DesignatorType, DesignatorIsStatement);
                end;
              end;
            end;
          else Error('Statement expected but ' + Ident[IdentIndex].Name + ' found');
        end; // case Ident[IdentIndex].Kind
      end;   // else
    BEGINTOK: CompileCompoundStatement(LoopNesting);
    IFTOK: CompileIfStatement(LoopNesting);
    CASETOK: CompileCaseStatement(LoopNesting);
    WHILETOK: CompileWhileStatement(LoopNesting + 1);
    REPEATTOK: CompileRepeatStatement(LoopNesting + 1);
    FORTOK: CompileForStatement(LoopNesting + 1);
    GOTOTOK: CompileGotoStatement(LoopNesting);
    WITHTOK: CompileWithStatement(LoopNesting);
  end;
end;

procedure CompileType(var DataType: Integer);
  procedure CompileEnumeratedType(var DataType: Integer);
  var
    ConstIndex: Integer;
  begin
    // Add new anonymous type
    DeclareType(ENUMERATEDTYPE);
    DataType   := NumTypes;
    // Compile enumeration constants
    ConstIndex := 0;
    NextTok;
    repeat
      AssertIdent;
      DeclareIdent(Tok.Name, CONSTANT, 0, False, DataType, EMPTYPASSING, ConstIndex, 0.0, '', [], EMPTYPROC, '', 0);
      Inc(ConstIndex);
      if ConstIndex > MAXENUMELEMENTS - 1 then
        Error('Too many enumeration elements');
      NextTok;
      if Tok.Kind <> COMMATOK then
        Break;
      NextTok;
    until False;
    EatTok(CPARTOK);
    Types[DataType].Low  := 0;
    Types[DataType].High := ConstIndex - 1;
  end;

  procedure CompileTypedPointerType(var DataType: Integer);
  var
    NestedDataType: Integer;
  begin
    // Add new anonymous type
    DeclareType(POINTERTYPE);
    DataType := NumTypes;
    // Compile pointer base type
    NextTok;
    CompileTypeIdent(NestedDataType, True);
    Types[DataType].BaseType := NestedDataType;
  end;

  procedure CompileArrayType(var DataType: Integer);
  var
    ArrType, IndexType, NestedDataType: Integer;
  begin
    NextTok;
    EatTok(OBRACKETTOK);
    DataType := NumTypes + 1;
    repeat
      // Add new anonymous type
      DeclareType(ARRAYTYPE);
      Types[NumTypes].IsOpenArray := False;
      ArrType := NumTypes;
      CompileType(IndexType);
      if not (Types[IndexType].Kind in OrdinalTypes) then
        Error('Ordinal type expected');
      Types[ArrType].IndexType := IndexType;
      if Tok.Kind <> COMMATOK then
        Break;
      Types[ArrType].BaseType := NumTypes + 1;
      NextTok;
    until False;
    EatTok(CBRACKETTOK);
    EatTok(OFTOK);
    CompileType(NestedDataType);
    Types[ArrType].BaseType := NestedDataType;
  end;

  procedure CompileRecordOrInterfaceType(var DataType: Integer; IsInterfaceType: Boolean);
    procedure DeclareField(const FieldName: TString; RecType, FieldType: Integer; var NextFieldOffset: Integer);
    var
      i, FieldTypeSize: Integer;
    begin
      for i := 1 to Types[RecType].NumFields do
        if Types[RecType].Field[i]^.Name = FieldName then
          Error('Duplicate field ' + FieldName);
      // Add new field
      Inc(Types[RecType].NumFields);
      if Types[RecType].NumFields > MAXFIELDS then
        Error('Too many fields');
      New(Types[RecType].Field[Types[RecType].NumFields]);
      with Types[RecType].Field[Types[RecType].NumFields]^ do begin
        Name     := FieldName;
        DataType := FieldType;
        Offset   := NextFieldOffset;
      end;
      // For interfaces, save Self pointer offset from the procedural field
      if Types[RecType].Kind = INTERFACETYPE then
        Types[FieldType].SelfPointerOffset := -NextFieldOffset;
      FieldTypeSize := TypeSize(FieldType);
      if FieldTypeSize > HighBound(INTEGERTYPEINDEX) - NextFieldOffset then
        Error('Type size is too large');
      NextFieldOffset := NextFieldOffset + FieldTypeSize;
    end;

    procedure CompileFixedFields(RecType: Integer; var NextFieldOffset: Integer);
    var
      FieldInListName: array [1..MAXFIELDS] of TString;
      NumFieldsInList, FieldInListIndex: Integer;
      FieldType:       Integer;
    begin
      while not (Tok.Kind in [CASETOK, ENDTOK, CPARTOK]) do begin
        NumFieldsInList := 0;
        repeat
          AssertIdent;
          Inc(NumFieldsInList);
          if NumFieldsInList > MAXFIELDS then
            Error('Too many fields');
          FieldInListName[NumFieldsInList] := Tok.Name;
          NextTok;
          if (Tok.Kind <> COMMATOK) or IsInterfaceType then
            Break;
          NextTok;
        until False;
        EatTok(COLONTOK);
        CompileType(FieldType);
        if IsInterfaceType and (Types[FieldType].Kind <> PROCEDURALTYPE) then
          Error('Non-procedural fields are not allowed in interfaces');
        for FieldInListIndex := 1 to NumFieldsInList do
          DeclareField(FieldInListName[FieldInListIndex], DataType, FieldType, NextFieldOffset);
        if Tok.Kind <> SEMICOLONTOK then
          Break;
        NextTok;
      end; // while
    end;

    procedure CompileFields(RecType: Integer; var NextFieldOffset: Integer);
    var
      TagName: TString;
      TagVal:  TConst;
      TagType, TagValType: Integer;
      TagTypeIdentIndex: Integer;
      VariantStartOffset: Integer;
    begin
      // Fixed fields
      CompileFixedFields(DataType, NextFieldOffset);
      // Variant fields
      if (Tok.Kind = CASETOK) and not IsInterfaceType then begin
        NextTok;
        // Tag field
        AssertIdent;
        TagTypeIdentIndex := GetIdentUnsafe(Tok.Name);
        if (TagTypeIdentIndex <> 0) and (Ident[TagTypeIdentIndex].Kind = USERTYPE) then      // Type name found
        begin
          TagType := Ident[TagTypeIdentIndex].DataType;
          NextTok;
        end
        else                                                                                 // Field name found
        begin
          TagName := Tok.Name;
          NextTok;
          EatTok(COLONTOK);
          CompileType(TagType);
          DeclareField(TagName, DataType, TagType, NextFieldOffset);
        end;
        if not (Types[TagType].Kind in OrdinalTypes) then
          Error('Ordinal type expected');
        VariantStartOffset := NextFieldOffset;
        EatTok(OFTOK);
        // Variants
        repeat
          repeat
            CompileConstExpression(TagVal, TagValType);
            GetCompatibleType(TagType, TagValType);
            if Tok.Kind <> COMMATOK then
              Break;
            NextTok;
          until False;
          EatTok(COLONTOK);
          EatTok(OPARTOK);
          NextFieldOffset := VariantStartOffset;
          CompileFields(DataType, NextFieldOffset);
          EatTok(CPARTOK);
          if (Tok.Kind = CPARTOK) or (Tok.Kind = ENDTOK) then
            Break;
          EatTok(SEMICOLONTOK);
        until (Tok.Kind = CPARTOK) or (Tok.Kind = ENDTOK);
      end; // if
    end;   // CompileFields
  var
    NextFieldOffset: Integer;
  begin // CompileRecordOrInterfaceType
    NextFieldOffset := 0;
    // Add new anonymous type
    if IsInterfaceType then
      DeclareType(INTERFACETYPE)
    else
      DeclareType(RECORDTYPE);
    Types[NumTypes].NumFields := 0;
    DataType := NumTypes;
    // Declare hidden Self pointer for interfaces
    if IsInterfaceType then
      DeclareField('SELF', DataType, POINTERTYPEINDEX, NextFieldOffset);
    NextTok;
    CompileFields(DataType, NextFieldOffset);
    EatTok(ENDTOK);
  end;

  procedure CompileSetType(var DataType: Integer);
  var
    NestedDataType: Integer;
  begin
    // Add new anonymous type
    DeclareType(SETTYPE);
    DataType := NumTypes;
    NextTok;
    EatTok(OFTOK);
    CompileType(NestedDataType);
    if (LowBound(NestedDataType) < 0) or (HighBound(NestedDataType) > MAXSETELEMENTS - 1) then
      Error('Too many set elements');
    Types[DataType].BaseType := NestedDataType;
  end; // CompileSetType
  procedure CompileStringType(var DataType: Integer);
  var
    LenConstVal:        TConst;
    LenType, IndexType: Integer;
  begin
    NextTok;
    if Tok.Kind = OBRACKETTOK then begin
      NextTok;
      CompileConstExpression(LenConstVal, LenType);
      if not (Types[LenType].Kind in IntegerTypes) then
        Error('Integer type expected');
      if (LenConstVal.OrdValue <= 0) or (LenConstVal.OrdValue > MAXSTRLENGTH) then
        Error('Illegal string length');
      // Add new anonymous type: 1..Len + 1
      DeclareType(SUBRANGETYPE);
      IndexType := NumTypes;
      Types[IndexType].BaseType := LenType;
      Types[IndexType].Low := 1;
      Types[IndexType].High := LenConstVal.OrdValue + 1;
      // Add new anonymous type: array [1..Len + 1] of Char
      DeclareType(ARRAYTYPE);
      DataType := NumTypes;
      Types[DataType].BaseType := CHARTYPEINDEX;
      Types[DataType].IndexType := IndexType;
      Types[DataType].IsOpenArray := False;
      EatTok(CBRACKETTOK);
    end
    else
      DataType := STRINGTYPEINDEX;
  end;

  procedure CompileFileType(var DataType: Integer);
  var
    NestedDataType: Integer;
  begin
    NextTok;
    if Tok.Kind = OFTOK then          // Typed file
    begin
      NextTok;
      CompileType(NestedDataType);
      if Types[NestedDataType].Kind = FILETYPE then
        Error('File of files is not allowed');
      // Add new anonymous type
      DeclareType(FILETYPE);
      Types[NumTypes].BaseType := NestedDataType;
      DataType := NumTypes;
    end
    else                              // Untyped/text file
      DataType := FILETYPEINDEX;
  end;

  procedure CompileSubrangeType(var DataType: Integer);
  var
    ConstVal: TConst;
    LowBoundType, HighBoundType: Integer;
  begin
    // Add new anonymous type
    DeclareType(SUBRANGETYPE);
    DataType := NumTypes;
    CompileConstExpression(ConstVal, LowBoundType);                               // Subrange lower bound
    if not (Types[LowBoundType].Kind in OrdinalTypes + [SUBRANGETYPE]) then
      Error('Ordinal type expected');
    Types[DataType].Low := ConstVal.OrdValue;
    EatTok(RANGETOK);
    CompileConstExpression(ConstVal, HighBoundType);                              // Subrange upper bound
    if not (Types[HighBoundType].Kind in OrdinalTypes + [SUBRANGETYPE]) then
      Error('Ordinal type expected');
    Types[DataType].High := ConstVal.OrdValue;
    GetCompatibleType(LowBoundType, HighBoundType);
    if Types[DataType].High < Types[DataType].Low then
      Error('Illegal subrange bounds');
    Types[DataType].BaseType := LowBoundType;
  end;

  procedure CompileProceduralType(var DataType: Integer; IsFunction: Boolean);
  begin
    DeclareType(PROCEDURALTYPE);
    Types[NumTypes].MethodIdentIndex := 0;
    DataType := NumTypes;
    NextTok;
    CompileFormalParametersAndResult(IsFunction, Types[DataType].Signature);
  end;

var
  IdentIndex:    Longint;
  TypeNameGiven: Boolean;
begin
  if Tok.Kind = PACKEDTOK then        // PACKED has no effect
  begin
    NextTok;
    if not (Tok.Kind in [ARRAYTOK, RECORDTOK, INTERFACETOK, SETTOK, FILETOK]) then
      Error('PACKED is not allowed here');
  end;
  case Tok.Kind of
    OPARTOK: CompileEnumeratedType(DataType);
    DEREFERENCETOK: CompileTypedPointerType(DataType);
    ARRAYTOK: CompileArrayType(DataType);
    RECORDTOK, INTERFACETOK: CompileRecordOrInterfaceType(DataType, Tok.Kind = INTERFACETOK);
    SETTOK: CompileSetType(DataType);
    STRINGTOK: CompileStringType(DataType);
    FILETOK: CompileFileType(DataType);
    PROCEDURETOK, FUNCTIONTOK: CompileProceduralType(DataType, Tok.Kind = FUNCTIONTOK)
    else                                                                              // Subrange or type name
      TypeNameGiven := False;
      IdentIndex    := 0;
      if Tok.Kind = IDENTTOK then  begin
        IdentIndex := GetIdent(Tok.Name);
        if Ident[IdentIndex].Kind = USERTYPE then
          TypeNameGiven := True;
      end;
      if TypeNameGiven then                                                           // Type name
      begin
        DataType := Ident[IdentIndex].DataType;
        NextTok;
      end
      else                                                                            // Subrange
        CompileSubrangeType(DataType);
  end;
end;

procedure CompileBlock(BlockIdentIndex: Integer);
  procedure ResolveForwardReferences;
  var
    TypeIndex, TypeIdentIndex, FieldIndex: Integer;
    DataType: Integer;
  begin
    for TypeIndex := 1 to NumTypes do
      if Types[TypeIndex].Kind = FORWARDTYPE then begin
        TypeIdentIndex := GetIdent(Types[TypeIndex].TypeIdentName);
        if Ident[TypeIdentIndex].Kind <> USERTYPE then
          Error('Type name expected');
        // Forward reference resolution
        DataType         := Ident[TypeIdentIndex].DataType;
        Types[TypeIndex] := Types[DataType];
        Types[TypeIndex].AliasType := DataType;
        if Types[DataType].Kind in [RECORDTYPE, INTERFACETYPE] then
          for FieldIndex := 1 to Types[DataType].NumFields do begin
            New(Types[TypeIndex].Field[FieldIndex]);
            Types[TypeIndex].Field[FieldIndex]^ := Types[DataType].Field[FieldIndex]^;
          end;
      end; // if    
  end;     // ResolveForwardReferences
  procedure CompileInitializer(InitializedDataOffset: Longint; ConstType: Integer);
  var
    ConstVal:     TConst;
    ConstValType: Integer;
    NumElements, ElementIndex, FieldIndex: Integer;
  begin
    // Numbers
    if Types[ConstType].Kind in OrdinalTypes + [REALTYPE, SINGLETYPE] then begin
      CompileConstExpression(ConstVal, ConstValType);
      // Try to convert integer to double or double to single
      ConvertConstIntegerToReal(ConstType, ConstValType, ConstVal);
      ConvertConstRealToReal(ConstType, ConstValType, ConstVal);
      GetCompatibleType(ConstType, ConstValType);
      if Types[ConstType].Kind = REALTYPE then
        Move(ConstVal.RealValue, InitializedGlobalData[InitializedDataOffset], TypeSize(ConstType))
      else
        if Types[ConstType].Kind = SINGLETYPE then
          Move(ConstVal.SingleValue, InitializedGlobalData[InitializedDataOffset], TypeSize(ConstType))
        else
          Move(ConstVal.OrdValue, InitializedGlobalData[InitializedDataOffset], TypeSize(ConstType));
    end
    // Arrays
    else
      if Types[ConstType].Kind = ARRAYTYPE then begin
        if IsString(ConstType) and (Tok.Kind <> OPARTOK) then         // Special case: strings
        begin
          CompileConstExpression(ConstVal, ConstValType);
          ConvertConstCharToString(ConstType, ConstValType, ConstVal);
          GetCompatibleType(ConstType, ConstValType);
          if Length(ConstVal.StrValue) > TypeSize(ConstType) - 1 then
            Error('String is too long');
          DefineStaticString(ConstVal.StrValue, InitializedDataOffset, InitializedDataOffset);
        end
        else                                                          // General rule
        begin
          EatTok(OPARTOK);
          NumElements := HighBound(Types[ConstType].IndexType) - LowBound(Types[ConstType].IndexType) + 1;
          for ElementIndex := 1 to NumElements do begin
            CompileInitializer(InitializedDataOffset, Types[ConstType].BaseType);
            InitializedDataOffset := InitializedDataOffset + TypeSize(Types[ConstType].BaseType);
            if ElementIndex < NumElements then
              EatTok(COMMATOK)
            else
              EatTok(CPARTOK);
          end; // for
        end;   // else
      end
      // Records
      else
        if Types[ConstType].Kind = RECORDTYPE then begin
          EatTok(OPARTOK);
          repeat
            AssertIdent;
            FieldIndex := GetField(ConstType, Tok.Name);
            NextTok;
            EatTok(COLONTOK);
            CompileInitializer(InitializedDataOffset + Types[ConstType].Field[FieldIndex]^.Offset, Types[ConstType].Field[FieldIndex]^.DataType);
            if Tok.Kind <> SEMICOLONTOK then
              Break;
            NextTok;
          until False;
          EatTok(CPARTOK);
        end
        // Sets
        else
          if Types[ConstType].Kind = SETTYPE then begin
            CompileConstExpression(ConstVal, ConstValType);
            GetCompatibleType(ConstType, ConstValType);
            DefineStaticSet(ConstVal.SetValue, InitializedDataOffset, InitializedDataOffset);
          end
          else
            Error('Illegal type');
  end; // CompileInitializer
  procedure CompileLabelDeclarations;
  begin
    repeat
      AssertIdent;
      DeclareIdent(Tok.Name, GOTOLABEL, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      NextTok;
      if Tok.Kind <> COMMATOK then
        Break;
      NextTok;
    until False;
    EatTok(SEMICOLONTOK);
  end; // CompileLabelDeclarations
  procedure CompileConstDeclarations;
    procedure CompileUntypedConstDeclaration(var NameTok: TToken);
    var
      ConstVal:     TConst;
      ConstValType: Integer;
    begin
      EatTok(EQTOK);
      CompileConstExpression(ConstVal, ConstValType);
      DeclareIdent(NameTok.Name, CONSTANT, 0, False, ConstValType, EMPTYPASSING, ConstVal.OrdValue, ConstVal.RealValue, ConstVal.StrValue, ConstVal.SetValue, EMPTYPROC, '', 0);
    end; // CompileUntypedConstDeclaration;
    procedure CompileTypedConstDeclaration(var NameTok: TToken);
    var
      ConstType: Integer;
    begin
      EatTok(COLONTOK);
      CompileType(ConstType);
      DeclareIdent(NameTok.Name, CONSTANT, 0, False, ConstType, VARPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      EatTok(EQTOK);
      CompileInitializer(Ident[NumIdent].Address, ConstType);
    end; // CompileTypedConstDeclaration    
  var
    NameTok: TToken;
  begin // CompileConstDeclarations
    repeat
      AssertIdent;
      NameTok := Tok;
      NextTok;
      if Tok.Kind = EQTOK then
        CompileUntypedConstDeclaration(NameTok)
      else
        CompileTypedConstDeclaration(NameTok);
      EatTok(SEMICOLONTOK);
    until Tok.Kind <> IDENTTOK;
  end; // CompileConstDeclarations
  procedure CompileTypeDeclarations;
  var
    NameTok: TToken;
    VarType: Integer;
  begin
    repeat
      AssertIdent;
      NameTok := Tok;
      NextTok;
      EatTok(EQTOK);
      CompileType(VarType);
      DeclareIdent(NameTok.Name, USERTYPE, 0, False, VarType, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      EatTok(SEMICOLONTOK);
    until Tok.Kind <> IDENTTOK;
    ResolveForwardReferences;
  end; // CompileTypeDeclarations
  procedure CompileVarDeclarations;
  var
    IdentInListName: array [1..MAXPARAMS] of TString;
    NumIdentInList, IdentInListIndex: Integer;
    VarType:         Integer;
  begin
    repeat
      NumIdentInList := 0;
      repeat
        AssertIdent;
        Inc(NumIdentInList);
        if NumIdentInList > MAXPARAMS then
          Error('Too many variables in one list');
        IdentInListName[NumIdentInList] := Tok.Name;
        NextTok;
        if Tok.Kind <> COMMATOK then
          Break;
        NextTok;
      until False;
      EatTok(COLONTOK);
      CompileType(VarType);
      if Tok.Kind = EQTOK then                                     // Initialized variable (equivalent to a typed constant, but mutable)
      begin
        if BlockStack[BlockStackTop].Index <> 1 then
          Error('Local variables cannot be initialized');
        if NumIdentInList <> 1 then
          Error('Multiple variables cannot be initialized');
        NextTok;
        DeclareIdent(IdentInListName[1], CONSTANT, 0, False, VarType, VARPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
        Ident[NumIdent].IsTypedConst := False;  // Allow mutability
        CompileInitializer(Ident[NumIdent].Address, VarType);
      end
      else                                                         // Uninitialized variables
        for IdentInListIndex := 1 to NumIdentInList do
          DeclareIdent(IdentInListName[IdentInListIndex], VARIABLE, 0, False, VarType, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      EatTok(SEMICOLONTOK);
    until Tok.Kind <> IDENTTOK;
    ResolveForwardReferences;
  end; // CompileVarDeclarations
  procedure CompileProcFuncDeclarations(IsFunction: Boolean);
    function CompileDirective(const ImportFuncName: TString): Boolean;
    var
      ImportLibNameConst:        TConst;
      ImportLibNameConstValType: Integer;
    begin
      Result := False;
      if Tok.Kind = IDENTTOK then
        if Tok.Name = 'EXTERNAL' then      // External (Windows API) declaration
        begin
          if BlockStackTop <> 1 then
            Error('External declaration must be global');
          // Read import library name
          NextTok;
          CompileConstExpression(ImportLibNameConst, ImportLibNameConstValType);
          if not IsString(ImportLibNameConstValType) then
            Error('Library name expected');
          // Register import function
          GenerateImportFuncStub(AddImportFunc(ImportLibNameConst.StrValue, ImportFuncName));
          EatTok(SEMICOLONTOK);
          Result := True;
        end
        else
          if Tok.Name = 'FORWARD' then  // Forward declaration
          begin
            Inc(NumBlocks);
            Ident[NumIdent].ProcAsBlock         := NumBlocks;
            Ident[NumIdent].IsUnresolvedForward := True;
            GenerateForwardReference;
            NextTok;
            EatTok(SEMICOLONTOK);
            Result := True;
          end
          else
            Error('Unknown directive ' + Tok.Name);
    end; // CompileDirective
    function CompileInterface: Boolean;
    begin
      Result := False;
      // Procedure interface in the interface section of a unit is an implicit forward declaration
      if ParserState.IsInterfaceSection and (BlockStack[BlockStackTop].Index = 1) then begin
        Inc(NumBlocks);
        Ident[NumIdent].ProcAsBlock         := NumBlocks;
        Ident[NumIdent].IsUnresolvedForward := True;
        GenerateForwardReference;
        Result := True;
      end;
    end; // CompileInterface
  var
    ForwardIdentIndex, FieldIndex: Integer;
    ReceiverType: Integer;
    ProcOrFunc:   TIdentKind;
    ProcName, NonUppercaseProcName, ReceiverName: TString;
    ForwardResolutionSignature: TSignature;
  begin // CompileProcFuncDeclarations
    AssertIdent;
    ProcName := Tok.Name;
    NonUppercaseProcName := Tok.NonUppercaseName;
    NextTok;
    // Check for method declaration
    ReceiverName := '';
    ReceiverType := 0;
    if Tok.Kind = FORTOK then begin
      NextTok;
      AssertIdent;
      ReceiverName := Tok.Name;
      NextTok;
      EatTok(COLONTOK);
      CompileTypeIdent(ReceiverType, False);
      if not (Types[ReceiverType].Kind in StructuredTypes) then
        Error('Structured type expected');
      if BlockStack[BlockStackTop].Index <> 1 then
        Error('Methods cannot be nested');
      if Types[ReceiverType].Kind in [RECORDTYPE, INTERFACETYPE] then begin
        FieldIndex := GetFieldUnsafe(ReceiverType, ProcName);
        if FieldIndex <> 0 then
          Error('Duplicate field');
      end;
    end;
    // Check for forward declaration resolution
    if ReceiverType <> 0 then
      ForwardIdentIndex := GetMethodUnsafe(ReceiverType, ProcName)
    else
      ForwardIdentIndex := GetIdentUnsafe(ProcName);
    // Possibly found an identifier of another kind or scope, or it is already resolved
    if ForwardIdentIndex <> 0 then
      if not Ident[ForwardIdentIndex].IsUnresolvedForward or (Ident[ForwardIdentIndex].Block <> BlockStack[BlockStackTop].Index) or
        ((Ident[ForwardIdentIndex].Kind <> PROC) and not IsFunction) or ((Ident[ForwardIdentIndex].Kind <> FUNC) and IsFunction) then
        ForwardIdentIndex := 0;
    // Procedure/function signature
    if ForwardIdentIndex <> 0 then                                      // Forward declaration resolution
    begin
      CompileFormalParametersAndResult(IsFunction, ForwardResolutionSignature);
      CheckSignatures(Ident[ForwardIdentIndex].Signature, ForwardResolutionSignature, ProcName);
      DisposeParams(ForwardResolutionSignature);
    end
    else                                                                // Conventional declaration
    begin
      if IsFunction then
        ProcOrFunc := FUNC
      else
        ProcOrFunc := PROC;
      DeclareIdent(ProcName, ProcOrFunc, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, ReceiverName, ReceiverType);
      CompileFormalParametersAndResult(IsFunction, Ident[NumIdent].Signature);
      if (ReceiverType <> 0) and (Ident[NumIdent].Signature.CallConv <> DEFAULTCONV) then
        Error('STDCALL/CDECL is not allowed for methods');
    end;
    EatTok(SEMICOLONTOK);
    // Procedure/function body, if any
    if ForwardIdentIndex <> 0 then                                                    // Forward declaration resolution
    begin
      if (ReceiverType <> 0) and (ReceiverName <> Ident[ForwardIdentIndex].ReceiverName) then
        Error('Incompatible receiver name');
      GenerateForwardResolution(Ident[ForwardIdentIndex].Address);
      CompileBlock(ForwardIdentIndex);
      EatTok(SEMICOLONTOK);
      Ident[ForwardIdentIndex].IsUnresolvedForward := False;
    end
    else
      if not CompileDirective(NonUppercaseProcName) and not CompileInterface then // Declaration in the interface part, external or forward declaration
      begin
        Inc(NumBlocks);                                                                 // Conventional declaration
        Ident[NumIdent].ProcAsBlock := NumBlocks;
        CompileBlock(NumIdent);
        EatTok(SEMICOLONTOK);
      end;
  end;

  procedure CompileDeclarations;
  var
    DeclTok:          TToken;
    ParamIndex, StackParamIndex: Integer;
    TotalParamSize:   Integer;
    NestedProcsFound: Boolean;

    procedure DeclareResult;
    begin
      with Ident[BlockIdentIndex].Signature do
        if (Types[ResultType].Kind in StructuredTypes) and ((CallConv = DEFAULTCONV) or (TypeSize(ResultType) > 2 * SizeOf(Longint))) then
          // For functions returning structured variables, Result is a hidden VAR parameter
          DeclareIdent('RESULT', VARIABLE, TotalParamSize, False, ResultType, VARPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0)
        else                                                                                  // Otherwise, Result is a hidden local variable
          DeclareIdent('RESULT', VARIABLE, 0, False, ResultType, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      Ident[BlockIdentIndex].ResultIdentIndex := NumIdent;
    end; // DeclareResult
  begin
    NestedProcsFound := False;
    // For procedures and functions, declare parameters and the Result variable
    // Default calling convention: ([var Self,] [var Result,] Parameter1, ... ParameterN [, StaticLink]), result returned in EAX
    // STDCALL calling convention: (ParameterN, ... Parameter1, [, var Result]), result returned in EAX, small structures in EDX:EAX, reals in ST(0)
    // CDECL calling convention:   equivalent to STDCALL, except that caller clears the stack
    if BlockStack[BlockStackTop].Index <> 1 then  begin
      TotalParamSize := GetTotalParamSize(Ident[BlockIdentIndex].Signature, Ident[BlockIdentIndex].ReceiverType <> 0, False);
      // Declare Self
      if Ident[BlockIdentIndex].ReceiverType <> 0 then
        DeclareIdent(Ident[BlockIdentIndex].ReceiverName, VARIABLE, TotalParamSize, False, Ident[BlockIdentIndex].ReceiverType, VARPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
      // Declare Result (default calling convention)
      if (Ident[BlockIdentIndex].Kind = FUNC) and (Ident[BlockIdentIndex].Signature.CallConv = DEFAULTCONV) then
        DeclareResult;
      // Allocate and declare other parameters
      for ParamIndex := 1 to Ident[BlockIdentIndex].Signature.NumParams do begin
        if Ident[BlockIdentIndex].Signature.CallConv = DEFAULTCONV then
          StackParamIndex := ParamIndex
        else
          StackParamIndex := Ident[BlockIdentIndex].Signature.NumParams - ParamIndex + 1;    // Inverse parameter stack for STDCALL/CDECL procedures
        DeclareIdent(Ident[BlockIdentIndex].Signature.Param[StackParamIndex]^.Name,
          VARIABLE,
          TotalParamSize,
          Ident[BlockIdentIndex].Signature.CallConv <> DEFAULTCONV,
          Ident[BlockIdentIndex].Signature.Param[StackParamIndex]^.DataType,
          Ident[BlockIdentIndex].Signature.Param[StackParamIndex]^.PassMethod,
          0,
          0.0,
          '',
          [],
          EMPTYPROC,
          '',
          0);
      end;
      // Declare Result (STDCALL/CDECL calling convention)
      if (Ident[BlockIdentIndex].Kind = FUNC) and (Ident[BlockIdentIndex].Signature.CallConv <> DEFAULTCONV) then
        DeclareResult;
    end; // if
         // Loop over interface/implementation sections
    repeat
      // Local declarations
      while Tok.Kind in [LABELTOK, CONSTTOK, TYPETOK, VARTOK, PROCEDURETOK, FUNCTIONTOK] do begin
        DeclTok := Tok;
        NextTok;
        case DeclTok.Kind of
          LABELTOK: CompileLabelDeclarations;
          CONSTTOK: CompileConstDeclarations;
          TYPETOK: CompileTypeDeclarations;
          VARTOK: CompileVarDeclarations;
          PROCEDURETOK, FUNCTIONTOK: begin
            if (BlockStack[BlockStackTop].Index <> 1) and not NestedProcsFound then begin
              NestedProcsFound := True;
              GenerateNestedProcsProlog;
            end;
            CompileProcFuncDeclarations(DeclTok.Kind = FUNCTIONTOK);
          end;
        end; // case
      end;   // while
      if ParserState.IsUnit and ParserState.IsInterfaceSection and (BlockStack[BlockStackTop].Index = 1) then begin
        EatTok(IMPLEMENTATIONTOK);
        ParserState.IsInterfaceSection := False;
      end
      else
        Break;
    until False;
    // Jump to entry point
    if NestedProcsFound then
      GenerateNestedProcsEpilog;
  end;

  procedure CheckUnresolvedDeclarations;
  var
    IdentIndex: Integer;
  begin
    IdentIndex := NumIdent;
    while (IdentIndex > 0) and (Ident[IdentIndex].Block = BlockStack[BlockStackTop].Index) do begin
      if (Ident[IdentIndex].Kind in [GOTOLABEL, PROC, FUNC]) and Ident[IdentIndex].IsUnresolvedForward then
        Error('Unresolved declaration of ' + Ident[IdentIndex].Name);
      Dec(IdentIndex);
    end;
  end;

  procedure DeleteDeclarations;
  begin
    // Delete local identifiers
    while (NumIdent > 0) and (Ident[NumIdent].Block = BlockStack[BlockStackTop].Index) do begin
      // Warn if not used
      if not Ident[NumIdent].IsUsed and not Ident[NumIdent].IsExported and (Ident[NumIdent].Kind = VARIABLE) and (Ident[NumIdent].PassMethod = EMPTYPASSING) then
        Warning('Variable ' + Ident[NumIdent].Name + ' is not used');
      // If procedure or function, delete parameters first
      if Ident[NumIdent].Kind in [PROC, FUNC] then
        DisposeParams(Ident[NumIdent].Signature);
      // Delete identifier itself
      Dec(NumIdent);
    end;
    // Delete local types
    while (NumTypes > 0) and (Types[NumTypes].Block = BlockStack[BlockStackTop].Index) do begin
      // If procedural type, delete parameters first
      if Types[NumTypes].Kind = PROCEDURALTYPE then
        DisposeParams(Types[NumTypes].Signature)
      // If record or interface, delete fields first
      else
        if Types[NumTypes].Kind in [RECORDTYPE, INTERFACETYPE] then
          DisposeFields(Types[NumTypes]);
      // Delete type itself
      Dec(NumTypes);
    end;
  end;

var
  LibProcIdentIndex: Integer;
  TotalParamSize:    Integer;
begin // CompileBlock
  Inc(BlockStackTop);
  with BlockStack[BlockStackTop] do begin
    if BlockIdentIndex = 0 then
      Index := 1
    else
      Index := Ident[BlockIdentIndex].ProcAsBlock;
    LocalDataSize := 0;
    ParamDataSize := 0;
    TempDataSize  := 0;
  end;
  if (ParserState.UnitStatus.Index = 1) and (BlockStack[BlockStackTop].Index = 1) then begin
    DeclarePredefinedTypes;
    DeclarePredefinedIdents;
  end;
  CompileDeclarations;
  if ParserState.IsUnit and (BlockStack[BlockStackTop].Index = 1) then begin
    // Main block of a unit (may contain the implementation part, but not statements)
    CheckUnresolvedDeclarations;
    EatTok(ENDTOK);
  end
  else begin
    // Main block of a program, or a procedure as part of a program/unit
    if BlockStack[BlockStackTop].Index = 1 then
      SetProgramEntryPoint;
    GenerateStackFrameProlog(Ident[BlockIdentIndex].Signature.CallConv <> DEFAULTCONV);
    if BlockStack[BlockStackTop].Index = 1 then          // Main program
    begin
      GenerateFPUInit;
      // Initialize heap and console I/O
      LibProcIdentIndex := GetIdent('INITSYSTEM');
      GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
    end;
    // Block body
    GenerateGotoProlog;
    GenerateExitProlog;
    CompileCompoundStatement(0);
    CheckUnresolvedDeclarations;
    GenerateExitEpilog;                            // Direct all Exit procedure calls here
    GenerateGotoEpilog;
    if ForLoopNesting <> 0 then
      Error('Internal fault: Illegal FOR loop nesting');
    // If function, return Result value (via the EAX register, except some special cases in STDCALL/CDECL functions)
    if (BlockStack[BlockStackTop].Index <> 1) and (Ident[BlockIdentIndex].Kind = FUNC) then begin
      PushVarIdentPtr(Ident[BlockIdentIndex].ResultIdentIndex);
      if Types[Ident[BlockIdentIndex].Signature.ResultType].Kind in StructuredTypes then begin
        if Ident[Ident[BlockIdentIndex].ResultIdentIndex].PassMethod = VARPASSING then
          DerefPtr(POINTERTYPEINDEX);
      end
      else
        DerefPtr(Ident[BlockIdentIndex].Signature.ResultType);
      SaveStackTopToEAX;
      // Return Double in EDX:EAX
      if Types[Ident[BlockIdentIndex].Signature.ResultType].Kind = REALTYPE then
        SaveStackTopToEDX;
      // Treat special cases in STDCALL/CDECL functions
      ConvertResultFromPascalToC(Ident[BlockIdentIndex].Signature);
    end;
    if BlockStack[BlockStackTop].Index = 1 then          // Main program
    begin
      LibProcIdentIndex := GetIdent('EXITPROCESS');
      PushConst(0);
      GenerateCall(Ident[LibProcIdentIndex].Address, 1, 1);
    end;
    GenerateStackFrameEpilog(Align(BlockStack[BlockStackTop].LocalDataSize + BlockStack[BlockStackTop].TempDataSize, SizeOf(Longint)),
      Ident[BlockIdentIndex].Signature.CallConv <> DEFAULTCONV);
    if BlockStack[BlockStackTop].Index <> 1 then  begin
      if Ident[BlockIdentIndex].Signature.CallConv = CDECLCONV then
        TotalParamSize := 0                                           // CDECL implies that the stack is cleared by the caller - no need to do it here
      else
        TotalParamSize := GetTotalParamSize(Ident[BlockIdentIndex].Signature, Ident[BlockIdentIndex].ReceiverType <> 0, False);
      GenerateReturn(TotalParamSize, Ident[BlockIdentIndex].NestingLevel);
    end;
    DeleteDeclarations;
  end;
  Dec(BlockStackTop);
end;

procedure CompileUsesClause;
var
  SavedParserState: TParserState;
  UnitIndex:        Integer;
begin
  NextTok;
  repeat
    AssertIdent;
    UnitIndex := GetUnitUnsafe(Tok.Name);
    // If unit is not found, compile it now
    if UnitIndex = 0 then begin
      SavedParserState := ParserState;
      if not SaveScanner then
        Error('Unit nesting is too deep');
      UnitIndex   := Compile(Tok.Name + '.pas');
      ParserState := SavedParserState;
      if not RestoreScanner then
        Error('Internal fault: Scanner state cannot be restored');
    end;
    ParserState.UnitStatus.UsedUnits := ParserState.UnitStatus.UsedUnits + [UnitIndex];
    SetUnitStatus(ParserState.UnitStatus);
    NextTok;
    if Tok.Kind <> COMMATOK then
      Break;
    NextTok;
  until False;
  EatTok(SEMICOLONTOK);
end;

function Compile(const Name: TString): Integer;
begin
  InitializeScanner(Name);
  Inc(NumUnits);
  if NumUnits > MAXUNITS then
    Error('Maximum number of units exceeded');
  ParserState.UnitStatus.Index := NumUnits;
  NextTok;
  ParserState.IsUnit := False;
  if Tok.Kind in [PROGRAMTOK, UNITTOK] then begin
    ParserState.IsUnit := Tok.Kind = UNITTOK;
    NextTok;
    AssertIdent;
    Units[ParserState.UnitStatus.Index].Name := Tok.Name;
    NextTok;
    EatTok(SEMICOLONTOK);
  end
  else
    Units[ParserState.UnitStatus.Index].Name := 'MAIN';
  ParserState.IsInterfaceSection := False;
  if ParserState.IsUnit then begin
    EatTok(INTERFACETOK);
    ParserState.IsInterfaceSection := True;
  end;
  // Always use System unit, except when compiling System unit itself
  if NumUnits > 1 then
    ParserState.UnitStatus.UsedUnits := [1]
  else
    ParserState.UnitStatus.UsedUnits := [];
  SetUnitStatus(ParserState.UnitStatus);
  if Tok.Kind = USESTOK then
    CompileUsesClause;
  Notice('Compiling ' + Name);
  NumBlocks := 1;
  CompileBlock(0);
  CheckTok(PERIODTOK);
  Result := ParserState.UnitStatus.Index;
  FinalizeScanner;
end;

end.