{

                          MODULE 11
 
 
                       Program Analysis
 
 
 
 
 
 As indicated in Modules 9 and 10, program analysis is  implemented
 by  a recursive-descent parser enriched  with semantic interludes.
 It is carried out therefore by a procedure Programme  whose  logic
 is  derived directly from the syntax and semantic rules of the ISO
 and ICL defining documents. The principal aspects of this analysis
 are explained in the comments introducing corresponding sections.

                                                                     }

program Analyser;

#include "globals.x"
#include "source.pf"
#include "interface.pf"
#include "lexical.pf"
#include "syntax.pf"
#include "diags.pf"
#include "semantics.pf"
#include "statstore.pf"
#include "progparams.pf"
#include "varref.pf"
#include "stdprocs.pf"
#include "ctlstructs.pf"
#include "objvalues.pf"
#include "datareps.pf"
#include "expeval.pf"
#include "withstmts.pf"
#include "assgncode.pf"
#include "pfcalls.pf"

procedure Programme;
  visible;

  var
    ProgId: IdEntry;
    ProgParams: record First, Last: ProgPmEntry end;
    EntryLabel: BlockLabel;
    Externals: IdList;
    WasExpression: Boolean;

{

 11.1  Program-heading analysis.
 
 For consistency  in  block  handling  the  program  identifier  is
 represented  by  an identry Progid, which is not part of any scope
 created during program analysis.
 
 Program parameters are optional, and  unrestricted  in  number  or
 type.   Each  parameter  is appended as an item of the list  Prog-
 Params,  and  duplicate  items  are reported  as  errors.   Subse-
 quently,   the  list is used during variable-declaration analysis,
 to bind program parameters  onto  matching  variable  identifiers.
 Analysis of the  ProgParams  list  is continued by  procedure Ver-
 ifyProgParams, when the variable declaration part  has  been  com-
 pletely  processed.  Parameters that  remain  unbound are reported
 as errors and a consolidated list Externals of the variables bound
 is  created.  This is then used for any program parameter process-
 ing necessary at program entry and exit.

                                                                     }

  procedure MakeProgEntry;

    var
      IdName: Alfa;
      EntryLabel: BlockLabel;

    begin
      new(ProgId, Prog);
      with ProgId^ do
        begin
          CopySpelling(IdName);
          Name := IdName;
          Klass := Prog;
          FutureBlockLabel(EntryLabel);
          ProgBody := EntryLabel
        end;
      ISerialise(ProgId)
    end;

  procedure InitParams;

    begin
      with ProgParams do
        begin
          First := nil;
          Last := nil
        end
    end { initparams };

  procedure Append(ThisParam: ProgPmEntry);

    begin
      with ProgParams do
        begin
          if First = nil
          then First := ThisParam else Last^.NextParam := ThisParam;
          Last := ThisParam
        end
    end { append };

  procedure SearchProgParams(Name: Alfa; var TheParam: ProgPmEntry);

    var Found: Boolean;

    begin
      TheParam := ProgParams.First;
      Found := false;
      while (TheParam <> nil) and not Found do
        if SameAlfa(TheParam^.Name, Name)
        then Found := true else TheParam := TheParam^.NextParam
    end { searchprogparams };

  procedure NewProgParam;

    var
      ThisParam: ProgPmEntry;
      NewPmName: Alfa;

    begin
      CopySpelling(NewPmName);
      SearchProgParams(NewPmName, ThisParam);
      if ThisParam <> nil
      then SemanticError(230)
      else
        begin
          new(ThisParam);
          with ThisParam^ do
            begin
              Name := NewPmName;
              Declaration := StartOfSymbol;
              if Name.Head = 'INPUT       '
              then
                begin
                  Spelling := Name;
                  NewId(InputFile, Vars);
                  ISerialise(InputFile);
                  InputFile^.IdType := TextType;
                  SetAddressFor(InputFile);
                  ParamId := InputFile
                end
              else
                if Name.Head = 'OUTPUT      '
                then
                  begin
                    Spelling := Name;
                    NewId(OutputFile, Vars);
                    ISerialise(OutputFile);
                    OutputFile^.IdType := TextType;
                    SetAddressFor(OutputFile);
                    ParamId := OutputFile
                  end
                else ParamId := nil;
              NextParam := nil
            end;
          Append(ThisParam)
        end
    end { newprogparam };

  procedure VerifyProgParams;

    var Entry: ProgPmEntry;

    begin
      Entry := ProgParams.First;
      while Entry <> nil do
        begin
          with Entry^ do
            if ParamId = nil
            then
              begin
                Error(231, Declaration);
                ParamId := DummyVarId
              end
            else AppendId(Externals, ParamId);
          Entry := Entry^.NextParam
        end;

    end { verifyprogparams };

  procedure AcceptParameter(ParamId: IdEntry);

    begin
      AcceptProgParameter(ParamId);
      if ParamId = InputFile
      then
        begin
          StackReference(false, InputFile^.VarAddress);
          SelectFile(TextType);
          FileOperation(Resetp, Standard);
          DiscardFile
        end;
      if ParamId = OutputFile
      then
        begin
          StackReference(false, OutputFile^.VarAddress);
          SelectFile(TextType);
          FileOperation(Rewritep, Standard);
          DiscardFile
        end
    end { acceptparameter };

  procedure ProgramHeading;

    begin { programheading }
      CheckContext([ProgramSy] + BlockBegSys + StatBegSys);
      Accept(ProgramSy);
      if Symbol <> Ident then MakeSpelling('PASCAL      ');
      MakeProgEntry;
      Accept(Ident);
      InputFile := nil;
      OutputFile := nil;
      InitParams;
      if Symbol = LeftParent
      then
        begin
          repeat
            AcceptSymbol;
            if Symbol = Ident then NewProgParam;
            Accept(Ident);
            CheckNextOrContext
              ([Comma, RightParent], [Semicolon] + BlockBegSys)
          until Symbol <> Comma;
          Accept(RightParent)
        end
    end { programheading };

{

 11.2 Block Analysis
 
 Block analysis is carried out by procedure  Block,  which  assumes
 that  a  (program,  procedure  or  function)  identifier entry has
 already been created for the block, and that a scope  has  already
 been opened.
 
 Syntax error recovery at block level  is  nonstandard  in  that  a
 block is judged complete only when an 'end' symbol followed by the
 specified BlockFollower symbol (';' or '.') is detected.

                                                                     }

  procedure Block(BlockFollower: SymbolType; BlockIdEntry: IdEntry);

    type
      DListEntry = ^Domains;
      Domains = record
                  Declaration: TextPosition;
                  DomainId: IdEntry;
                  PointerType: TypEntry;
                  NextDomain: DListEntry
                end;

    var
      BlockContext: SetOfSymbols;
      DomainList: DListEntry;
      AllTypesDefined: Boolean;
      FinalPart: StatementLabel;
      ReadableVars, WriteableVars: SetOfIdClass;

    procedure PresetBlock;

      begin
        with BlockIdEntry^ do
          begin
            InitializeVariables;
            if Klass = Prog
            then
              begin
                OpenProgParameterList;
                ForAll(Externals, AcceptParameter);
                ClsProgParameterList
              end
          end
      end { presetblock };

    procedure PostSetBlock;

      begin
        NextIsStatementLabel(FinalPart);
        with BlockIdEntry^ do
          begin
            FinalizeVariables;
            if Klass = Prog
            then
              begin
                OpenProgParameterList;
                ForAll(Externals, ReturnProgParameter);
                ClsProgParameterList
              end
          end
      end { postsetblock };

{

 11.3  Label-declaration analysis.
 
 Labels  are  distinguished   by  their  apparent  integral  values
 which  must  belong to the closed interval 0..9999.  Semantic pro-
 cessing for labels has already been described in module 10,  para-
 graph 6.

                                                                     }

    procedure LabelDeclarationPart;

      begin { labeldeclarationpart }
        repeat
          AcceptSymbol;
          if Symbol = IntConst
          then
            begin
              NewLabel;
              with Constant do
                if OrderedValues(Velue, MinLabValue) or
                   OrderedValues(MaxLabValue, Velue)
                then SemanticError(137)
            end;
          Accept(IntConst);
          CheckContext([Comma, Semicolon] + BlockContext)
        until Symbol <> Comma;
        Accept(Semicolon);
        CheckContext(BlockContext)
      end { labeldeclarationpart };

{

 11.4  Constant definition analysis.
 
 Constant definition analysis involves two major procedures:
 
 (i)  UnsignedConstant, which  analyses  constant  denotations  and
      extracts their type and value;
 
 (ii) ConstExpression,  which  performs  syntactic   and   semantic
      analysis  and  compile-time  evluation of expressions of con-
      stant operands;
 
 (ii) ConstDefinitionPart, which analyses a  sequence  of  constant
      definitions,  creating IdEntries for each constant identifier
      so defined.
 
 Correct identifier usage is enforced by delaying the  creation  of
 each  constant  identifier entry until its constant denotation has
 been analysed, leaving the last-use mechanism to  reject  constant
 identifiers whose definition makes use of a nonlocal definition of
 the same identifier.

                                                                     }

    procedure UnsignedConstant(Context: SetOfSymbols;
                               var ConsType: TypEntry;
                               var ConstValue: ObjectValue);

      var IdConst: IdEntry;

      begin { UnsignedConstant }
        ConsType := Unknown;
        ConstValue := DftValue;
        CheckNextOrContext(ConstBegSys, Context);
        if Symbol in ConstBegSys
        then
          begin
            case Symbol of
              CharConst :
                begin
                  ConsType := CharType;
                  ConstValue := Constant.Velue
                end;
              StringConst :
                begin
                  StringType(ConsType);
                  ConstValue := Constant.Velue
                end;
              Ident :
                begin
                  SearchId([Consts], IdConst);
                  with IdConst^ do
                    begin
                      ConsType := IdType;
                      ConstValue := Values
                    end
                end;
              IntConst :
                begin
                  ConsType := IntType;
                  ConstValue := Constant.Velue
                end;
              RealConst :
                begin
                  ConsType := RealType;
                  ConstValue := Constant.Velue
                end;
              BasedConst :
                begin
                  ConsType := WordType;
                  ConstValue := Constant.Velue
                end
            end;
            AcceptSymbol;
            CheckContext(Context)
          end
      end { UnsignedConstant };

    procedure VariableOrType(Context: SetOfSymbols);
      forward;

    procedure ConstExpression(ExpContext: SetOfSymbols;
                              var ExpType: TypEntry;
                              var ExpValue: ObjectValue);

      var
        LeftType: TypEntry;
        RValue: ObjectValue;
        RelOperator: OpType;

      procedure SimpleConstExpression(SimpleExpContext: SetOfSymbols;
                                      var LValue: ObjectValue);

        var
          LeftType: TypEntry;
          RValue: ObjectValue;
          Sign, AddOperator: OpType;
          Signed: Boolean;
          Followers: SetOfSymbols;

        procedure ConstPlusMinusMul(FirstOpType: TypEntry;
                                    var ExpValue: ObjectValue;
                                    RValue: ObjectValue;
                                    Operator: OpType);

          { semantic analysis of operators +,-, and * }
          { assuming operand types are given by       }
          { firstoptype and exptype respectively, and }
          { resetting exptype to describe the result  }

          begin
            if (Compatible(FirstOpType, IntType) and
                Compatible(ExpType, IntType))
            then
              begin
                ExpType := IntType;
                case Operator of
                  Mul : MultiplyValues(ExpValue, RValue, ExpValue);
                  Plus : AddValues(ExpValue, RValue, ExpValue);
                  Minus : SubValues(ExpValue, RValue, ExpValue)
                end
              end
            else
              if (Compatible(FirstOpType, WordType) and
                  Compatible(ExpType, WordType))
              then
                begin
                  ExpType := WordType;
                  case Operator of
                    Mul : SemanticError(204);
                    Plus : AddValues(ExpValue, RValue, ExpValue);
                    Minus : SubValues(ExpValue, RValue, ExpValue)
                  end
                end
              else
                begin
                  if Compatible(FirstOpType, IntType)
                  then
                    begin
                      FirstOpType := RealType;
                      ConstRealFn(Floatf, ExpValue, ExpValue)
                    end;
                  if Compatible(ExpType, IntType)
                  then
                    begin
                      ExpType := RealType;
                      ConstRealFn(Floatf, RValue, RValue)
                    end;
                  if not (Compatible(FirstOpType, RealType) and
                          Compatible(ExpType, RealType))
                  then
                    begin
                      SemanticError(190);
                      ExpType := IntType
                    end
                  else
                    begin
                      case Operator of
                        Mul : MultiplyValues(ExpValue, RValue, ExpValue);
                        Plus : AddValues(ExpValue, RValue, ExpValue);
                        Minus : SubValues(ExpValue, RValue, ExpValue)
                      end;
                      ExpType := RealType
                    end
                end
          end { ConstPlusMinusMul };

        procedure ConstTerm(TermContext: SetOfSymbols;
                            var LValue: ObjectValue);

          var
            LeftType: TypEntry;
            RValue: ObjectValue;
            MulOperator: OpType;
            Followers: SetOfSymbols;

          procedure ConstFactor(FactorContext: SetOfSymbols;
                                var LValue: ObjectValue);

            var MinValue, MaxValue: ObjectValue;
                RecastType: TypEntry;
                FactorClasses: SetOfIdClass;
                Starters: SetOfSymbols;
                FirstId: IdEntry;

            procedure FunctionCall(FnContext: SetOfSymbols;
                                   FnId: IdEntry);

              var WhichFn: StdProcFuncs;
                  ArgType: TypEntry;
                  ArgValue, WordValue: ObjectValue;

              begin
                WhichFn := FnId^.PfIndex;
                if (WhichFn >= Absf) and (WhichFn <= Arctanf)
                then
                  begin
                    Accept(LeftParent);
                    ConstExpression([RightParent] + FnContext,
                                    ArgType, ArgValue);
                    case WhichFn of
                      Absf, Sqrf :
                        if Compatible(ArgType, IntType)
                        then ConstIntFn(WhichFn, ArgValue, LValue)
                        else
                          if Compatible(ArgType, RealType)
                          then ConstRealFn(WhichFn, ArgValue, LValue)
                          else
                            begin
                              SemanticError(109);
                              ExpType := IntType
                            end;
                      Oddf :
                        begin
                          if not (Compatible(ArgType, IntType) or
                                  Compatible(ArgType, WordType))
                          then SemanticError(107)
                          else ConstIntFn(Oddf, ArgValue, LValue);
                          ExpType := BoolType
                        end;
                      Succf, Predf :
                        begin
                          EnsureOrdinal(ArgType);
                          ConstIntFn(WhichFn, ArgValue, LValue);
                          GetBounds(ArgType, MinValue, MaxValue);
                          if WhichFn = Succf
                          then
                            CheckValue(MinValue, MaxValue, LValue, 38)
                          else
                            CheckValue(MinValue, MaxValue, LValue, 39);
                          ExpType := ArgType
                        end;
                      Ordf :
                        begin
                          EnsureOrdinal(ArgType);
                          ConstIntFn(Ordf, ArgValue, LValue);
                          ExpType := IntType
                        end;
                      Chrf :
                        begin
                          if not (Compatible(ArgType, IntType) or
                                  Compatible(ArgType, WordType))
                          then SemanticError(107)
                          else ConstIntFn(Chrf, ArgValue, LValue);
                          CheckValue(MinCharValue, MaxCharValue, LValue, 37);
                          ExpType := CharType
                        end;
                      Truncf, Roundf :
                        begin
                          if not Compatible(ArgType, RealType)
                          then SemanticError(108)
                          else ConstRealFn(WhichFn, ArgValue, LValue);
                          ExpType := IntType
                        end;
                      Sinf, Cosf, Expf, Lnf, Sqrtf, Arctanf :
                        begin
                          if Compatible(ArgType, IntType)
                          then
                            begin
                              ConstRealFn(Floatf, ArgValue, ArgValue);
                              ArgType := RealType
                            end;
                          if not Compatible(ArgType, RealType)
                          then SemanticError(109)
                          else ConstRealFn(WhichFn, ArgValue, LValue);
                          ExpType := RealType
                        end
                    end;
                    Accept(RightParent)
                  end
                else
                  if (WhichFn >= Wrdf) and (WhichFn <= RotWf)
                  then
                    begin
                      Accept(LeftParent);
                      case WhichFn of
                        MinValf, MaxValf :
                          begin
                            VariableOrType([RightParent] + FnContext);
                            EnsureOrdinal(VarType);
                            GetBounds(VarType, MinValue, MaxValue);
                            if WhichFn = MinValf
                            then LValue := MinValue
                            else LValue := MaxValue;
                            ExpType := VarType
                          end;
                        Wrdf :
                          begin
                            ConstExpression
                              ([RightParent] + FnContext, ArgType, ArgValue);
                            EnsureOrdinal(ArgType);
                            ConstIntFn(Wrdf, ArgValue, LValue);
                            ExpType := WordType
                          end;
                        Intf :
                          begin
                            ConstExpression
                              ([RightParent] + FnContext, ArgType, ArgValue);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105)
                            else ConstIntFn(Intf, ArgValue, LValue);
                            ExpType := IntType
                          end;
                        AndWf, OrWf, NeqWf :
                          begin
                            ConstExpression
                              ([RightParent, Comma] + FnContext, ArgType,
                                 ArgValue);
                            if not Compatible(ArgType, WordType)
                            then SemanticError(105)
                            else WordValue := ArgValue;
                            Accept(Comma);
                            ConstExpression
                              ([RightParent] + FnContext, ArgType, ArgValue);
                            if not Compatible(ArgType, WordType)
                            then SemanticError(105)
                            else
                              ConstWrdFn
                                (WhichFn, WordValue, ArgValue, LValue);
                            ExpType := WordType
                          end;
                        NotWf :
                          begin
                            ConstExpression
                              ([RightParent] + FnContext, ArgType, ArgValue);
                            if not Compatible(ArgType, WordType)
                            then SemanticError(105)
                            else
                              ConstWrdFn(NotWf, ArgValue, ArgValue, LValue);
                            ExpType := WordType
                          end;
                        ShWf, RotWf :
                          begin
                            ConstExpression
                              ([Comma, RightParent] + FnContext, ArgType,
                                 ArgValue);
                            if not Compatible(ArgType, WordType)
                            then SemanticError(105)
                            else WordValue := ArgValue;
                            Accept(Comma);
                            ConstExpression
                              ([RightParent] + FnContext, ArgType, ArgValue);
                            if not Compatible(ArgType, IntType)
                            then SemanticError(107)
                            else
                              ConstWrdFn
                                (WhichFn, WordValue, ArgValue, LValue);
                            ExpType := WordType
                          end
                      end;
                      Accept(RightParent)
                    end
                  else SemanticError(119);
              CheckContext(FnContext)
            end { FunctionCall };

            begin { constfactor }
              ExpType := Unknown;
              LValue := DftValue;
              if ICLPascal
              then Starters := ConstFacBegSys else Starters := ConstBegSys;
              CheckNextOrContext(Starters, FactorContext);
              if Symbol in Starters
              then
                begin
                  case Symbol of
                    Ident :
                      begin
                        FactorClasses := [Consts];
                        if ICLPascal
                        then FactorClasses := FactorClasses + [Func, Types];
                        SearchId(FactorClasses, FirstId);
                        AcceptSymbol;
                        case FirstId^.Klass of
                          Consts :
                            with FirstId^ do
                              begin
                                ExpType := IdType;
                                LValue := Values
                              end;
                          Func : FunctionCall(FactorContext, FirstId);
                          Types :
                            begin
                              RecastType := FirstId^.IdType;
                              EnsureEnumerated(RecastType);
                              Accept(LeftParent);
                              ConstExpression
                                ([RightParent] + FactorContext,
                                  ExpType, LValue);
                              EnsureOrdinal(ExpType);
                              Accept(RightParent);
                              GetBounds(RecastType, MinValue, MaxValue);
                              CheckValue(MinValue, MaxValue, LValue, 81);
                              ExpType := RecastType
                            end
                        end
                      end;
                    LeftParent :
                      begin
                        AcceptSymbol;
                        ConstExpression
                          ([RightParent] + FactorContext, ExpType,
                           LValue);
                        Accept(RightParent)
                      end;
                    NotSy :
                      begin
                        AcceptSymbol;
                        ConstFactor(FactorContext, LValue);
                        if not Compatible(ExpType, BoolType)
                        then SemanticError(106)
                        else NotValues(LValue, DftValue, LValue);
                        ExpType := BoolType
                      end;
                    IntConst, RealConst, CharConst,
                    StringConst, BasedConst:
                      UnsignedConstant(FactorContext, ExpType, LValue)
                  end;
                  CheckContext(FactorContext)
                end
            end { constfactor };

          begin { constterm }
            if ICLPascal
            then Followers := TermContext
            else Followers := [MulOp] + ConstFacBegSys + TermContext;
            ConstFactor(Followers, LValue);
            while (Symbol = MulOp) or (Symbol in ConstFacBegSys) do
              begin
                WasExpression := true;
                LeftType := ExpType;
                if Symbol = MulOp
                then MulOperator := Operator else MulOperator := NotOp;
                Accept(MulOp);
                ConstFactor
                  ([MulOp] + ConstFacBegSys + TermContext, RValue);
                case MulOperator of
                  Mul :
                    ConstPlusMinusMul(LeftType, LValue, RValue, Mul);
                  RDiv :
                    begin
                      if Compatible(LeftType, IntType)
                      then
                        begin
                          ConstRealFn(Floatf, LValue, LValue);
                          LeftType := RealType
                        end;
                      if Compatible(ExpType, IntType)
                      then
                        begin
                          ConstRealFn(Floatf, RValue, RValue);
                          ExpType := RealType
                        end;
                      if not (Compatible(LeftType, RealType) and
                              Compatible(ExpType, RealType))
                      then SemanticError(193)
                      else DivValues(LValue, RValue, LValue);
                      ExpType := RealType
                    end;
                  IDiv, IMod :
                    begin
                      if not (Compatible(LeftType, IntType) and
                              Compatible(ExpType, IntType))
                      then SemanticError(194)
                      else
                        if MulOperator = IDiv
                        then DivValues(LValue, RValue, LValue)
                        else ModValues(LValue, RValue, LValue);
                      ExpType := IntType
                    end;
                  AndOp :
                    begin
                      if not (Compatible(LeftType, BoolType) and
                              Compatible(ExpType, BoolType))
                      then SemanticError(195)
                      else AndValues(LValue, RValue, LValue);
                      ExpType := BoolType
                    end;
                  NotOp : ExpType := Unknown
                end { case }
              end;

          end { constterm };

        begin { simple expression }
          if ICLPascal
          then
            begin
              Signed := ((Symbol = AddOp) and (Operator in [Plus, Minus]));
              if Signed
              then
                begin
                  Sign := Operator;
                  AcceptSymbol
                end;
              Followers := [AddOp] + SimpleExpContext
            end
          else
            begin
              Signed := false;
              Followers := SimpleExpContext
            end;
          ConstTerm(Followers, LValue);
          if Signed
          then
            if Compatible(ExpType, IntType) or
               Compatible(ExpType, RealType)
            then
              begin
                if Sign = Minus then NegateValue(LValue)
              end
            else
              begin
                SemanticError(196);
                ExpType := Unknown
              end;
          while Symbol = AddOp do
            begin
              WasExpression := true;
              LeftType := ExpType;
              AddOperator := Operator;
              AcceptSymbol;
              ConstTerm([AddOp] + SimpleExpContext, RValue);
              case AddOperator of
                Plus, Minus :
                  ConstPlusMinusMul
                    (LeftType, LValue, RValue, AddOperator);
                OrOp :
                  begin
                    if not (Compatible(LeftType, BoolType) and
                            Compatible(ExpType, BoolType))
                    then SemanticError(195)
                    else OrValues(LValue, RValue, LValue);
                    ExpType := BoolType
                  end
              end { case }
            end
        end { simple expression };

      begin { ConstExpression }
        WasExpression := false;
        SimpleConstExpression([RelOp] + ExpContext, ExpValue);
        if (Symbol = RelOp) and ICLPascal
        then
          begin
            WasExpression := true;
            LeftType := ExpType;
            RelOperator := Operator;
            if RelOperator = InOp then SemanticError(203);
            AcceptSymbol;
            SimpleConstExpression(ExpContext, RValue);
            if not Compatible(LeftType, ExpType)
            then

              { could be real/integer mix }
              if Compatible(LeftType, IntType)
              then
                begin
                  ConstRealFn(Floatf, ExpValue, ExpValue);
                  LeftType := RealType
                end
              else
                if Compatible(ExpType, IntType)
                then
                  begin
                    ConstRealFn(Floatf, RValue, RValue);
                    ExpType := RealType
                  end;
              if Compatible(LeftType, ExpType)
              then
                case LeftType^.Form of
                  Scalars, Subranges:
                    CompareValues(ExpValue, RValue, RelOperator);
                  Arrays :
                    if not String(LeftType)
                    then SemanticError(201)
                    else CompareValues(ExpValue, RValue, RelOperator);
                  Pointers, Sets, CAPSchema, Records, Files:
                    SemanticError(204)
                end
              else SemanticError(198);
            ExpType := BoolType
          end
      end { ConstExpression };

  procedure Expression(ExpContext: SetOfSymbols);
    forward;

  procedure PragmaList(Context: SetOfSymbols);

    procedure ProcessPragma(Context: SetOfSymbols);

      var
        Applicable: Boolean;
        PragmaSpelling: Alfa;

      procedure CheckDenoter;

        var
          DenoterSpelling: Alfa;
          i: AlfaIndex;

        begin
          if Constant.Length > 8
          then PragmaticError(1)
          else
            begin
              InitAlfa(DenoterSpelling);
              for i := 1 to Constant.Length do
                DenoterSpelling.Head[i] := Constant.String[i];
              if not SameAlfa(SystemSpelling, DenoterSpelling)
              then PragmaticError(2)
              else Applicable := true
            end
        end { CheckDenoter };

      procedure PragmaParameters;

        var
          ParamType: TypEntry;
          ParamValue: ObjectValue;

        begin
          repeat
            AcceptSymbol;
            Expression(Context + [Comma, RightParent] - [PragmaSy])
          until Symbol <> Comma;
          Accept(RightParent)
        end { PragmaParameters };

      begin { ProcessPragma }
        Applicable := false;
        if Symbol = StringConst
        then
          begin
            CheckDenoter;
            AcceptSymbol
          end;
        if Symbol = Ident then CopySpelling(PragmaSpelling);
        Accept(Ident);
        if Symbol = LeftParent then PragmaParameters;
        CheckContext(Context)
      end { ProcessPragma };

    begin
      repeat
        AcceptSymbol;
        ProcessPragma(Context + [Semicolon, PragmaSy]);
        Accept(Semicolon)
      until Symbol <> PragmaSy;
      CheckContext(Context)
    end { PragmaList };


    procedure ConstDefinitionPart;

      var
        ConstName: Alfa;
        ConstId: IdEntry;
        ConsType: TypEntry;
        ConstValue: ObjectValue;

      begin { constdefinitionpart }
        AcceptSymbol;
        CheckNextOrContext([Ident], BlockContext);
        while Symbol = Ident do
          begin
            CopySpelling(ConstName);
            AcceptSymbol;
            AcceptEquals;
            ConstExpression
              ([Semicolon, PragmaSy] + BlockContext, ConsType, ConstValue);
            RestoreSpelling(ConstName);
            NewId(ConstId, Consts);
            ConstId^.IdType := ConsType;
            ConstId^.Values := ConstValue;
            Accept(Semicolon);
            if Symbol = PragmaSy
            then PragmaList([Ident] + BlockContext);
            CheckContext([Ident] + BlockContext)
          end
      end { constdefinitionpart };

{

 11.5  Type definition analysis.
 
 Type definition analysis involves two major procedures:
 
 (i)  TypeDenoter, which analyses any type  denotation,  creates  a
      new  type  record  to describe it if necessary, and returns a
      TypEntry pointing to its description;
 
 (ii) TypeDefinitionPart, which analyses a sequence of type defini-
      tions,   creating  IdEntries  for  each  type  identifier  so
      defined.
 
 Correct identifier usage is again enforced by delaying  the  crea-
 tion  of  the  type identifier entry until its type denotation has
 been analysed,  but  correct  handling  of  pointer  domains  also
 requires  use  of a domain list to remember unbound pointer types,
 interim domain IdEntries,  the  procedures  BindDomain  and  Sear-
 chDomain  from section 9.4, and a variable AllTypesDefined to dis-
 tinguish between type definition  and  variable  declaration  con-
 texts.

                                                                     }

    procedure NewSubType(var TheType: TypEntry);

      var
        IdFound: IdEntry;
        TypeFound: TypEntry;

      begin
        AcceptSymbol;
        if Symbol = Ident
        then
          begin
            SearchId([Types], IdFound);
            TypeFound := IdFound^.IdType;
            if Ordinal(TheType) then EnsureOrdinal(TypeFound);
            TheType^.Occupying := IdFound^.IdType;
            AdjustRepresentationFor(TheType)
          end;
        Accept(Ident)
      end { newsubtype };

    procedure TypeDenoter(Context: SetOfSymbols;
                          var TypeFound: TypEntry);

      var IdFound: IdEntry;

      procedure OrdinalType(Context: SetOfSymbols;
                            var OrdTypEntry: TypEntry);

        var
          NewTypEntry: TypEntry;
          FirstIdEntry: IdEntry;

        procedure EnumeratedType;

          var
            LastId: IdEntry;
            NextValue: ValueDetails;

          procedure NewConstId;

            var ThisId: IdEntry;

            begin
              if Symbol = Ident
              then
                begin
                  NewId(ThisId, Consts);
                  ISerialise(ThisId);
                  with ThisId^ do
                    begin
                      IdType := NewTypEntry;
                      Evaluate(NextValue);
                      Values := NextValue.Velue;
                      NextValue.IVal := NextValue.IVal + 1;
                      SuccId := nil
                    end;
                  if LastId = nil
                  then NewTypEntry^.FirstConst := ThisId
                  else LastId^.SuccId := ThisId;
                  LastId := ThisId
                end;
              Accept(Ident)
            end;

          begin { enumeratedtype }
            NewType(NewTypEntry, Scalars);
            LastId := nil;
            with NextValue do
              begin
                Kind := OrdValue;
                IVal := 0
              end;
            repeat
              AcceptSymbol;
              NewConstId;
              CheckContext(Context + [Comma, RightParent])
            until Symbol <> Comma;
            SetRepresentationFor(NewTypEntry);
            Accept(RightParent)
          end { enumeratedtype };

        procedure SubrangeType;

          var
            FirsType, SecondType: TypEntry;
            FirstValue, SecondValue: ObjectValue;

          begin { subrangetype }
            ConstExpression(Context + [Thru], FirsType, FirstValue);
            EnsureOrdinal(FirsType);
            Accept(Thru);
            ConstExpression(Context, SecondType, SecondValue);
            EnsureOrdinal(SecondType);
            NewType(NewTypEntry, Subranges);
            if (FirsType <> Unknown) and (SecondType <> Unknown)
            then
              with NewTypEntry^ do
                begin
                  Min := FirstValue;
                  Max := SecondValue;
                  if not Compatible(FirsType, SecondType)
                  then SemanticError(122)
                  else
                    if FirsType <> Unknown
                    then
                      begin
                        RangeType := FirsType;
                        if SecondType <> Unknown
                        then
                          if OrderedValues(Max, Min)
                          then SemanticError(123)
                      end
                    else RangeType := SecondType
                end;
            SetRepresentationFor(NewTypEntry)
          end { subrangetype };

        begin { ordinaltype }
          CheckNextOrContext(SimpTypeBegSys, Context);
          if Symbol in SimpTypeBegSys
          then
            begin
              if Symbol = LeftParent
              then EnumeratedType
              else
                if Symbol = Ident
                then
                  begin
                    SearchId([Domain, Types, Consts], FirstIdEntry);
                    with FirstIdEntry^ do
                      if Klass = Consts
                      then SubrangeType
                      else
                        begin
                          AcceptSymbol;
                          NewTypEntry := IdType;
                          EnsureOrdinal(NewTypEntry)
                        end
                  end
                else SubrangeType;
              OrdTypEntry := NewTypEntry;
              CheckContext(Context)
            end
          else OrdTypEntry := Unknown;
          SetRepresentationFor(OrdTypEntry)
        end { ordinaltype };

      procedure StructuredType;

        var PackFlag: Boolean;

        procedure ArrayType;

          label 9;

          var
            ElementType, IndexType, Dimension, LastDimension: TypEntry;

          procedure NewDimension;

            begin
              OrdinalType
                (Context + [Comma, RightBracket, OfSy], IndexType);
              NewType(Dimension, Arrays);
              with Dimension^ do
                begin
                  PackedArray := PackFlag;
                  InxType := IndexType;

                  { dimensions are temporarily back-chained }
                  { thru their aeltype fields               }

                  AelType := LastDimension
                end;
              LastDimension := Dimension
            end;

          begin { arraytype }
            AcceptSymbol;
            Accept(LeftBracket);
            LastDimension := nil;
            while true do
              begin
                NewDimension;
                if Symbol <> Comma then goto 9;
                AcceptSymbol
              end;
            9 : ;
            Accept(RightBracket);
            Accept(OfSy);
            TypeDenoter(Context, ElementType);

            { now reverse chaining and set }
            { representation at each level }

            repeat
              LastDimension := Dimension^.AelType;
              Dimension^.AelType := ElementType;
              SetRepresentationFor(Dimension);
              ElementType := Dimension;
              Dimension := LastDimension
            until Dimension = nil;
            TypeFound := ElementType
          end { arraytype };

        procedure RecordType;

          var
            LVarPart: TypEntry;
            LFixedPart: IdEntry;
            LFiles: Boolean;

          procedure FieldList(Context: SetOfSymbols;
                              var FixedPart: IdEntry;
                              var VarPart: TypEntry;
                              var AnyFiles: Boolean);

            { Although called fieldlist, this procedure }
            { actually accepts constructs of the form   }
            {      [ field-list [ ";" ] ]               }
            { which is the only context in which a      }
            { field-list can occur.                     }

            label 9, 19;

            var
              LastField, TagField, TagTypeId, FirstSubField: IdEntry;
              FieldsOfOneType: IdList;
              FirstName, TypeName: Alfa;
              FieldType, TagType, ThisVariant, LastVariant,
              LastDistinctVariant, SubVariantPart:
                TypEntry;
              VariantFiles, MultipleLabels, StillDistinct: Boolean;
              TagMin, TagMax: ObjectValue;
              Selections: ValueDetails;
              LabelCount: integer;

            procedure NewFieldId;

              var ThisField: IdEntry;

              begin
                if Symbol = Ident
                then
                  begin
                    NewId(ThisField, Field);
                    ISerialise(ThisField);
                    AppendId(FieldsOfOneType, ThisField)
                  end;
                Accept(Ident)
              end;

            procedure FixFieldId(ThisField: IdEntry);

              begin
                ThisField^.IdType := FieldType;
                if LastField = nil
                then FixedPart := ThisField
                else LastField^.NextField := ThisField;
                LastField := ThisField
              end;

            procedure NewVariantLabel;

              var
                LabelType: TypEntry;
                FirstValue, SecondValue,LabelValue: ObjectValue;
                Followers: SetOfSymbols;

              function ValidLabel: Boolean;

                begin
                  ValidLabel := false;
                  if not Compatible(TagType, LabelType)
                  then SemanticError(124)
                  else
                    if OrderedValues(LabelValue, TagMin) or
                       OrderedValues(TagMax, LabelValue)
                    then SemanticError(125)
                    else ValidLabel := true
                end { ValidLabel };

              begin
                FirstValue := DftValue;
                SecondValue := DftValue;
                Followers := [Comma, Colon, LeftParent];
                if ICLPascal then Followers := Followers + [Thru];
                ConstExpression
                  (Followers + Context, LabelType, LabelValue);
                  if ValidLabel
                  then
                    begin
                      FirstValue := LabelValue;
                      SecondValue := LabelValue;
                      if Symbol = Thru
                      then
                        begin
                          AcceptSymbol;
                          ConstExpression
                            ([Comma, Colon, LeftParent] + Context,
                              LabelType, LabelValue);
                          if ValidLabel then SecondValue := LabelValue;
                        end;
                      ThisVariant := LastVariant;
                      while ThisVariant <> nil do
                        with ThisVariant^ do
                          begin
                            if not Disjoint
                               (VariantValue1, VariantValue2,
                                FirstValue, SecondValue)
                            then SemanticError(126);
                            ThisVariant := NextVariant
                          end
                    end;
                NewType(ThisVariant, Variant);
                with ThisVariant^ do
                  begin
                    NextVariant := LastVariant;
                    VariantValue1 := FirstValue;
                    VariantValue2 := SecondValue
                  end;
                LabelCount := LabelCount + Range(FirstValue, SecondValue);
                LastVariant := ThisVariant
              end;

            procedure CheckCompleteness(Required: Boolean);

              var Min, Max: ObjectValue;

              begin
                if TagType <> Unknown
                then
                  begin
                    GetBounds(TagType, Min, Max);
                    if Required
                    then
                      begin
                        if Range(Min, Max) <> LabelCount
                        then SemanticError(127)
                      end
                    else
                      begin
                        if Range(Min, Max) = LabelCount
                        then SemanticError(129)
                      end
                  end
              end { checkcompleteness };

            procedure FixSelector;

              var
                SelectorType: TypEntry;
                SelectorId: IdEntry;

              begin
                with VarPart^ do
                  if (TagField = nil) or MultipleLabels
                  then
                    begin
                      Evaluate(Selections);
                      NewType(SelectorType, Subranges);
                      with SelectorType^ do
                        begin
                          Max := Selections.Velue;
                          RangeType := IntType
                        end;
                      SetRepresentationFor(SelectorType);
                      MakeSpelling(DefaultSpelling);
                      CreateId(SelectorId, Field);
                      SelectorId^.IdType := SelectorType;
                      SelectorField := SelectorId
                    end
                  else SelectorField := TagField
              end { fixselector };

            begin { fieldlist }
              CheckContext(Context + [Ident, CaseSy]);

              { fixed part, if any }

              FixedPart := nil;
              LastField := nil;
              AnyFiles := false;
              while Symbol = Ident do
                begin
                  StartList(FieldsOfOneType);
                  while true do
                    begin
                      NewFieldId;
                      CheckNextOrContext
                        ([Comma, Colon], Context + [Semicolon, CaseSy]);
                      if Symbol <> Comma then goto 9;
                      AcceptSymbol
                    end;
                  9 : ;
                  Accept(Colon);
                  TypeDenoter(Context + [CaseSy, Semicolon], FieldType);
                  AnyFiles := AnyFiles or EmbeddedFile(FieldType);
                  ForAll(FieldsOfOneType, FixFieldId);
                  DsposeList(FieldsOfOneType);
                  LastField^.NextField := nil;
                  if Symbol = Semicolon
                  then
                    begin
                      AcceptSymbol;
                      CheckContext([Ident, CaseSy] + Context)
                    end
                  else
                    if Symbol = CaseSy
                    then Error(Missing(Semicolon), StartOfSymbol)
                end;

              { variant part, if any }

              if Symbol = CaseSy
              then
                begin
                  NewType(VarPart, VariantPart);
                  AcceptSymbol;
                  CopySpelling(FirstName);
                  Accept(Ident);
                  if Symbol = OfSy
                  then
                    begin
                      TagField := nil;
                      TypeName := FirstName
                    end
                  else
                    begin
                      RestoreSpelling(FirstName);
                      NewId(TagField, Field);
                      TagField^.Tag := true;
                      ISerialise(TagField);
                      Accept(Colon);
                      CopySpelling(TypeName);
                      Accept(Ident)
                    end;
                  RestoreSpelling(TypeName);
                  SearchId([Domain, Types], TagTypeId);
                  TagType := TagTypeId^.IdType;
                  EnsureOrdinal(TagType);
                  GetBounds(TagType, TagMin, TagMax);
                  VarPart^.TagType := TagType;
                  VarPart^.TagField := TagField;
                  if TagField <> nil then TagField^.IdType := TagType;
                  CheckContext([OfSy,OtherwiseSy] + ConstFacBegSys + Context);
                  Accept(OfSy);
                  MultipleLabels := false;
                  LabelCount := 0;
                  Selections.Kind := OrdValue;
                  Selections.IVal := -1;
                  LastVariant := nil;
                  while not (Symbol in (Context + [OtherwiseSy])) do
                    begin
                      LastDistinctVariant := LastVariant;
                      while true do
                        begin
                          NewVariantLabel;
                          if Symbol = Comma
                          then MultipleLabels := true else goto 19;
                          AcceptSymbol
                        end;
                      19 : ;
                      Accept(Colon);
                      Selections.IVal := Selections.IVal + 1;
                      Accept(LeftParent);
                      FieldList
                        (Context + [RightParent], FirstSubField,
                         SubVariantPart, VariantFiles);
                      AnyFiles := AnyFiles or VariantFiles;
                      StillDistinct := true;
                      while ThisVariant <> LastDistinctVariant do
                        with ThisVariant^ do
                          begin
                            VarFileFree := not VariantFiles;
                            SubVarPart := SubVariantPart;
                            SubFixedPart := FirstSubField;
                            Distinct := StillDistinct;
                            ThisVariant := NextVariant;
                            StillDistinct := false
                          end;
                      Accept(RightParent);
                      CheckContext(Context + [Semicolon, OtherwiseSy]);
                      if Symbol = OtherwiseSy
                      then Error(Missing(Semicolon), StartOfSymbol);
                      if Symbol = Semicolon then AcceptSymbol
                    end;
                  if Symbol = OtherwiseSy
                  then
                    begin
                      CheckCompleteness(false);
                      AcceptSymbol;
                      Accept(LeftParent);
                      NewType(ThisVariant, Variant);
                      FieldList
                        (Context + [RightParent], FirstSubField,
                         SubVariantPart, VariantFiles);
                      with ThisVariant^ do
                        begin
                          VarFileFree := not VariantFiles;
                          SubVarPart := SubVariantPart;
                          SubFixedPart := FirstSubField
                        end;
                      VarPart^.DefaultVariant := ThisVariant;
                      Accept(RightParent);
                      CheckContext(Context + [Semicolon]);
                      if Symbol = Semicolon then AcceptSymbol
                    end
                  else CheckCompleteness(true);
                  FixSelector;
                  VarPart^.FirstVariant := LastVariant
                end
              else VarPart := nil
            end { fieldlist };

          begin { recordtype }
            AcceptSymbol;
            OpenScope(RecordScope);
            FieldList(Context + [EndSy], LFixedPart, LVarPart, LFiles);
            NewType(TypeFound, Records);
            with TypeFound^ do
              begin
                FileFree := not LFiles;
                PackedRecord := PackFlag;
                FieldScope := Display[ScopeLevel].Locals;
                FixedPart := LFixedPart;
                VarPart := LVarPart
              end;
            CloseScope;
            Accept(EndSy);
            SetRepresentationFor(TypeFound)
          end { recordtype };

        procedure SetType;

          var ElementType: TypEntry;

          begin { settype }
            AcceptSymbol;
            Accept(OfSy);
            OrdinalType(Context, ElementType);
            NewType(TypeFound, Sets);
            with TypeFound^ do
              begin
                if PackFlag
                then FormOfset := IsPacked else FormOfset := Unpacked;
                BaseType := ElementType
              end;
            SetRepresentationFor(TypeFound)
          end { settype };

        procedure FileType;

          var ElementType: TypEntry;

          begin { filetype }
            AcceptSymbol;
            Accept(OfSy);
            TypeDenoter(Context, ElementType);
            NewType(TypeFound, Files);
            with TypeFound^ do
              begin
                PackedFile := PackFlag;
                if EmbeddedFile(ElementType)
                then
                  begin
                    SemanticError(128);
                    ElementType := Unknown
                  end;
                FelType := ElementType
              end;
            SetRepresentationFor(TypeFound)
          end { filetype };

        begin { structuredtype }
          PackFlag := (Symbol = PackedSy);
          if PackFlag then AcceptSymbol;
          CheckNextOrContext(TypeDels, Context);
          if Symbol in TypeDels
          then
            case Symbol of
              ArraySy : ArrayType;
              RecordSy : RecordType;
              SetSy : SetType;
              FileSy : FileType
            end
          else TypeFound := Unknown
        end { structuredtype };

      procedure PointerType;

        var
          DomainEntry: DListEntry;
          ItsDomain: IdEntry;
          DomainNeeded: Boolean;

        begin { pointertype }
          NewType(TypeFound, Pointers);
          AcceptSymbol;
          if Symbol = Ident
          then
            begin
              DomainNeeded := true;
              if AllTypesDefined
              then
                begin
                  SearchId([Types], ItsDomain);
                  TypeFound^.DomainType := ItsDomain^.IdType;
                  DomainNeeded := false
                end
              else
                begin
                  SearchDomain(ItsDomain);
                  if ItsDomain <> nil
                  then
                    begin
                      if ItsDomain^.Klass <> Domain
                      then
                        begin
                          if ItsDomain^.Klass = Types
                          then
                            TypeFound^.DomainType := ItsDomain^.IdType
                          else SemanticError(104);
                          DomainNeeded := false
                        end
                    end
                  else NewId(ItsDomain, Domain)
                end;
              if DomainNeeded
              then
                begin
                  new(DomainEntry);
                  with DomainEntry^ do
                    begin
                      Declaration := StartOfSymbol;
                      DomainId := ItsDomain;
                      PointerType := TypeFound;
                      NextDomain := DomainList
                    end;
                  DomainList := DomainEntry
                end
            end;
          Accept(Ident);
          SetRepresentationFor(TypeFound)
        end { pointertype };

      begin { typedenoter }
        CheckNextOrContext(TypeBegSys, Context);
        if Symbol in TypeBegSys
        then
          begin
            if Symbol = Ident
            then
              begin
                SearchId([Domain, Types, Consts], IdFound);
                if IdFound^.Klass = Types
                then
                  begin
                    TypeFound := IdFound^.IdType;
                    AcceptSymbol
                  end
                else OrdinalType(Context, TypeFound)
              end
            else
              if Symbol in SimpTypeBegSys
              then OrdinalType(Context, TypeFound)
              else
                if Symbol = Arrow then PointerType else StructuredType;
            CheckContext(Context)
          end
        else TypeFound := Unknown
      end { typedenoter };

    procedure TypeDefinitionPart;

      var
        TypeName: Alfa;
        NewTypEntry: TypEntry;
        IdFound: IdEntry;
        ThisDomain: DListEntry;
        DomainFound: Boolean;

      begin { typedefinitionpart }
        AcceptSymbol;
        AllTypesDefined := false;
        DomainList := nil;
        CheckNextOrContext([Ident], BlockContext);
        while Symbol = Ident do
          begin
            CopySpelling(TypeName);
            AcceptSymbol;
            AcceptEquals;
            TypeDenoter
              ([OccupiesSy, Semicolon, PragmaSy]
               + BlockContext, NewTypEntry);
            if Symbol = OccupiesSy then NewSubType(NewTypEntry);
            RestoreSpelling(TypeName);
            DomainFound := false;
            SeekLocalId(Display[BlockLevel].Locals, IdFound);
            if IdFound <> nil
            then DomainFound := IdFound^.Klass = Domain;
            if DomainFound
            then IdFound^.Klass := Types else NewId(IdFound, Types);
            IdFound^.IdType := NewTypEntry;
            Accept(Semicolon);
            if Symbol = PragmaSy
            then PragmaList([Ident] + BlockContext);
            CheckContext([Ident] + BlockContext)
          end;

        { bind remaining domain-identifiers and }
        { fixup local pointer types             }

        while DomainList <> nil do
          begin
            ThisDomain := DomainList;
            with ThisDomain^ do
              begin
                StartOfSymbol := Declaration;
                if DomainId^.Klass = Domain then BindDomain(DomainId);
                PointerType^.DomainType := DomainId^.IdType;
                DomainList := NextDomain
              end;
            dispose(ThisDomain)
          end
      end { typedefinitionpart };

{

 11.6  Variable declaration analysis.
 
 Within each variable declaration, variables  are  accumulated   on
 an   idlist  VarsOfOneType  for  fix-up after the type denoter has
 been analysed.  Variables  declared  at   the   outermost   global
 level  are  checked against the ProgParams list for possible bind-
 ing, as explained in 11.1.
 
 The procedure DeclarationPart provides a common analyser  for  the
 variable,  preset,  and  readonly declaration parts of ICL Pascal.
 For the latter two, initialisation analysis is  performed  by  the
 procedure  Initialize  on  the  basis  of  the  type  returned  by
 TypeDenoter.

                                                                     }

    procedure DeclarationPart(Class: IdClass);

      label 99;

      var
        VarsOfOneType: IdList;
        VarTypEntry: TypEntry;
        PresetOpened: Boolean;

      procedure NewVarId;

        var VarIdEntry: IdEntry;

        begin
          if Symbol = Ident
          then
            begin
              NewId(VarIdEntry, Class);
              ISerialise(VarIdEntry);
              AppendId(VarsOfOneType, VarIdEntry)
            end;
          Accept(Ident)
        end;

      procedure FixVarId(VarId: IdEntry);

        var ParamFound: ProgPmEntry;

        begin
          VarId^.IdType := VarTypEntry;
          if (Symbol = VisibleSy) or (Symbol = ExternSy)
          then
            begin
              if BlockLevel = GlobalLevel
              then
                begin
                  if Symbol = ExternSy
                  then VarId^.VarKind := ExternalVar
                  else VarId^.VarKind := VisibleVar
                end;
              if SameAlfa(VarId^.Name, ProgId^.Name)
              then SemanticError(138)
            end;
          SetAddressFor(VarId);
          if BlockLevel = GlobalLevel
          then SearchProgParams(VarId^.Name, ParamFound)
          else ParamFound := nil;
          if ParamFound <> nil then ParamFound^.ParamId := VarId
        end { fixvarid };

      procedure DesignateVars;

        begin
          ForAll(VarsOfOneType, FixVarId);
          if (Symbol = VisibleSy) or (Symbol = ExternSy)
          then
            begin
              if (BlockLevel <> GlobalLevel) and (Symbol = VisibleSy)
              then SemanticError(139);
              if (BlockLevel <> GlobalLevel) and (Symbol = ExternSy)
              then SemanticError(118);
              AcceptSymbol;
              Accept(Semicolon)
            end
        end { DesignateVars };

      procedure Initialize(TheType: TypEntry; Context: SetOfSymbols);

        function ValidValue(DomainType, ValueType: TypEntry;
                            Velue: ObjectValue):
                   Boolean;

          var
            LowBound, HighBound: ObjectValue;
            OKValue: Boolean;

          begin
            OKValue := Compatible(DomainType, ValueType);
            if OKValue and Ordinal(DomainType)
            then
              begin
                GetBounds(DomainType, LowBound, HighBound);
                OKValue := InRange(LowBound, Velue, HighBound)
              end;
            ValidValue := OKValue
          end;

        procedure ScalarInitialization;

          var
            PresetValue: ObjectValue;
            PresetType: TypEntry;
            Valid: Boolean;

          begin

            { expressions cannot start with }
            {     '(' in this context       }

            if Symbol = LeftParent
            then Error(Missing(OtherSy), StartOfSymbol);
            ConstExpression(Context, PresetType, PresetValue);
            if TheType = RealType
            then Valid := Compatible(PresetType, RealType)
            else Valid := ValidValue(TheType, PresetType, PresetValue);
            if Valid
            then
              begin
                StackConstant(PresetValue);
                AssignPreset
              end
            else SemanticError(260)
          end;

        procedure PointerInitialization;

          begin
            Accept(NilSy);
            StackConstant(NilValue);
            AssignPreset
          end;

        procedure SetInitialization;

          label 1;

          var
            BaseType, PresetType: TypEntry;
            FirstValue, PresetValue: ObjectValue;

          begin { setinitialization }
            Accept(LeftBracket);
            BaseType := TheType^.BaseType;
            StackConstant(EmptyValue);
            if Symbol <> RightBracket
            then
              while true do
                begin
                  UnsignedConstant
                    ([Comma, Thru, RightBracket] + Context, PresetType,
                     PresetValue);
                  EnsureOrdinal(PresetType);
                  if ValidValue(BaseType, PresetType, PresetValue)
                  then StackConstant(PresetValue)
                  else SemanticError(261);
                  if Symbol = Thru
                  then
                    begin
                      AcceptSymbol;
                      FirstValue := PresetValue;
                      UnsignedConstant
                        ([Comma, RightBracket] + Context, PresetType,
                         PresetValue);
                      EnsureOrdinal(PresetType);
                      if ValidValue(BaseType, PresetType, PresetValue)
                      then StackConstant(PresetValue)
                      else SemanticError(261);
                      if OrderedValues(PresetValue, FirstValue)
                      then SemanticError(262);
                      RangeSet(PresetType^.Representation)
                    end
                  else SingletonSet(PresetType^.Representation);
                  BinarySetOperation(Plus);
                  if Symbol <> Comma then goto 1;
                  AcceptSymbol
                end { while };
            1 : ;
            AssignPreset;
            Accept(RightBracket)
          end { setinitialization };

        procedure RecordInitialization;

          type RecordMode = (Undecided, Named, Positional);

          var FieldFound: IdEntry;

          procedure PresetLevel(Context: SetOfSymbols;
                                Mode: RecordMode; FixedPart: IdEntry;
                                VariantPart: TypEntry);

            var
              PresetBegSys: SetOfSymbols;
              SelectedList, FieldList: IdList;
              PresetType, NestedVariant: TypEntry;
              PresetValue: ObjectValue;

            procedure EnsureMode(Required: RecordMode);

              begin
                if (Mode <> Required) and (Mode <> Undecided)
                then Error(Missing(OtherSy), StartOfSymbol);
                Mode := Required
              end { EnsureMode };

            procedure FieldOrExpn(ExpContext: SetOfSymbols;
                                  var ExpFound: Boolean);

              var
                IdFound: IdEntry;
                IdName: Alfa;

              begin
                CopySpelling(IdName);
                SearchGlobals(Consts, IdFound);
                if IdFound <> nil
                then
                  begin
                    ConstExpression
                      (ExpContext + [Bar, PresetOp], PresetType,
                       PresetValue);
                    ExpFound := WasExpression or (Symbol in ExpContext)
                  end
                else
                  begin
                    ExpFound := false;
                    AcceptSymbol
                  end;
                if not ExpFound then RestoreSpelling(IdName)
              end { FieldOrExpn };

            procedure BuildList(Field: IdEntry);

              begin
                StartList(FieldList);
                while Field <> nil do
                  begin
                    if Field = FieldFound
                    then FieldFound := nil
                    else Include(FieldList, Field);
                    Field := Field^.NextField
                  end
              end { BuildList };

            procedure SelectField(Field: IdEntry);

              begin
                if InSet(SelectedList, Field)
                then SemanticError(263)
                else
                  if not InSet(FieldList, Field)
                  then SemanticError(271)
                  else
                    begin
                      FieldPreset(Field^.Offset);
                      Exclude(FieldList, Field);
                      Include(SelectedList, Field)
                    end
              end { SelectField };

            procedure AssignField(Field: IdEntry);

              var FieldType: TypEntry;

              begin
                FieldType := Field^.IdType;
                if not ValidValue(FieldType, PresetType, PresetValue)
                then SemanticError(260) else StackConstant(PresetValue)
              end { AssignField };

            procedure NamedFieldList(Context: SetOfSymbols;
                                     var FieldType: TypEntry);

              var FirstId: Boolean;

              procedure NamedField;

                var IdFound: IdEntry;

                begin
                  SeekLocalId(TheType^.FieldScope, IdFound);
                  if IdFound = nil
                  then SemanticError(271)
                  else
                    begin
                      if Identical(IdFound^.IdType, FieldType)
                      then FieldType := IdFound^.IdType
                      else SemanticError(264);
                      SelectField(IdFound)
                    end;
                  if FirstId then FirstId := false else AcceptSymbol
                end { NamedField };

              begin
                FieldType := Unknown;
                FirstId := true;
                repeat
                  NamedField;
                  CheckNextOrContext([Bar, PresetOp], Context);
                  if Symbol = Bar then AcceptSymbol
                until Symbol <> Ident
              end { NamedFieldList };

            procedure PresetFieldList(FirstField: IdEntry);

              procedure PresetField(Context: SetOfSymbols);

                var
                  NextField: IdEntry;
                  FieldType: TypEntry;
                  ExpnFound: Boolean;

                begin
                  if Symbol = Ident
                  then
                    begin
                      FieldOrExpn(Context, ExpnFound);
                      if ExpnFound
                      then
                        begin
                          EnsureMode(Positional);
                          NextField := FieldList.FirstEntry^.Id;
                          SelectField(NextField);
                          AssignField(NextField)
                        end
                      else
                        begin
                          NamedFieldList
                            ([PresetOp] + Context, FieldType);
                          EnsureMode(Named);
                          Accept(PresetOp);
                          Initialize(FieldType, Context)
                        end
                    end
                  else
                    begin
                      EnsureMode(Positional);
                      NextField := FieldList.FirstEntry^.Id;
                      FieldType := NextField^.IdType;
                      SelectField(NextField);
                      Initialize(FieldType, Context)
                    end;
                  CopyPreset;
                  CheckContext(Context)
                end { PresetField };

              begin
                StartList(SelectedList);
                BuildList(FirstField);
                PresetField
                  ([Comma, RightParent] + ConstFacBegSys + Context);
                while (Symbol in ([Comma] + PresetBegSys)) and
                      (FieldList.FirstEntry <> nil) do
                  begin
                    Accept(Comma);
                    PresetField
                      ([Comma, RightParent] + ConstFacBegSys + Context)
                  end;
                if Symbol = Comma then AcceptSymbol;
                if FieldList.FirstEntry <> nil then SemanticError(265);
                DsposeList(FieldList);
                DsposeList(SelectedList)
              end { PresetFieldList };

            procedure SelectVariant(var Variant: TypEntry);

              var
                SubPart: TypEntry;
                ExpnFound: Boolean;

              procedure ActivateVariant;

                begin
                  with SubPart^ do
                    begin
                      PresetSelector
                        (Representation, Variant^.Representation);
                      if TagField <> nil
                      then
                        begin
                          FieldPreset(TagField^.Offset);
                          OpenPresetSpace(TagField^.IdType^.Representation);
                          StackConstant(PresetValue);
                          AssignPreset;
                          StackPreset;
                          CopyPreset
                        end
                      else
                        if FieldFound <> nil
                        then
                          with FieldFound^ do
                            begin
                              FieldPreset(Offset);
                              Accept(PresetOp);
                              Initialize
                                (IdType,
                                 [Comma, RightParent] + Context);
                              CopyPreset
                            end
                    end
                end { ActivateVariant };

              procedure SelectByField(FieldId: IdEntry);

                begin
                  if VariantPart^.TagField <> nil
                  then
                    begin
                      if VariantPart^.TagField <> FieldId
                      then SemanticError(273);
                      Accept(PresetOp);
                      ConstExpression
                        ([Comma, RightParent] + Context, PresetType,
                         PresetValue);
                      if ValidValue
                           (VariantPart^.TagType, PresetType,
                            PresetValue)
                      then SeekByValue(SubPart, Variant, PresetValue)
                      else SemanticError(266)
                    end
                  else
                    if not VariantField(SubPart, FieldId)
                    then SemanticError(274)
                    else SeekByName(SubPart, Variant, FieldId)
                end { SelectByField };

              begin
                Variant := nil;
                SubPart := VariantPart;
                if Symbol in PresetBegSys
                then
                  begin
                    if Symbol = Ident
                    then
                      begin
                        FieldOrExpn
                          ([Colon, Comma] + Context, ExpnFound);
                        if ExpnFound
                        then
                          begin
                            if ValidValue
                                 (SubPart^.TagType, PresetType,
                                  PresetValue)
                            then
                              SeekByValue
                                (SubPart, Variant, PresetValue)
                            else SemanticError(266);
                            EnsureMode(Positional);
                            Accept(Colon);
                            Mode := Undecided
                          end
                        else
                          begin
                            EnsureMode(Named);
                            SeekLocalId
                              (TheType^.FieldScope, FieldFound);
                            if FieldFound = nil
                            then SemanticError(271)
                            else SelectByField(FieldFound)
                          end
                      end
                    else
                      begin

                        { expressions cannot start with a }
                        {     '(' in this context         }

                        if Symbol = LeftParent
                        then Error(Missing(OtherSy), StartOfSymbol);
                        EnsureMode(Positional);
                        ConstExpression
                          ([Comma, Colon] + Context, PresetType,
                           PresetValue);
                        if ValidValue
                             (SubPart^.TagType, PresetType, PresetValue)
                        then
                          SeekByValue(SubPart, Variant, PresetValue)
                        else SemanticError(266);
                        Accept(Colon);
                        Mode := Undecided
                      end;
                    if SubPart <> VariantPart then SemanticError(272);
                    if Variant <> nil then ActivateVariant;
                    if (Mode <> Undecided) and (Symbol = Comma)
                    then AcceptSymbol
                  end
              end { SelectVariant };

            begin { PresetLevel }
              PresetBegSys := FacBegSys + [AddOp];
              CheckNextOrContext(PresetBegSys + [RightParent], Context);
              if Symbol in PresetBegSys
              then
                begin
                  if FixedPart <> nil then PresetFieldList(FixedPart);
                  if VariantPart <> nil
                  then
                    begin
                      SelectVariant(NestedVariant);
                      if Mode = Undecided then Accept(LeftParent);
                      if NestedVariant <> nil
                      then
                        with NestedVariant^ do
                          PresetLevel
                            (Context, Mode, SubFixedPart, SubVarPart);
                      if Mode = Undecided then Accept(RightParent)
                    end;
                  CheckContext(Context)
                end
            end { PresetLevel };

          begin { recordinitialization }
            with TheType^ do
              begin
                if FieldScope = nil
                then SemanticError(267)
                else
                  begin
                    FieldFound := nil;
                    Accept(LeftParent);
                    PresetLevel
                      (Context + [RightParent], Undecided, FixedPart,
                       VarPart);
                    Accept(RightParent)
                  end
              end
          end { recordinitialization };

        procedure ArrayInitialization;

          var
            PresetBegSys: SetOfSymbols;
            PresetValue: ObjectValue;
            PresetType: TypEntry;

          procedure ArrayConstructor(Context: SetOfSymbols);

            type
              ArrayMode = (Undecided, Positional, Indexed);
              RangeEntry = ^RangeRecord;
              RangeRecord = record
                              succ, Prev: RangeEntry;
                              LowIndex, HighIndex: ObjectValue
                            end;

            var
              Elements: Scalar;
              IndexType, ElementType: TypEntry;
              LowBound, HighBound: ObjectValue;
              Selections, Defaults: RangeEntry;
              Mode: ArrayMode;

            procedure NewRange(Low, High: ObjectValue;
                               var Range: RangeEntry);

              begin
                new(Range);
                with Range^ do
                  begin
                    succ := nil;
                    Prev := nil;
                    LowIndex := Low;
                    HighIndex := High
                  end
              end { newrange };

            procedure SearchRange(List, SubRange: RangeEntry;
                                  var HostRange: RangeEntry);

              var Inclusive: Boolean;

              begin
                HostRange := List;
                Inclusive := false;
                while (HostRange <> nil) and not Inclusive do
                  if (OrderedValues
                        (HostRange^.HighIndex, SubRange^.LowIndex)
                      or
                      OrderedValues
                        (SubRange^.HighIndex, HostRange^.LowIndex))
                  then HostRange := HostRange^.succ
                  else Inclusive := true
              end;

            function SameRange(Range1, Range2: RangeEntry): Boolean;

              begin
                SameRange :=
                  SameValue(Range1^.LowIndex, Range2^.LowIndex) and
                  SameValue(Range1^.HighIndex, Range2^.HighIndex)
              end { SameRange };

            procedure InsertRange(InsertPtr, Range: RangeEntry);

              begin
                Range^.Prev := InsertPtr;
                Range^.succ := InsertPtr^.succ;
                InsertPtr^.succ := Range
              end { InsertRange };

            procedure DeleteRange(var List: RangeEntry;
                                  Range: RangeEntry);

              var Previous, Successor: RangeEntry;

              begin
                Previous := Range^.Prev;
                Successor := Range^.succ;
                if Previous <> nil then Previous^.succ := Successor;
                if Successor <> nil then Successor^.Prev := Previous;
                dispose(Range);
                if Previous = nil then List := Successor
              end { DeleteRange };

            procedure IncludeRange(var List: RangeEntry;
                                   Range: RangeEntry);

              var Last: RangeEntry;

              begin
                if List = nil
                then List := Range
                else
                  begin
                    Last := List;
                    while Last^.succ <> nil do Last := Last^.succ;
                    InsertRange(Last, Range)
                  end
              end { IncludeRange };

            procedure ExcludeRange(Range1, Range2: RangeEntry);

              var
                NextLow, NextHigh: ObjectValue;
                NextRange: RangeEntry;

              begin
                if SameValue(Range1^.LowIndex, Range2^.LowIndex)
                then
                  AddValues
                    (Range2^.HighIndex, OneValue, Range1^.LowIndex)
                else
                  if SameValue(Range1^.HighIndex, Range2^.HighIndex)
                  then
                    SubValues
                      (Range2^.LowIndex, OneValue, Range1^.HighIndex)
                  else
                    begin
                      NextHigh := Range1^.HighIndex;
                      SubValues
                        (Range2^.LowIndex, OneValue, Range1^.HighIndex);
                      AddValues(Range2^.HighIndex, OneValue, NextLow);
                      NewRange(NextLow, NextHigh, NextRange);
                      InsertRange(Range1, NextRange)
                    end
              end;

            procedure DisposeRanges(List: RangeEntry);

              var ThisRange: RangeEntry;

              begin
                while List <> nil do
                  begin
                    ThisRange := List;
                    DeleteRange(List, ThisRange)
                  end
              end { DisposeRanges };

            procedure SelectRange(Low, High: ObjectValue);

              var ThisRange, RangeFound: RangeEntry;

              begin
                NewRange(Low, High, ThisRange);
                SearchRange(Selections, ThisRange, RangeFound);
                if RangeFound <> nil
                then SemanticError(268)
                else IncludeRange(Selections, ThisRange)
              end { selectrange };

            procedure DefaultRanges(Low, High: ObjectValue);

              var SubRange, HostRange: RangeEntry;

              begin
                NewRange(Low, High, Defaults);
                while Selections <> nil do
                  begin
                    SubRange := Selections;
                    SearchRange(Defaults, SubRange, HostRange);
                    if SameRange(SubRange, HostRange)
                    then DeleteRange(Defaults, HostRange)
                    else ExcludeRange(HostRange, SubRange);
                    DeleteRange(Selections, SubRange)
                  end
              end;

            procedure ForAllRanges(List: RangeEntry;
                                   procedure Action(Low, High:
                                                      ObjectValue));

              var ThisRange: RangeEntry;

              begin
                ThisRange := List;
                while ThisRange <> nil do
                  with ThisRange^ do
                    begin
                      Action(LowIndex, HighIndex);
                      ThisRange := succ
                    end
              end { forallranges };

            procedure IndexArray(Low, High: ObjectValue);

              begin
                InxPreset(TheType^.PackedArray,
                              Low, High, LowBound,
                              TheType^.AelType^.Representation)
              end { indexedarray };

            procedure DefaultSelections;

              var
                Count, NextIndex: ObjectValue;
                ArrayLength: Scalar;

              begin
                ArrayLength := Range(LowBound, HighBound);
                if Elements < ArrayLength
                then
                  begin
                    if Symbol = RightParent
                    then
                      begin
                        MakeValue(Elements, Count);
                        AddValues(LowBound, Count, NextIndex);
                        IndexArray(NextIndex, HighBound);
                        StackConstant(PresetValue)
                      end
                    else
                      begin
                        Accept(OtherwiseSy);
                        DefaultRanges(LowBound, HighBound);
                        ForAllRanges(Defaults, IndexArray);
                        Accept(PresetOp);
                        Initialize
                          (TheType^.AelType, Context + [RightParent])
                      end;
                    CopyPreset;
                    Elements := ArrayLength
                  end;
                if Elements > ArrayLength then SemanticError(269)
              end;

            procedure SelectElements(Low, High: ObjectValue);

              begin
                SelectRange(Low, High);
                IndexArray(Low, High);
                Elements := Elements + Range(Low, High)
              end { SelectElements };

            procedure IndexElement;

              var Index: ObjectValue;

              begin
                MakeValue(Elements, Index);
                AddValues(LowBound, Index, Index);
                SelectElements(Index, Index)
              end { IndexElement };

            procedure IndexOrExpn(ExpContext: SetOfSymbols;
                                  var ExpnFound: Boolean);

              begin

                { expressions cannot start with a }
                {     '(' in this context         }

                if Symbol = LeftParent
                then Error(Missing(OtherSy), StartOfSymbol);
                ConstExpression
                  (ExpContext + [Bar, Thru, PresetOp], PresetType,
                   PresetValue);
                ExpnFound := WasExpression or (Symbol in ExpContext)
              end { IndexOrExpn };

            procedure IndexList(Context: SetOfSymbols);

              label 9;

              var FirstTaken: Boolean;

              procedure IndexValues(Context: SetOfSymbols);

                var FirstIndex, SecondIndex: ObjectValue;

                begin
                  if FirstTaken
                  then FirstTaken := false
                  else
                    ConstExpression
                      ([Thru] + Context, PresetType, PresetValue);
                  if not ValidValue(IndexType, PresetType, PresetValue)
                  then SemanticError(270);
                  FirstIndex := PresetValue;
                  if Symbol = Thru
                  then
                    begin
                      AcceptSymbol;
                      ConstExpression(Context, PresetType, SecondIndex);
                      if not ValidValue
                               (IndexType, PresetType, SecondIndex)
                      then SemanticError(270)
                      else
                        if OrderedValues(SecondIndex, FirstIndex)
                        then SemanticError(262)
                        else SelectElements(FirstIndex, SecondIndex)
                    end
                  else SelectElements(FirstIndex, FirstIndex)
                end { IndexValues };

              begin { IndexList }
                FirstTaken := true;
                while true do
                  begin
                    IndexValues([Bar] + Context);
                    CheckNextOrContext([Bar, PresetOp], Context);
                    if Symbol <> Bar then goto 9;
                    AcceptSymbol
                  end;
                9 :
              end { IndexList };

            procedure EnsureMode(Required: ArrayMode);

              begin
                if (Mode <> Required) and (Mode <> Undecided)
                then Error(Missing(OtherSy), StartOfSymbol);
                Mode := Required
              end { EnsureMode };

            procedure PresetList(Context: SetOfSymbols);

              procedure PresetElement(Context: SetOfSymbols);

                var ExpnFound: Boolean;

                begin
                  if Symbol in (ConstBegSys + [NotSy])
                  then
                    begin
                      IndexOrExpn(Context, ExpnFound);
                      if ExpnFound
                      then
                        begin
                          EnsureMode(Positional);
                          IndexElement;
                          if ValidValue
                               (ElementType, PresetType, PresetValue)
                          then StackConstant(PresetValue)
                          else SemanticError(260)
                        end
                      else
                        begin
                          EnsureMode(Indexed);
                          IndexList([PresetOp] + Context);
                          Accept(PresetOp);
                          Initialize(ElementType, Context)
                        end
                    end
                  else
                    begin
                      EnsureMode(Positional);
                      IndexElement;
                      Initialize(ElementType, Context)
                    end;
                  CopyPreset;
                  CheckContext(Context)
                end { PresetElement };

              begin { PresetList }
                PresetElement
                  ([Comma, RightParent] + ConstFacBegSys + Context);
                while Symbol in ([Comma] + PresetBegSys) do
                  begin
                    Accept(Comma);
                    if Symbol in PresetBegSys
                    then
                      PresetElement
                        ([Comma, RightParent] + ConstFacBegSys +
                         Context)
                  end
              end { PresetList };

            begin { arrayconstructor }
              Mode := Undecided;
              Selections := nil;
              Defaults := nil;
              Elements := 0;
              ElementType := TheType^.AelType;
              IndexType := TheType^.InxType;
              GetBounds(IndexType, LowBound, HighBound);
              CheckNextOrContext(PresetBegSys + [OtherwiseSy], Context);
              if Symbol in PresetBegSys
              then PresetList([OtherwiseSy] + Context);
              DefaultSelections;
              DisposeRanges(Selections);
              DisposeRanges(Defaults)
            end { ArrayConstructor };

          begin { arrayinitialization }
            PresetBegSys := FacBegSys + [AddOp];
            CheckNextOrContext
              ([StringConst, LeftParent],
               PresetBegSys + [OtherwiseSy] + Context);
            if (Symbol = StringConst) and (TheType^.AelType = CharType)
            then
              begin
                UnsignedConstant(Context, PresetType, PresetValue);
                if Compatible(TheType, PresetType)
                then
                  begin
                    StackConstant(PresetValue);
                    AssignPreset
                  end
                else SemanticError(260)
              end
            else
              begin
                Accept(LeftParent);
                ArrayConstructor(Context + [RightParent]);
                Accept(RightParent)
              end
          end {arrayinitialization};

        begin
          OpenPresetSpace(TheType^.Representation);
          case TheType^.Form of
            Scalars, Subranges : ScalarInitialization;
            Pointers : PointerInitialization;
            Sets : SetInitialization;
            Arrays : ArrayInitialization;
            Records : RecordInitialization;
            Files :
          end;
          StackPreset;
          CheckContext(Context)
        end { initialization };

      begin { declarationpart }
        if (Class = PresetVars) and (BlockLevel <> GlobalLevel)
        then SemanticError(156);
        AllTypesDefined := true;
        AcceptSymbol;
        repeat
          StartList(VarsOfOneType);
          PresetOpened := false;
          while true do
            begin
              NewVarId;
              CheckNextOrContext
                (BlockContext + [Comma, Colon] + TypeDels, [Semicolon]);
              if (Symbol <> Comma) then goto 99;
              AcceptSymbol
            end;
          99 : Accept(Colon);
          TypeDenoter
            ([Semicolon, Becomes, PragmaSy] + TypeDels + BlockContext,
             VarTypEntry);
          if Class = Vars
          then Accept(Semicolon)
          else
            begin
              if EmbeddedFile(VarTypEntry) then SemanticError(275);
              if Symbol = Becomes
              then
                begin
                  AcceptSymbol;
                  Initialize(VarTypEntry, BlockContext + [Semicolon]);
                  PresetOpened := true;
                  Accept(Semicolon);
                  CheckContext
                    ([Ident, VisibleSy, PragmaSy] + TypeDels + BlockContext)
                end
              else
                begin
                  Accept(Semicolon);
                  if Symbol <> ExternSy
                  then Error(Missing(ExternSy), StartOfSymbol)
                end
            end;
          DesignateVars;
          if PresetOpened then ClsPresetSpace;
          if Symbol = PragmaSy
          then PragmaList([Ident] + TypeDels + BlockContext);
          DsposeList(VarsOfOneType);
          CheckContext([Ident] + TypeDels + BlockContext)
        until (Symbol <> Ident) and not (Symbol in TypeDels)
      end { declarationpart };   

{

 11.7  Procedure and function declaration analysis.
 
 Analysis  of procedure  and  function  declarations  involves  the
 treatment  of formal parameter lists and forward block identifica-
 tion.
 
 A representation of the formal parameters is  built  as  the  list
 FormalList,  which  has one element for each parameter identifier.
 Each element records the kind of the formal parameter, and associ-
 ated attributes needed for actual parameter checking or congruence
 testing.  A  formal  parameter  section  involving  a  conformant-
 array-parameter-schema  gives  rise  to  an additional element  of
 kind BoundParm, which does  not  correspond directly  to  a formal
 parameter, but is used to prompt the passing of actual array-bound
 values to the bound-identifiers of the schema.  The completed for-
 mal  list  is  attached to the Idrec representing the procedure or
 function identifier.
 
 The formal parameter identifiers  are   also   treated  as   local
 variables  and  are  entered  into  the  symbol table at the newly
 created  top-most  scope  level.  At the end of the  procedure  or
 function  heading  this scope is automatically saved, and restored
 at the start of the corresponding block. As  explained  in  module
 10, this allows type identifiers used in the formal parameter list
 to be redefined within the block.
 
 This saving and  restoring  also  accommodates  the  split  scopes
 created  by  forward  declarations. If however the program repeats
 the formal parameter list of a forward-declared procedure or func-
 tion  special  logic  is  included  to  discard and re-analyse the
 parameter list for error recovery purposes.

                                                                     }

    procedure PfDeclaration;

      var
        BlockId: IdEntry;
        Followers: SetOfSymbols;

      procedure PfHeading(Context: SetOfSymbols; HeadingKind: IdKind;
                          var PfId: IdEntry);

        var
          PfClass: Proc..Func;
          TypeId: IdEntry;
          FormalList: FormalEntry;
          FuncType: TypEntry;
          AlreadyDeclared: Boolean;

        procedure FormalParameterList(Context: SetOfSymbols);

          label 9;

          var
            PfParam: IdEntry;
            ParamsOfOneType: IdList;
            ParamType: TypEntry;
            ReadOnlyMode, VarMode, Packing, FirstOne: Boolean;
            LastFormal: FormalEntry;
            SectionNumber: Scalar;

          procedure NewParamId;

            var ThisParam: IdEntry;

            begin
              if Symbol = Ident
              then
                begin
                  if ReadOnlyMode
                  then NewId(ThisParam, ReadOnlyVars)
                  else NewId(ThisParam, Vars);
                  ISerialise(ThisParam);
                  if VarMode
                  then ThisParam^.VarKind := VarParam
                  else
                    if ReadOnlyMode
                    then ThisParam^.VarKind := ReadOnlyParam
                    else ThisParam^.VarKind := ValueParam;
                  AppendId(ParamsOfOneType, ThisParam)
                end;
              Accept(Ident)
            end;

          procedure AppendFormal(ParamSpec: ParmKind);

            var ThisFormal: FormalEntry;

            begin
              new(ThisFormal);
              with ThisFormal^ do
                begin
                  Section := SectionNumber;
                  Parm := ParamSpec;
                  case Parm of
                    ReadOnlyParm, BoundParm, ValueParm, VarParm :
                      FormalType := ParamType;
                    ProcParm, FuncParm :
                      begin
                        ItsFormals := PfParam^.Formals;
                        if Parm = FuncParm
                        then FormalType := PfParam^.IdType
                      end
                  end;
                  Next := nil
                end;
              if LastFormal = nil
              then FormalList := ThisFormal
              else LastFormal^.Next := ThisFormal;
              LastFormal := ThisFormal
            end { addtoformallist };

          procedure FixParamId(ParamId: IdEntry);

            begin
              ParamId^.IdType := ParamType;
              SetAddressFor(ParamId);
              if VarMode
              then AppendFormal(VarParm)
              else
                if ReadOnlyMode
                then AppendFormal(ReadOnlyParm)
                else AppendFormal(ValueParm)
            end { fixparamid };

          procedure ProcOrFuncSpec;

            begin
              SetAddressFor(PfParam);
              with PfParam^ do
                if Klass = Proc
                then AppendFormal(ProcParm) else AppendFormal(FuncParm)
            end { procorfuncspec };

          procedure VarOrValueSpec;

            begin
              if IsConformant(ParamType) then AppendFormal(BoundParm);
              ForAll(ParamsOfOneType, FixParamId)
            end { varorvaluespec };

          procedure IdentOrSchema(Context: SetOfSymbols;
                                  var TypeFound: TypEntry);

            var
              TypeId: IdEntry;
              Starters: SetOfSymbols;

            procedure ArraySchema(Context: SetOfSymbols;
                                  var TypeFound: TypEntry);

              label 9;

              var
                Schema, LastSchema, ComponentType: TypEntry;
                WeakStarters: SetOfSymbols;

              procedure IndexSpec(Context: SetOfSymbols);

                type
                  BdForm=
                    record
                      case Fixed: Boolean of
                        false: (BdId: IdEntry);
                        true: (BdValue: ObjectValue;
                               BdType: TypEntry)
                    end;

                var
                  Bound1, Bound2: BdForm;
                  BdIdent1, BdIdent2: IdEntry;
                  BoundsProvided: Boolean;
                  FirstName: Alfa;
                  IndexType: TypEntry;
                  TypeId: IdEntry;
                  ThisBound: CAPBound;

              procedure ArrayBound(Context: SetOfSymbols;
                                   var ThisBound: BdForm);

                begin
                  CheckNextOrContext(IndexSpecBegSys, Context);
                  if Symbol in IndexSpecBegSys
                  then
                    begin
                      with ThisBound do
                        if Symbol = Ident
                        then
                          begin
                            Fixed := false;
                            NewId(BdId, Bound);
                            ISerialise(BdId);
                            AcceptSymbol
                          end
                        else
                          begin
                            Fixed := true;
                            ConstExpression(Context, BdType, BdValue)
                          end;
                      CheckContext(Context)
                    end
                end { ArrayBound };

              procedure Check(Bound: BdForm; var Ident: IdEntry);

                var MinValue, MaxValue: ObjectValue;

                begin
                  with Bound do
                    if Fixed
                    then
                      begin
                        Ident := nil;
                        if not Compatible(BdType, IndexType)
                        then SemanticError(255)
                        else
                          begin
                            GetBounds(IndexType, MinValue, MaxValue);
                            if OrderedValues(BdValue, MinValue) or
                               OrderedValues(MaxValue, BdValue)
                            then SemanticError(256)
                          end
                      end
                    else
                      begin
                        Ident := Bound.BdId;
                        Ident^.IdType := IndexType
                      end
                end { Check } ;

              procedure SetBound(var ThisBound: BdForm;
                                      Value: ObjectValue);

                begin
                  with ThisBound do
                    begin
                      Fixed := true;
                      BdValue := Value;
                      BdType := NaturalType
                    end
                 end { SetConstBound };

               procedure CopyBound(ThisBound: BdForm;
                                   var Copy: CAPBound);
                 begin
                   with Copy do
                     begin
                       Fixed := ThisBound.Fixed;
                       if Fixed
                       then Value := ThisBound.BdValue
                       else Address := ThisBound.BdId^.BdAddress
                     end
                 end { CopyBound };

                begin { indexspec }
                  SetBound(Bound1, ZeroValue);
                  SetBound(Bound2, OneValue);
                  BoundsProvided := false;
                  IndexType := Unknown;
                  if InHousePascal
                  then CheckContext(IndexSpecBegSys + Context)
                  else CheckNextOrContext(IndexSpecBegSys, Context);
                  if Symbol in IndexSpecBegSys
                  then
                    begin
                      if InHousePascal and (Symbol = Ident)
                      then
                        begin
                          CopySpelling(FirstName);
                          AcceptSymbol;
                          if not (Symbol in Context)
                          then
                            begin
                              RestoreSpelling(FirstName);
                              with Bound1 do
                                begin
                                  Fixed := false;
                                  NewId(BdId, Bound);
                                  ISerialise(BdId)
                                end;
                              BoundsProvided := true
                            end
                          else
                            begin
                              if not FirstOne then SemanticError(257);
                              RestoreSpelling(FirstName);
                              SearchId([Types], TypeId);
                              IndexType := TypeId^.IdType;
                              EnsureOrdinal(IndexType)
                            end
                        end
                      else
                        begin
                          BoundsProvided := true;
                          ArrayBound([Thru] + Context, Bound1)
                        end;
                    if BoundsProvided
                    then
                      begin
                        Accept(Thru);
                        if Bound1.Fixed and (Symbol <> Ident)
                        then Error(Missing(Ident), StartOfSymbol);
                        ArrayBound([Colon] + Context, Bound2);
                        Accept(Colon);
                        if Symbol = Ident
                        then
                          begin
                            SearchId([Types], TypeId);
                            IndexType := TypeId^.IdType;
                            EnsureOrdinal(IndexType)
                          end;
                        Accept(Ident);
                        Check(Bound1, BdIdent1);
                        Check(Bound2, BdIdent2);
                        SetBoundPairBlockFor(BdIdent1, BdIdent2)
                      end
                    end
                  else
                    if InHousePascal
                    then
                      begin
                        if not FirstOne then SemanticError(257);
                        IndexType := NaturalType;
                        SetBound(Bound2, MaxintValue)
                      end;
                  NewType(Schema, CAPSchema);
                  with Schema^ do
                    begin
                      PackedSchema := Packing;
                      ValueSchema := not (VarMode or ReadOnlyMode);
                      FirstIndex := FirstOne;
                      Bounded := BoundsProvided;
                      InxSpec := IndexType;
                      CompType := LastSchema;
                      CopyBound(Bound1, ThisBound);
                      LowBound := ThisBound;
                      CopyBound(Bound2, ThisBound);
                      HighBound :=ThisBound
                    end;
                  LastSchema := Schema;
                  FirstOne := false;
                  CheckContext(Context)
                end { indexspec };

              begin { arrayschema }
                WeakStarters := [LeftBracket, Ident];
                Schema := nil;
                LastSchema := nil;
                Accept(ArraySy);
                CheckNextOrContext(WeakStarters, Context);
                if Symbol in WeakStarters
                then
                  begin
                    Accept(LeftBracket);
                    while true do
                      begin
                        IndexSpec
                          ([Semicolon, RightBracket] + Context);
                        if Symbol <> Semicolon then goto 9;
                        if Packing then SemanticError(250);
                        AcceptSymbol
                      end;
                    9 : Accept(RightBracket);
                    Accept(OfSy)
                  end;
                CheckContext(Context);
                IdentOrSchema(Context, ComponentType);
                if Schema <> nil
                then
                  repeat
                    LastSchema := Schema^.CompType;
                    Schema^.CompType := ComponentType;
                    SetRepresentationFor(Schema);
                    ComponentType := Schema;
                    Schema := LastSchema
                  until Schema = nil;
                TypeFound := ComponentType
              end { arrayschema };

            begin { identorschema }
              Starters := ConformantParamBegSys + [Ident];
              CheckNextOrContext(Starters, Context);
              if Symbol in Starters
              then
                begin
                  if Symbol = Ident
                  then
                    begin
                      SearchId([Types], TypeId);
                      TypeFound := TypeId^.IdType;
                      Accept(Ident)
                    end
                  else
                    begin
                      if Packing then SemanticError(250);
                      if Symbol = PackedSy
                      then
                        begin
                          Packing := true;
                          AcceptSymbol
                        end;
                      ArraySchema(Starters + Context, TypeFound)
                    end;
                  CheckContext(Context)
                end
              else TypeFound := Unknown
            end { identorschema };

          begin { formalparameterlist }
            Accept(LeftParent);
            LastFormal := nil;
            SectionNumber := 0;
            CheckNextOrContext(ParamBegSys, [RightParent] + Context);
            while Symbol in ParamBegSys do
              begin
                SectionNumber := SectionNumber + 1;
                case Symbol of
                  ProcSy, FuncSy :
                    begin
                      PfHeading
                        ([Semicolon, RightParent] + Context, Formal,
                         PfParam);

                      { discard scope created }
                      { for parameter list of }
                      { this parameter        }

                      CloseStackFrame;
                      DisposeScope;
                      CloseScope;
                      ProcOrFuncSpec
                    end;
                  ReadOnlySy, VarSy, Ident :
                    begin
                      StartList(ParamsOfOneType);
                      VarMode := (Symbol = VarSy);
                      ReadOnlyMode := (Symbol = ReadOnlySy);
                      if (VarMode or ReadOnlyMode) then AcceptSymbol;
                      while true do
                        begin
                          NewParamId;
                          CheckNextOrContext
                            ([Comma, Colon],
                             [Semicolon, RightParent] + Context);
                          if Symbol <> Comma then goto 9;
                          AcceptSymbol
                        end;
                      9 : ;
                      Accept(Colon);
                      Packing := false;
                      FirstOne := true;
                      IdentOrSchema
                        (Context + [Semicolon, RightParent], ParamType);
                      if ParamType <> Unknown
                      then
                        if not VarMode and EmbeddedFile(ParamType)
                        then
                          if ReadOnlyMode
                          then SemanticError(287)
                          else SemanticError(145);
                      VarOrValueSpec;
                      DsposeList(ParamsOfOneType)
                    end
                end { case };
                if Symbol = Semicolon
                then
                  begin
                    AcceptSymbol;
                    CheckNextOrContext
                      (ParamBegSys, [RightParent] + Context)
                  end
              end { while };
            Accept(RightParent);
            CheckContext(Context)
          end { formalparameterlist };

        procedure DuplicateParameterScope;

          begin

            { dispose the original formal scope }

            ReEnterScope(PfId^.FormalScope);
            ReclaimStackFrame;
            CloseStackFrame;
            DisposeScope;
            CloseScope;

            { now open a scope for the duplicate fplist }

            OpenScope(ActualBlock);
            OpenStackFrame
          end { DuplicateParameterScope };

        procedure SaveParameterScope;

          var Temporary: ScopeCopy;

          begin
            SaveStackFrame;
            SaveScope(Temporary);
            PfId^.FormalScope := Temporary
          end { SaveParameterScope };

        begin { pfheading }
          if Symbol = ProcSy then PfClass := Proc else PfClass := Func;
          AcceptSymbol;
          AlreadyDeclared := false;
          if Symbol = Ident
          then
            begin
              SeekLocalId(Display[ScopeLevel].Locals, PfId);
              if PfId <> nil
              then
                with PfId^ do
                  AlreadyDeclared :=
                    Forwrd and (PfClass = Klass) and (PfKind = Actual)
            end
          else MakeSpelling(DefaultSpelling);
          if not AlreadyDeclared
          then
            begin
              NewId(PfId, PfClass);
              if HeadingKind = Actual
              then
                begin
                  ISerialise(PfId);
                  OpenScope(ActualBlock)
                end
              else
                begin
                  PfId^.PfKind := Formal;
                  OpenScope(FormalBlock)
                end;
              OpenStackFrame
            end;
          Accept(Ident);
          if (Symbol = LeftParent) and AlreadyDeclared
          then
            begin
              SemanticError(140);
              DuplicateParameterScope;
              AlreadyDeclared := false
            end;
          if PfClass = Proc
          then
            begin
              CheckContext([LeftParent] + Context);
              if Symbol = LeftParent
              then
                begin
                  FormalParameterList([Semicolon] + Context);
                  PfId^.Formals := FormalList
                end
              else
                if not AlreadyDeclared then PfId^.Formals := nil;
              if not AlreadyDeclared and (HeadingKind = Actual)
              then SaveParameterScope
            end
          else
            begin
              CheckContext([LeftParent, Colon] + Context);
              if Symbol = LeftParent
              then
                begin
                  FormalParameterList([Colon, Semicolon] + Context);
                  PfId^.Formals := FormalList
                end
              else
                if not AlreadyDeclared then PfId^.Formals := nil;
              if not AlreadyDeclared and (HeadingKind = Actual)
              then SaveParameterScope;
              if Symbol = Colon
              then
                begin
                  AcceptSymbol;
                  if Symbol = Ident
                  then
                    begin
                      if AlreadyDeclared then SemanticError(141);
                      SearchId([Types], TypeId);
                      FuncType := TypeId^.IdType;
                      if FuncType <> Unknown
                      then
                        if FuncType^.Form in
                             [Scalars, Subranges, Pointers]
                        then PfId^.IdType := FuncType
                        else SemanticError(142)
                    end;
                  Accept(Ident)
                end
              else
                if not AlreadyDeclared then SemanticError(143)
            end;
          CheckContext(Context)
        end { pfheading };

      procedure CheckDirective(word: AlfaHead);

        begin
          if word = 'FORWARD     '
          then
            with BlockId^ do
              begin
                if Forwrd then SemanticError(144);
                if BlockKind = ExternalBlock 
                then Error(Missing(OtherSy), StartOfSymbol);
                Forwrd := true;
                Declaration := StartOfSymbol
              end
          else SemanticError(154)
        end { checkdirective };

      procedure DesignatePf;

        var EntryLabel: BlockLabel;

        begin
          if (Symbol = VisibleSy) or (Symbol = ExternSy)
          then
            begin
              if BlockId^.Forwrd
              then Error(Missing(OtherSy), StartOfSymbol);
              if (BlockLevel <> GlobalLevel) and (Symbol = VisibleSy)
              then SemanticError(179);
              if (BlockLevel <> GlobalLevel) and (Symbol = ExternSy)
              then SemanticError(189);
              if SameAlfa(BlockId^.Name, ProgId^.Name)
              then SemanticError(138);
              if Symbol = VisibleSy
              then BlockId^.BlockKind := VisibleBlock
              else
                with BlockId^ do
                  begin
                    BlockKind := ExternalBlock;
                    Declaration := StartOfSymbol;
                    EntryLabel := CodeBody;
                    ExternalBlockLabel(EntryLabel);
                    CodeBody := EntryLabel
                  end;
              AcceptSymbol;
              Accept(Semicolon)
            end
          else BlockId^.BlockKind := LocalBlock
        end { DesignatePf };

      begin { pfdeclaration }
        PfHeading(BlockContext + [Semicolon], Actual, BlockId);
        Accept(Semicolon);
        DesignatePf;
        if Symbol = Ident
        then
          begin
            CheckDirective(Spelling.Head);
            AcceptSymbol;
            Accept(Semicolon);
            if Symbol = PragmaSy then PragmaList(BlockContext);
            CheckContext(BlockContext)
          end
        else
          begin
            ReEnterScope(BlockId^.FormalScope);
            ReclaimStackFrame;
            if BlockId^.Forwrd then CheckContext(BlockContext);
            if Symbol = PragmaSy then PragmaList(BlockContext);
            if BlockId^.BlockKind <> ExternalBlock
            then
              begin
                with BlockId^ do
                  begin
                    EntryLabel := CodeBody;
                    OpenCodeSpace(EntryLabel);
                    CodeBody := EntryLabel;
                    Forwrd := false;
                    if Klass = Func
                    then
                      begin
                        Assignable := true;
                        SetAddressFor(BlockId)
                      end;
                    if ICLPascal
                    then Followers := BlockBegSys
                    else Followers := [ProcSy, FuncSy, BeginSy];
                    repeat

                      { for syntax error recovery }
                      Block(Semicolon, BlockId);
                      Accept(Semicolon);
                      CheckNextOrContext(Followers, BlockContext)
                    until Symbol in Followers;
                    if Klass = Func
                    then
                      begin
                        Assignable := false;
                        if not Assigned then SemanticError(146)
                      end
                  end;
                FileScope(BlockId);
                CloseCodeSpace
              end;
            CloseStackFrame;
            DisposeScope;
            CloseScope
          end
      end { pfdeclaration };

{

 11.8  Variable analysis.
 
 Variable analysis is carried out by one of two procedures:
 
 (i)  Selector, which is called when the table entry for  the  ini-
      tial variable identifier has already been located; or
 
 (ii) Variable, which is  called  when  no  preliminary  identifier
      checking has occurred.
 
 In either case the type of the variable  is  left  in  the  global
 variable  VarType.  Additional information on the accessibility of
 the variable is left in the following global flags:
 
 SimpleVar   the variable is a simple variable
 
 PackedVar   the variable is a component of a packed structure
 
 TagVar      the variable is a tag field
 
 NewRecVar   the variable is a complete record created by 'new'
 
 When TagVar is true, the global VntSelector holds a pointer to the
 the type descriptor for the variant part containing the tag field.

                                                                     }

    { The following forward procedure declaration is required }
    { by the analysis of indexed variables in Selector. The   }
    { body of the procedure is located in Section 11.10.      }

    procedure Selector(SelectContext: SetOfSymbols;
                       VarIdEntry: IdEntry);

      var
        LocalType: TypEntry;
        LocalId: IdEntry;
        LowerBound, UpperBound: ObjectValue;

      begin { selector }
        PackedVar := false;
        SimpleVar := true;
        TagVar := false;
        NewRecVar := false;
        with VarIdEntry^ do
          begin
            LocalType := IdType;
            case Klass of
              PresetVars, Vars, ReadOnlyVars :
                if IsConformant(LocalType)
                then StackReference(true, VarAddress)
                else
                  StackReference
                    ((VarKind = VarParam) or (VarKind = ExternalVar),
                     VarAddress);
              Field :
                begin
                  SimpleVar := false;
                  TagVar := Tag;
                  WithReference(LevelFound);
                  with Display[LevelFound] do
                    begin
                      PackedVar := FieldsPacked;
                      with RecordType^ do
                        if VarPart <> nil
                        then
                          if VariantField(VarPart, VarIdEntry)
                          then DoVariantChecks(VarPart, VarIdEntry);
                      if TagVar
                      then
                        VntSelector :=
                          TaggedVarPart(RecordType^.VarPart, VarIdEntry)
                    end;
                  FieldReference(Offset, TagVar)
                end;
              Func :
                if PfDecKind = Predefined
                then SemanticError(147)
                else
                  if PfKind = Formal
                  then SemanticError(148)
                  else
                    if Assignable
                    then
                      begin
                        StackReference(false, Result);
                        Assigned := true
                      end
                    else SemanticError(149)
            end { case }
          end { with };
        if VarIdEntry^.Klass = Func
        then CheckContext(SelectContext)
        else CheckContext(SelectSymbols + SelectContext);
        while Symbol in SelectSymbols do
          begin
            NewRecVar := false;
            case Symbol of
              LeftBracket :
                begin
                  repeat
                    if not IsConformant(LocalType)
                    then EnsureFormIs(Arrays, LocalType);
                    AcceptSymbol;
                    Expression([Comma, RightBracket] + SelectContext);
                    EnsureOrdinal(ExpType);
                    with LocalType^ do
                      if Compatible(IndexOf(LocalType), ExpType)
                      then
                        begin
                          if Form = CAPSchema
                          then
                            WithSchema(LocalType, InxCAPReference)
                          else
                            begin
                              GetBounds
                                (InxType, LowerBound, UpperBound);
                              InxReference
                                (PackedArray, LowerBound, UpperBound,
                                 AelType^.Representation)
                            end;
                          PackedVar := PackingOf(LocalType)
                        end
                      else SemanticError(160);
                    LocalType := ElementOf(LocalType)
                  until Symbol <> Comma;
                  Accept(RightBracket)
                end;
              Period :
                begin
                  EnsureFormIs(Records, LocalType);
                  PackedVar := LocalType^.PackedRecord;
                  AcceptSymbol;
                  if Symbol = Ident
                  then
                    begin
                      SeekLocalId(LocalType^.FieldScope, LocalId);
                      if LocalId = nil
                      then
                        begin
                          SemanticError(100);
                          LocalType := Unknown
                        end
                      else
                        begin
                          with LocalType^ do
                            if VarPart <> nil
                            then
                              if VariantField(VarPart, LocalId)
                              then DoVariantChecks(VarPart, LocalId);
                          with LocalId^ do
                            begin
                              TagVar := Tag;
                              if TagVar
                              then
                                VntSelector :=
                                  TaggedVarPart
                                    (LocalType^.VarPart, LocalId);
                              FieldReference(Offset, TagVar);
                              LocalType := IdType
                            end
                        end
                    end;
                  Accept(Ident)
                end;
              Arrow :
                begin
                  if LocalType <> Unknown
                  then
                    with LocalType^ do
                      if Form = Pointers
                      then
                        begin
                          LocalType := DomainType;
                          PackedVar := false;
                          NewRecVar := (LocalType^.Form = Records);
                          PnterReference
                        end
                      else
                        if Form = Files
                        then
                          begin
                            LocalType := FelType;
                            PackedVar := PackedFile;
                            BufferReference
                              (PackedVar, TextFile,
                               FelType^.Representation)
                          end
                        else SemanticError(161);
                  AcceptSymbol
                end;
              Shriek:
                begin
                  AcceptSymbol;
                  if Symbol = Ident
                  then
                    begin
                      SearchId([Types], LocalId);
                      LocalType := LocalId^.IdType
                    end;
                  Accept(Ident)
                end
            end;
            SimpleVar := false;
            CheckContext(SelectSymbols + SelectContext)
          end;
        VarType := LocalType
      end { selector };

    procedure Variable(Context: SetOfSymbols; ClassOfId: SetOfIdClass);

      var VarId: IdEntry;

      begin
        if Symbol = Ident
        then SearchId(ReadableVars, VarId) else VarId := DummyVarId;
        Accept(Ident);
        Selector(Context, VarId);
        Threaten(VarId, ClassOfId)
      end { variable };

    procedure VariableOrType{Context: SetOfSymbols};

      var TypeId: IdEntry;

      begin
        TypeId := nil;
        if Symbol = Ident then SearchGlobals(Types, TypeId);
        if TypeId <> nil
        then
          begin
            VarType := TypeId^.IdType;
            AcceptSymbol
          end
        else Variable(Context, ReadableVars)
      end { VariableOrType };

{

 11.9  Procedure and function call analysis.
 
 Procedure  and function calls are processed by procedure Call  and
 its subprocedures CallStandard and CallUserDefined as follows.
 
 The  procedure CallStandard analyses calls  to  all  the  required
 (standard) functions and procedures of Pascal. A variety of ad-hoc
 techniques are employed to check the number and validity  of   the
 actual parameters.
 
 The procedure CallUserDefined analyses  calls  to  procedures  and
 functions  declared  within the program.  The analysis  of  actual
 parameters  is controlled  by the formal list which is attached to
 the   procedure   or function's  idrec.   Actual-formal correspon-
 dence is established on the basis of position and is checked using
 the  attributes  held in the formal list, by one of the procedures
 ActualValue, ActualVariable, ActualProcedure, and  ActualFunction.
 The  first  two  also check conformance of actual array parameters
 passed to a conformant array schema.

                                                                     }

    procedure Call(CallContext: SetOfSymbols; PfId: IdEntry);

      procedure CallStandard(WhichPf: StdProcFuncs);

        { Analyses all calls on standard }
        { procedures and functions.      }

        var First, Last: ObjectValue;

        procedure ResetOrRewriteOrAppend;

          { Analyses parameter list for }
          { reset or rewrite or append. }

          var
            Context: SetOfSymbols;
            IdFound: IdEntry;
            Format: IOFormat;
            FileType: TypEntry;

          begin
            Context := CallContext + [RightParent];
            if ICLPascal then Context := Context + [Comma];
            Variable(Context, WriteableVars);
            EnsureFormIs(Files, VarType);
            FileType := VarType;
            SelectFile(FileType);
            Format := Standard;
            if Symbol = Comma
            then
              begin
                AcceptSymbol;
                Format := Named;
                if Symbol = Ident
                then
                  begin
                    SearchScopes(ScopeLevel, 0, IdFound);
                    if IdFound <> nil
                    then
                      if Compatible(IdFound^.IdType, BoolType)
                      then Format := Flagged
                  end
              end;
            if Format = Named
            then
              begin
                Expression(Context);
                if not String(ExpType) then SemanticError(114);
                if Symbol = Comma then AcceptSymbol
              end;
            CheckContext([Ident, RightParent] + Context);
            if Symbol = Ident
            then
              begin
                Variable([RightParent] + CallContext, WriteableVars);
                if not Compatible(VarType, BoolType)
                then SemanticError(106);
                if PackedVar then SemanticError(289);
                if TagVar then SemanticError(290);
                if Format = Named then Format := Full
              end;
            SelectFile(FileType);
            FileOperation(WhichPf, Format);
            DiscardFile
          end { ResetRewriteOrAppend };

        procedure CloseProcedure;

          { Analyses the parameter list }
          { for get or put.             }

          begin
            Variable([RightParent] + CallContext, WriteableVars);
            EnsureFormIs(Files, VarType);
            SelectFile(VarType);
            FileOperation(WhichPf, Standard);
            DiscardFile
          end { closeprocedure };

        procedure GetOrPut;

          { Analyses the parameter list }
          { for get or put.             }

          begin
            Variable([RightParent] + CallContext, WriteableVars);
            EnsureFormIs(Files, VarType);
            SelectFile(VarType);
            FileOperation(WhichPf, Standard);
            DiscardFile
          end { getorput };

        procedure SelectInput;

          { Default action when read, readln, }
          { eof or eoln is called without an  }
          { explicit textfile parameter.      }

          begin
            if InputFile = nil
            then SemanticError(232)
            else
              with InputFile^ do
                begin
                  StackReference((VarKind = VarParam), VarAddress);
                  SelectFile(TextType)
                end
          end;

        procedure SelectOutput;

          { Default action when write or writeln is        }
          { called without an explicit textfile parameter. }

          begin
            if OutputFile = nil
            then SemanticError(233)
            else
              with OutputFile^ do
                begin
                  StackReference((VarKind = VarParam), VarAddress);
                  SelectFile(TextType)
                end
          end;

        procedure ReadProcedure;

          { Analyses parameter list of read or readln. }

          label 1;

          var
            FileDetermined: Boolean;
            FileType: TypEntry;

          procedure InputVariable;

            { Analyses any parameter of read or readln }
            { including the optional initial textfile. }

            procedure SimpleRead;

              begin
                with FileType^ do
                  begin
                    ReadBuffer;
                    CheckAssignment(VarType, FelType);
                    Assign(VarType^.Representation);
                    FileOperation(Getp, Standard)
                  end
              end { simpleread };

            procedure NumericRead;

              begin
                if Compatible(VarType, RealType)
                then ReadNumeric(RealKind)
                else
                  if Compatible(VarType, IntType)
                  then
                    begin
                      ReadNumeric(IntKind);
                      CheckAssignment(VarType, IntType)
                    end
                  else SemanticError(163);
                Assign(VarType^.Representation)
              end { numericread };

            begin
              Variable
                ([Comma, RightParent] + CallContext, WriteableVars);
              if VarType^.Form = Files
              then
                if FileDetermined
                then SemanticError(162)
                else
                  begin
                    case WhichPf of
                      Readp :
                        if Symbol <> Comma
                        then Error(Missing(Comma), StartOfSymbol);
                      Readlnp :
                        if not Compatible(VarType, TextType)
                        then SemanticError(177)
                    end;
                    FileType := VarType;
                    SelectFile(FileType)
                  end
              else
                begin
                  if not FileDetermined
                  then
                    begin
                      FileType := TextType;
                      SelectInput
                    end;
                  if (FileType = TextType) and
                     not Compatible(VarType, CharType)
                  then NumericRead else SimpleRead
                end;
              FileDetermined := true
            end { inputvariable };

          begin
            FileDetermined := false;
            while true do
              begin
                InputVariable;
                if Symbol <> Comma then goto 1;
                AcceptSymbol
              end;
            1 :
              if WhichPf = Readlnp then ReadLayout;
            DiscardFile
          end { readprocedure };

        procedure WriteProcedure;

          { analyses parameter list of write or writeln }

          label 1;

          var
            FileDetermined: Boolean;
            FileType: TypEntry;

          procedure OutputValue;

            { Analyses any parameter of write or writeln }
            { including the optional initial textfile.   }
            { N.B. It is assumed that the analyser for   }
            {      expression leaves a file variable     }
            {      operand in reference form, without    }
            {      attempting to 'evaluate' it.          }

            var
              Exp1Type: TypEntry;
              WriteKind: OutputKind;
              Format: FormatKind;

            procedure WriteOtherFile;

              begin
                with FileType^ do
                  begin
                    CheckAssignment(FelType, Exp1Type);
                    WriteBuffer;
                    FileOperation(Putp, Standard)
                  end
              end { writeotherfile };

            procedure WriteTextFile;

              begin
                if Compatible(Exp1Type, CharType)
                then WriteKind := CharKind
                else
                  if Compatible(Exp1Type, IntType)
                  then WriteKind := IntKind
                  else
                    if Compatible(Exp1Type, RealType)
                    then WriteKind := RealKind
                    else
                      if Compatible(Exp1Type, BoolType)
                      then WriteKind := BoolKind
                      else
                        if Compatible(Exp1Type, WordType)
                        then WriteKind := WordKind
                        else
                          if String(Exp1Type)
                          then WriteKind := StringKind
                          else
                            if CAPString(Exp1Type)
                            then WriteKind := CAPKind
                            else
                              begin
                                SemanticError(164);
                                WriteKind := DefaultKind
                              end;
                if Symbol = Colon
                then
                  begin
                    AcceptSymbol;
                    Expression
                      ([Comma, Colon, RightParent] + CallContext);
                    if not Compatible(ExpType, IntType)
                    then SemanticError(165);
                    if Symbol = Colon
                    then
                      begin
                        AcceptSymbol;
                        Expression([Comma, RightParent] + CallContext);
                        if not Compatible(ExpType, IntType)
                        then SemanticError(166);
                        if not (Compatible(Exp1Type, RealType) or
                                Compatible(Exp1Type, WordType))
                        then SemanticError(167);
                        Format := Fixed
                      end
                    else Format := Floating
                  end
                else Format := Default;
                case WriteKind of
                  IntKind, RealKind, CharKind, BoolKind, WordKind :
                    WriteScalars(WriteKind, Format);
                  StringKind :
                    WriteString(Exp1Type^.InxType^.Max, Format);
                  CAPKind:
                    WriteCAPString(Exp1Type^.HighBound, Format);
                  DefaultKind :
                end
              end { writetextfile };

            begin
              Expression([Comma, Colon, RightParent] + CallContext);
              Exp1Type := ExpType;
              if Exp1Type^.Form = Files
              then
                if FileDetermined
                then SemanticError(162)
                else
                  begin
                    case WhichPf of
                      Writep :
                        if Symbol <> Comma
                        then Error(Missing(Comma), StartOfSymbol);
                      Writelnp :
                        if not Compatible(VarType, TextType)
                        then SemanticError(178)
                    end;
                    FileType := Exp1Type;
                    SelectFile(FileType)
                  end
              else
                begin
                  if not FileDetermined
                  then
                    begin
                      FileType := TextType;
                      SelectOutput
                    end;
                  if FileType = TextType
                  then WriteTextFile else WriteOtherFile
                end;
              FileDetermined := true
            end { outputvalue };

          begin
            FileDetermined := false;
            while true do
              begin
                OutputValue;
                if Symbol <> Comma then goto 1;
                AcceptSymbol
              end;
            1 :
              if WhichPf = Writelnp
              then
                begin
                  StackConstant(LineFeed);
                  WriteLayout{(Standard)}
                end;
            DiscardFile
          end { writeprocedure };

        procedure PageProcedure;

          { Analyses parameter list of page. }

          begin
            Variable([RightParent] + CallContext, WriteableVars);
            if Compatible(VarType, TextType)
            then
              begin
                SelectFile(TextType);
                StackConstant(PageThrow);
                WriteLayout{(Standard)};
                DiscardFile
              end
            else SemanticError(168)
          end;

        procedure CheckArray(PackingRequired: Boolean);

          begin
            if VarType^.Form <> CAPSchema
            then EnsureFormIs(Arrays, VarType);
            if PackingRequired <> PackingOf(VarType)
            then
              if PackingRequired
              then SemanticError(169) else SemanticError(170)
          end { checkarray };

        procedure Repack(WhichOp: StdProcFuncs;
                         UPType, PKType: TypEntry);

          var
            UpIndex, PKIndex, UPElem, PKElem: TypEntry;
            UPRep, PKRep: TypeRepresentation;
            PKLow, PKHigh, UPLow, UPHigh: ObjectValue;

          begin
            UpIndex := IndexOf(UPType);
            PKIndex := IndexOf(PKType);
            UPElem := ElementOf(UPType);
            PKElem := ElementOf(PKType);
            if not Identical(UPElem, PKElem)
            then SemanticError(171)
            else
              begin
                GetBounds(UpIndex, UPLow, UPHigh);
                GetBounds(PKIndex, PKLow, PKHigh);
                UPRep := UPElem^.Representation;
                PKRep := PKElem^.Representation;
                if IsConformant(UPType)
                then
                  if IsConformant(PKType)
                  then
                    CAPCAPOp
                      (WhichOp, UPType^.LowBound,
                       UPType^.HighBound, UPType^.Representation,
                       UPRep, PKRep, PKType^.LowBound,
                       PKType^.HighBound)
                  else
                    CAPArrayOp
                      (WhichOp, UPType^.LowBound,
                       UPType^.HighBound, UPType^.Representation,
                       UPRep, PKRep, PKLow, PKHigh)
                else
                  if IsConformant(PKType)
                  then
                    ArrayCAPOp
                      (WhichOp, UPLow, UPHigh, UPRep, PKRep,
                       PKType^.LowBound, UPType^.HighBound)
                  else
                    ArrayArrayOp
                      (WhichOp, UPLow, UPHigh, UPRep, PKRep, PKLow,
                       PKHigh)
              end
          end { repack };

        procedure PackProcedure;

          var UnpackedType, PackedType: TypEntry;

          begin
            Variable(CallContext + [Comma, RightParent], ReadableVars);
            CheckArray(false);
            UnpackedType := VarType;
            Accept(Comma);
            Expression(CallContext + [Comma, RightParent]);
            EnsureOrdinal(ExpType);
            if not Compatible(ExpType, IndexOf(UnpackedType))
            then SemanticError(172);
            Accept(Comma);
            Variable(CallContext + [RightParent], WriteableVars);
            CheckArray(true);
            PackedType := VarType;
            Repack(Packp, UnpackedType, PackedType)
          end { packprocedure };

        procedure UnpackProcedure;

          var UnpackedType, PackedType: TypEntry;

          begin
            Variable(CallContext + [Comma, RightParent], ReadableVars);
            CheckArray(true);
            PackedType := VarType;
            Accept(Comma);
            Variable(CallContext + [Comma, RightParent], WriteableVars);
            CheckArray(false);
            UnpackedType := VarType;
            Accept(Comma);
            Expression(CallContext + [RightParent]);
            EnsureOrdinal(ExpType);
            if not Compatible(ExpType, IndexOf(UnpackedType))
            then SemanticError(172);
            Repack(Unpackp, UnpackedType, PackedType)
          end { unpackprocedure };

        procedure RequestVariant(FieldFound: TypEntry);

          var
            ThisVariant: TypEntry;
            TagVal: ObjectValue;
            TagValType: TypEntry;
            StructureKnown: Boolean;
            SearchState: (Match, NoMatch, StillLooking);

          begin
            StructureKnown := true;
            while Symbol = Comma do
              begin
                AcceptSymbol;
                ConstExpression
                  ([Comma, RightParent] + CallContext, TagValType,
                   TagVal);
                EnsureOrdinal(TagValType);
                if StructureKnown
                then
                  if FieldFound = nil
                  then
                    begin
                      SemanticError(173);
                      StructureKnown := false
                    end
                  else
                    if Compatible(FieldFound^.TagType, TagValType)
                    then
                      begin
                        SearchState := StillLooking;
                        ThisVariant := FieldFound^.FirstVariant;
                        repeat
                          if ThisVariant <> nil
                          then
                            with ThisVariant^ do
                              if InRange(VariantValue1, TagVal, VariantValue2)
                              then SearchState := Match
                              else ThisVariant := NextVariant
                          else
                            begin
                              ThisVariant := FieldFound^.DefaultVariant;
                              if ThisVariant <> nil
                              then SearchState := Match
                              else SearchState := NoMatch
                            end
                        until SearchState <> StillLooking;
                        if SearchState = Match
                        then
                          with ThisVariant^ do
                            begin
                              TailorRequest
                                (FieldFound^.Representation,
                                 Representation);
                              FieldFound := SubVarPart
                            end
                        else
                          begin
                            SemanticError(173);
                            StructureKnown := false
                          end
                      end
                    else
                      begin
                        SemanticError(174);
                        StructureKnown := false
                      end;

              end { while }
          end;

        procedure HeapProcedure;

          { Analyses parameter list for new or dispose. }

          var
            ThisVarPart: TypEntry;
            IdFound: IdEntry;

          begin
            ThisVarPart := nil;
            if WhichPf = Newp
            then
              Variable
                ([Comma, RightParent] + CallContext, WriteableVars)
            else
              begin
                if Symbol = Ident
                then
                  begin
                    SearchScopes(ScopeLevel, 0, IdFound);
                    if IdFound <> nil
                    then
                      if IdFound^.Klass = ReadOnlyVars
                      then SemanticError(157)
                  end;
                Expression([Comma, RightParent] + CallContext);
                VarType := ExpType
              end;
            EnsureFormIs(Pointers, VarType);
            with VarType^ do
              begin
                HeapRequest(DomainType^.Representation);
                if DomainType^.Form = Records
                then
                  begin
                    ThisVarPart := DomainType^.VarPart;
                    RequestVariant(ThisVarPart)
                  end
              end;
            HeapOperation(WhichPf)
          end { heapprocedure };

        procedure SizeFunction;

          var ThisVarPart: TypEntry;

          begin
            VariableOrType([Comma, RightParent] + CallContext);
            SizeRequest(VarType^.Representation);
            if Symbol = Comma
            then
              begin
                EnsureFormIs(Records, VarType);
                ThisVarPart := VarType^.VarPart;
                RequestVariant(ThisVarPart)
              end;
            IntFunction(Sizef);
            ExpType := IntType
          end { sizefunction };

        procedure LinesProcedure;

          { Analyses parameter list of lines. }

          begin
            Expression([Comma, RightParent] + CallContext);
            if ExpType^.Form = Files
            then
              begin
                if not Compatible(VarType, TextType)
                then SemanticError(179);
                SelectFile(TextType);
                Accept(Comma);
                Expression([RightParent] + CallContext)
              end
            else SelectOutput;
            StackConstant(LineFeed);
            WriteLayout{(Repeated)};
            DiscardFile
          end;

        procedure DateOrTime;

          var ValidType: Boolean;

          begin
            Variable([RightParent] + CallContext, WriteableVars);
            ValidType := false;
            if String(VarType)
            then
              ValidType := SameValue(VarType^.InxType^.Max, EightValue);
            if not ValidType then SemanticError(292);
            if PackedVar then SemanticError(288);
            StampProcedure(WhichPf)
          end { dateortime };

        begin { callstandard }
          if Symbol = LeftParent
          then
            begin
              AcceptSymbol;
              if PfId^.Klass = Proc
              then

                { standard procedure with parameters }

                case WhichPf of
                  Getp, Putp : GetOrPut;
                  Closep : CloseProcedure;
                  Appendp, Resetp, Rewritep : ResetOrRewriteOrAppend;
                  Readlnp, Readp : ReadProcedure;
                  Writelnp, Writep : WriteProcedure;
                  Pagep : PageProcedure;
                  Newp, Disposep : HeapProcedure;
                  Packp : PackProcedure;
                  Unpackp : UnpackProcedure;
                  Linesp : LinesProcedure;
                  Datep, Timep : DateOrTime
                end
              else
                begin

                  { standard function with an argument }

                  if WhichPf <= Eolnf
                  then
                    begin
                      Expression([RightParent] + CallContext);
                      case WhichPf of
                        Absf, Sqrf :
                          if Compatible(ExpType, IntType)
                          then IntFunction(WhichPf)
                          else
                            if Compatible(ExpType, RealType)
                            then RealFunction(WhichPf)
                            else
                              begin
                                SemanticError(109);
                                ExpType := IntType
                              end;
                        Oddf :
                          begin
                            if not (Compatible(ExpType, IntType) or
                                    Compatible(ExpType, WordType))
                            then SemanticError(107);
                            IntFunction(Oddf);
                            ExpType := BoolType
                          end;
                        Succf, Predf :
                          begin
                            EnsureOrdinal(ExpType);
                            IntFunction(WhichPf);
                            GetBounds(ExpType, First, Last);
                            RangeCheck(First, Last)
                          end;
                        Ordf :
                          begin
                            EnsureOrdinal(ExpType);
                            IntFunction(Ordf);
                            ExpType := IntType
                          end;
                        Chrf :
                          begin
                            if not (Compatible(ExpType, IntType) or
                                    Compatible(ExpType, WordType))
                            then SemanticError(107);
                            RangeCheck(MinCharValue, MaxCharValue);
                            IntFunction(Chrf);
                            ExpType := CharType
                          end;
                        Truncf, Roundf :
                          begin
                            if not Compatible(ExpType, RealType)
                            then SemanticError(108);
                            RealFunction(WhichPf);
                            ExpType := IntType
                          end;
                        Sinf, Cosf, Expf, Lnf, Sqrtf, Arctanf :
                          begin
                            if Compatible(ExpType, IntType)
                            then FloatInteger(TopOfStack)
                            else
                              if not Compatible(ExpType, RealType)
                              then SemanticError(109);
                            RealFunction(WhichPf);
                            ExpType := RealType
                          end;
                        Eoff :
                          begin
                            EnsureFormIs(Files, ExpType);
                            SelectFile(ExpType);
                            FileFunction(Eoff);
                            DiscardFile;
                            ExpType := BoolType
                          end;
                        Eolnf :
                          begin
                            if not Compatible(ExpType, TextType)
                            then SemanticError(176);
                            SelectFile(TextType);
                            FileFunction(Eolnf);
                            DiscardFile;
                            ExpType := BoolType
                          end
                      end
                    end
                  else { ICL FUNCTIONS }
                    begin
                      case WhichPf of
                        MinValf, MaxValf :
                          begin
                            VariableOrType
                              ([RightParent] + CallContext);
                            EnsureOrdinal(VarType);
                            GetBounds(VarType, First, Last);
                            MaxMinFunction(WhichPf, First, Last);
                            ExpType := VarType
                          end;
                        Wrdf :
                          begin
                            Expression([RightParent] + CallContext);
                            EnsureOrdinal(ExpType);
                            WordFunction(Wrdf);
                            ExpType := WordType
                          end;
                        Intf :
                          begin
                            Expression([RightParent] + CallContext);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105);
                            IntFunction(Intf);
                            ExpType := IntType
                          end;
                        Sizef : SizeFunction;
                        Ptrf, CPtrf :
                          begin
                            Variable
                              ([RightParent] + CallContext,
                               ReadableVars);
                            PnterFunction(WhichPf);
                            ExpType := PtrType
                          end;
                        AndWf, OrWf, NeqWf :
                          begin
                            Expression
                              ([RightParent, Comma] + CallContext);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105);
                            Accept(Comma);
                            Expression([RightParent] + CallContext);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105);
                            WordFunction(WhichPf);
                            ExpType := WordType
                          end;
                        NotWf :
                          begin
                            Expression([RightParent] + CallContext);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105);
                            WordFunction(NotWf);
                            ExpType := WordType
                          end;
                        ShWf, RotWf :
                          begin
                            Expression
                              ([Comma, RightParent] + CallContext);
                            if not Compatible(ExpType, WordType)
                            then SemanticError(105);
                            Accept(Comma);
                            Expression([RightParent] + CallContext);
                            if not Compatible(ExpType, IntType)
                            then SemanticError(107);
                            WordFunction(WhichPf);
                            ExpType := WordType
                          end
                      end
                    end
                end;
              Accept(RightParent)
            end
          else

            { parameterless procedure or function call }

            if WhichPf in [Readlnp, Writelnp, Pagep, Eolnf, Eoff]
            then
              begin
                case WhichPf of
                  Readlnp :
                    begin
                      SelectInput;
                      ReadLayout;
                      DiscardFile
                    end;
                  Writelnp :
                    begin
                      SelectOutput;
                      StackConstant(LineFeed);
                      WriteLayout{(Standard)};
                      DiscardFile
                    end;
                  Pagep :
                    begin
                      SelectOutput;
                      StackConstant(PageThrow);
                      WriteLayout{(Standard)};
                      DiscardFile
                    end;
                  Eolnf, Eoff :
                    begin
                      SelectInput;
                      FileFunction(WhichPf);
                      DiscardFile;
                      ExpType := BoolType
                    end
                end { case}
              end
            else Error(Missing(LeftParent), StartOfSymbol)
        end {  callstandard };

      procedure CallUserDefined;

        { Analyses all calls to user defined }
        { procedures and functions.          }

        var
          ThisFormal: FormalEntry;
          LastActual: TypEntry;
          ToBePassed: Boolean;

        procedure PfIdentifier(PfIdent: IdEntry);

          var CodeOfBody: BlockLabel;

          begin
            with PfIdent^ do
              if PfKind = Actual
              then
                begin
                  CodeOfBody := CodeBody;
                  StackActualBlock(CodeOfBody);
                  CodeBody := CodeOfBody
                end
              else StackFormalBlock(FAddress)
          end { pfidentifier };

        procedure ActualProcedure;

          var ActualId: IdEntry;

          begin
            if Symbol = Ident
            then
              begin
                SearchId([Proc], ActualId);
                if ActualId^.PfDecKind = Predefined
                then SemanticError(180)
                else
                  if not Congruent
                           (ThisFormal^.ItsFormals, ActualId^.Formals)
                  then SemanticError(182)
                  else
                    begin
                      PfIdentifier(ActualId);
                      PassBlock
                    end
              end;
            Accept(Ident);
            CheckContext([Comma, RightParent] + CallContext)
          end { actualprocedure };

        procedure ActualFunction;

          var ActualId: IdEntry;

          begin
            if Symbol = Ident
            then
              begin
                SearchId([Func], ActualId);
                if ActualId^.PfDecKind = Predefined
                then SemanticError(181)
                else
                  if not Congruent
                           (ThisFormal^.ItsFormals, ActualId^.Formals)
                     or
                     not Identical
                           (ActualId^.IdType, ThisFormal^.FormalType)
                  then SemanticError(183)
                  else
                    begin
                      PfIdentifier(ActualId);
                      PassBlock
                    end
              end;
            Accept(Ident);
            CheckContext([Comma, RightParent] + CallContext)
          end { actualfunction };

        procedure CheckConformance(Actual, Formal: TypEntry);

          var InxLow, InxHigh, ActLow, ActHigh: ObjectValue;

          begin
            if (Actual <> Unknown) and (Formal <> Unknown)
            then
              if not IsConformant(Formal) or
                 not (Actual^.Form in [Arrays, CAPSchema])
              then SemanticError(251)
              else
                if not Compatible(IndexOf(Actual), IndexOf(Formal)) or
                   (PackingOf(Actual) <> PackingOf(Formal))
                then SemanticError(251)
                else
                  begin
                    if ToBePassed
                    then
                      begin
                        GetBounds(IndexOf(Formal), InxLow, InxHigh);
                        if IsConformant(Actual)
                        then
                          with Actual^ do
                            PassCAPBounds
                              (LowBound, HighBound,
                               Formal^.LowBound, Formal^.HighBound,
                               InxLow, InxHigh, Representation)
                        else
                          begin
                            GetBounds(IndexOf(Actual), ActLow, ActHigh);
                            PassArrayBounds
                              (ActLow, ActHigh,
                               Formal^.LowBound, Formal^.HighBound,
                               InxLow, InxHigh,
                               Actual^.Representation,
                               Actual^.PackedArray)
                          end
                      end;
                    if MultiLevel(Formal)
                    then
                      CheckConformance
                        (ElementOf(Actual), ElementOf(Formal))
                    else
                      begin
                        if ElementOf(Actual) <> ElementOf(Formal)
                        then SemanticError(251);
                        ToBePassed := false
                      end
                  end
          end { checkconformance };

        procedure ActualVariable;

          begin
            Variable([Comma, RightParent] + CallContext, WriteableVars);
            if PackedVar then SemanticError(184);
            if TagVar then SemanticError(185);
            if NewRecVar
            then TailoredFactorCheck(VarType^.Representation);
            with ThisFormal^ do
              if IsConformant(FormalType)
              then
                begin
                  CheckConformance(VarType, FormalType);
                  if not Identical(LastActual, VarType)
                  then SemanticError(252) else LastActual := VarType
                end
              else
                if not Identical(VarType, FormalType)
                then SemanticError(186);
            PassReference(MayBeInsecure)
          end { actualvariable };

        procedure ActualReadOnly;

          begin
            with ThisFormal^ do
              begin
                if ICLPascal and StringFound
                then
                  begin
                    Expression([Comma, RightParent] + CallContext);
                    VarType := ExpType;
                    if not IsConformant(FormalType)
                    then
                      begin
                        if not Compatible(VarType, FormalType)
                        then SemanticError(283);
                        VarType := FormalType;
                        MakeAuxiliary(VarType^.Representation)
                      end
                  end
                else
                  begin
                    Variable
                      ([Comma, RightParent] + CallContext, ReadableVars);
                    if PackedVar then SemanticError(284);
                    if NewRecVar
                    then TailoredFactorCheck(VarType^.Representation)
                  end;
                if IsConformant(FormalType)
                then
                  begin
                    CheckConformance(VarType, FormalType);
                    if not Identical(LastActual, VarType)
                    then SemanticError(252) else LastActual := VarType
                  end
                else
                  if not Identical(VarType, FormalType)
                  then SemanticError(286);
              PassReference(Secure)
            end
          end { actualreadonly };

        procedure ActualValue;

          begin
            Expression([Comma, RightParent] + CallContext);
            if ThisFormal <> nil
            then
              with ThisFormal^ do
                if IsConformant(FormalType)
                then
                  if IsConformant(ExpType)
                  then SemanticError(253)
                  else
                    if EmbeddedFile(ExpType)
                    then SemanticError(150)
                    else
                      begin
                        CheckConformance(ExpType, FormalType);
                        if not Identical(LastActual, ExpType)
                        then SemanticError(252)
                        else LastActual := ExpType;
                        MakeAuxiliary(ExpType^.Representation);
                        PassReference(Secure)
                      end
                else
                  begin
                    CheckAssignment(FormalType, ExpType);
                    PassValue(FormalType^.Representation)
                  end
          end { actualvalue };

        procedure NewArraySchema;

          begin
            LastActual := Unknown;
            ToBePassed := true;
            StartBoundPairs;
            ThisFormal := ThisFormal^.Next
          end { newarrayschema };

        begin { calluserdefined }
          PfIdentifier(PfId);
          ThisFormal := PfId^.Formals;
          OpenParameterList(PfId^.Klass);
          if Symbol = LeftParent
          then
            begin
              repeat

                { for each actual parameter }

                AcceptSymbol;
                if ThisFormal <> nil
                then
                  begin
                    if ThisFormal^.Parm = BoundParm then NewArraySchema;
                    with ThisFormal^ do
                      case Parm of
                        ValueParm : ActualValue;
                        VarParm : ActualVariable;
                        ProcParm : ActualProcedure;
                        FuncParm : ActualFunction;
                        ReadOnlyParm : ActualReadOnly
                      end
                  end
                else
                  begin
                    SemanticError(187);

                    { for recovery purposes ... }

                    ActualValue
                  end;
                if ThisFormal <> nil then ThisFormal := ThisFormal^.Next
              until Symbol <> Comma;
              Accept(RightParent)
            end { parameter list };
          if ThisFormal <> nil then SemanticError(187);
          CloseParameterList;
          CallBlock;
          if PfId^.Klass = Func
          then
            begin
              TakeResult(PfId^.IdType^.Representation);
              ExpType := PfId^.IdType
            end
        end { calluserdefined };

      begin { call }
        if PfId^.PfDecKind = Predefined
        then CallStandard(PfId^.PfIndex) else CallUserDefined
      end { call };

{

 11.10 Expression analysis.
 
 Expression analysis is carried out by the procedure SubExpression,
 which  leaves  the  type  of the expression analysed in the global
 ExpType.  In practice it is called by one of two routes:
 
 (i)  when an assignable value is required as result it  is  called
      via the procedure Expression;
 
 (ii) when a Boolean condition is required (by a control statement)
      it is called via the procedure BooleanExpression.
 
 These differ in the code generation interface calls  they  produce
 as explained in module 6.

                                                                     }

    procedure SubExpression(ExpContext: SetOfSymbols);

      var
        LeftType: TypEntry;
        RelOperator: OpType;

      procedure SimpleExpression(SimpleExpContext: SetOfSymbols);

        var
          LeftType: TypEntry;
          Sign, AddOperator: OpType;
          Signed: Boolean;

        procedure PlusMinusMul(FirstOpType: TypEntry; Operator: OpType);

          { semantic analysis of operators +,-, and * }
          { assuming operand types are given by       }
          { firstoptype and exptype respectively, and }
          { resetting exptype to describe the result  }

          begin
            if (FirstOpType^.Form = Sets) or (ExpType^.Form = Sets)
            then
              begin
                if Compatible(FirstOpType, ExpType)
                then
                  begin
                    if ExpType = Unknown then ExpType := FirstOpType
                  end
                else
                  begin
                    SemanticError(191);
                    ExpType := EmptyType
                  end;
                BinarySetOperation(Operator)
              end
            else
              if Compatible(FirstOpType, IntType) and
                 Compatible(ExpType, IntType)
              then
                begin
                  ExpType := IntType;
                  BinaryIntegerOperation(Operator)
                end
              else
                if Compatible(FirstOpType, WordType) and
                   Compatible(ExpType, WordType)
                then
                  begin
                    if Operator = Mul
                    then
                      begin
                        SemanticError(190);
                        ExpType := EmptyType
                      end
                    else ExpType := WordType;
                    BinaryIntegerOperation(Operator)
                  end
                else
                  begin
                    if Compatible(FirstOpType, IntType)
                    then
                      begin
                        FirstOpType := RealType;
                        FloatInteger(NextToTop)
                      end;
                    if Compatible(ExpType, IntType)
                    then
                      begin
                        ExpType := RealType;
                        FloatInteger(TopOfStack)
                      end;
                    if Compatible(FirstOpType, RealType) and
                       Compatible(ExpType, RealType)
                    then ExpType := RealType
                    else
                      begin
                        SemanticError(190);
                        ExpType := IntType
                      end;
                    BinaryRealOperation(Operator)
                  end
          end { plusminusmul };

        procedure Term(TermContext: SetOfSymbols);

          var
            LeftType: TypEntry;
            MulOperator: OpType;

          procedure Factor(FactorContext: SetOfSymbols);

            var
              FirstId: IdEntry;
              RecastType: TypEntry;
              FactorClasses: SetOfIdClass;
              MinValue, MaxValue: ObjectValue;

            procedure SetConstructor;

              label 1;

              var BaseNow, SetType: TypEntry;

              begin { setconstructor }
                AcceptSymbol;
                BaseNow := Unknown;
                SetType := EmptyType;
                StackConstant(EmptyValue);
                if Symbol = RightBracket
                then AcceptSymbol
                else
                  begin
                    while true do
                      begin
                        Expression
                          ([Comma, Thru, RightBracket] + FactorContext);
                        EnsureOrdinal(ExpType);
                        if (BaseNow = Unknown) and (ExpType <> Unknown)
                        then
                          begin
                            BaseNow := ExpType;
                            NewType(SetType, Sets);
                            with SetType^ do
                              begin
                                FormOfset := Constructed;
                                BaseType := BaseNow
                              end;
                            SetRepresentationFor(SetType)
                          end
                        else
                          if not Compatible(BaseNow, ExpType)
                          then SemanticError(192);
                        if Symbol = Thru
                        then
                          begin
                            AcceptSymbol;
                            Expression
                              ([Comma, RightBracket] + FactorContext);
                            EnsureOrdinal(ExpType);
                            if not Compatible(BaseNow, ExpType)
                            then SemanticError(192);
                            RangeSet(SetType^.Representation)
                          end
                        else SingletonSet(SetType^.Representation);
                        BinarySetOperation(Plus);
                        if Symbol <> Comma then goto 1;
                        AcceptSymbol
                      end;
                    1 : ;
                    Accept(RightBracket)
                  end;
                ExpType := SetType
              end { setconstructor };

            begin { factor }
              CheckNextOrContext(FacBegSys, FactorContext);
              if Symbol in FacBegSys
              then
                begin
                  case Symbol of
                    Ident :
                      begin
                        FactorClasses :=
                          [Consts, Bound, Func] + ReadableVars;
                        if ICLPascal
                        then FactorClasses := FactorClasses + [Types];
                        SearchId(FactorClasses, FirstId);
                        AcceptSymbol;
                        case FirstId^.Klass of
                          Consts, Bound :
                            with FirstId^ do
                              begin
                                if Klass = Consts
                                then StackConstant(Values)
                                else
                                  begin
                                    StackReference(false, BdAddress);
                                    DeReference(IdType^.Representation)
                                  end;
                                ExpType := IdType
                              end;
                          ReadOnlyVars, PresetVars, Vars, Field :
                            begin
                              Selector(FactorContext, FirstId);
                              if VarType^.Form <> Files
                              then
                                begin
                                  if NewRecVar
                                  then
                                    TailoredFactorCheck
                                      (VarType^.Representation);
                                  if IsConformant(VarType)
                                  then
                                    WithSchema(VarType, CAPDeReference)
                                  else
                                    DeReference
                                      (VarType^.Representation);
                                  if FirstId^.Klass = Field
                                  then UndefinedVariableCheck
                                  else
                                    if (FirstId^.VarKind <> ValueParam)
                                       and
                                       not InSet
                                             (ControlVars, FirstId)
                                    then UndefinedVariableCheck
                                end;
                              if VarType^.Form = Subranges
                              then ExpType := VarType^.RangeType
                              else ExpType := VarType
                            end;
                          Func :
                            begin Call(FactorContext, FirstId) end;
                          Types :
                            begin
                              RecastType := FirstId^.IdType;
                              EnsureEnumerated(RecastType);
                              Accept(LeftParent);
                              SubExpression
                                ([RightParent] + FactorContext);
                              EnsureOrdinal(ExpType);
                              IntFunction(Recastf);
                              Accept(RightParent);
                              GetBounds(RecastType, MinValue, MaxValue);
                              RangeCheck(MinValue, MaxValue);
                              ExpType := RecastType
                            end
                        end
                      end;
                    IntConst :
                      begin
                        StackConstant(Constant.Velue);
                        ExpType := IntType;
                        AcceptSymbol
                      end;
                    RealConst :
                      begin
                        StackConstant(Constant.Velue);
                        ExpType := RealType;
                        AcceptSymbol
                      end;
                    CharConst :
                      begin
                        StackConstant(Constant.Velue);
                        ExpType := CharType;
                        AcceptSymbol
                      end;
                    BasedConst :
                      begin
                        StackConstant(Constant.Velue);
                        ExpType := WordType;
                        AcceptSymbol
                      end;
                    StringConst :
                      begin
                        StackConstant(Constant.Velue);
                        StringType(ExpType);
                        AcceptSymbol
                      end;
                    NilSy :
                      begin
                        StackConstant(NilValue);
                        ExpType := NilType;
                        AcceptSymbol
                      end;
                    LeftParent :
                      begin
                        AcceptSymbol;
                        SubExpression([RightParent] + FactorContext);
                        Accept(RightParent)
                      end;
                    NotSy :
                      begin
                        AcceptSymbol;
                        Factor(FactorContext);
                        if Compatible(ExpType, BoolType)
                        then NegateBoolean else SemanticError(106);
                        ExpType := BoolType
                      end;
                    LeftBracket : SetConstructor
                  end;
                  CheckContext(FactorContext)
                end
              else ExpType := Unknown
            end { factor };

          begin { term }
            Factor([MulOp] + FacBegSys + TermContext);
            if (Symbol = MulOp) and (Operator = AndOp)
            then BinaryBooleanOperation(AndOp, true);
            while (Symbol = MulOp) or (Symbol in FacBegSys) do
              begin
                LeftType := ExpType;
                if Symbol = MulOp
                then MulOperator := Operator else MulOperator := NotOp;
                Accept(MulOp);
                Factor([MulOp] + FacBegSys + TermContext);
                case MulOperator of
                  Mul : PlusMinusMul(LeftType, Mul);
                  RDiv :
                    begin
                      if Compatible(LeftType, IntType)
                      then
                        begin
                          FloatInteger(NextToTop);
                          LeftType := RealType
                        end;
                      if Compatible(ExpType, IntType)
                      then
                        begin
                          FloatInteger(TopOfStack);
                          ExpType := RealType
                        end;
                      if not (Compatible(LeftType, RealType) and
                              Compatible(ExpType, RealType))
                      then SemanticError(193);
                      ExpType := RealType;
                      BinaryRealOperation(RDiv);
                      ExpType := RealType
                    end;
                  IDiv, IMod :
                    begin
                      if not (Compatible(LeftType, IntType) and
                              Compatible(ExpType, IntType))
                      then SemanticError(194);
                      BinaryIntegerOperation(MulOperator);
                      ExpType := IntType
                    end;
                  AndOp :
                    begin
                      if not (Compatible(LeftType, BoolType) and
                              Compatible(ExpType, BoolType))
                      then SemanticError(195);
                      BinaryBooleanOperation(AndOp, false);
                      ExpType := BoolType
                    end;
                  NotOp : ExpType := Unknown
                end { case }
              end
          end { term };

        begin { simple expression }
          if (Symbol = AddOp) and (Operator in [Plus, Minus])
          then
            begin
              Signed := true;
              Sign := Operator;
              AcceptSymbol
            end
          else Signed := false;
          Term([AddOp] + SimpleExpContext);
          if Signed
          then
            if Compatible(ExpType, IntType)
            then
              begin
                if Sign = Minus then NegInteger
              end
            else
              if Compatible(ExpType, RealType)
              then
                begin
                  if Sign = Minus then NegReal
                end
              else
                begin
                  SemanticError(196);
                  ExpType := Unknown
                end;
          if (Symbol = AddOp) and (Operator = OrOp)
          then BinaryBooleanOperation(OrOp, true);
          while Symbol = AddOp do
            begin
              LeftType := ExpType;
              AddOperator := Operator;
              AcceptSymbol;
              Term([AddOp] + SimpleExpContext);
              case AddOperator of
                Plus : PlusMinusMul(LeftType, Plus);
                Minus : PlusMinusMul(LeftType, Minus);
                OrOp :
                  begin
                    if not (Compatible(LeftType, BoolType) and
                            Compatible(ExpType, BoolType))
                    then SemanticError(195);
                    BinaryBooleanOperation(OrOp, false);
                    ExpType := BoolType
                  end
              end { case }
            end
        end { simple expression };

      begin { subexpression }
        SimpleExpression([RelOp] + ExpContext);
        if Symbol = RelOp
        then
          begin
            EliminateConditions;
            LeftType := ExpType;
            RelOperator := Operator;
            if RelOperator = InOp then EnsureOrdinal(LeftType);
            AcceptSymbol;
            SimpleExpression(ExpContext);
            EliminateConditions;
            if RelOperator = InOp
            then
              begin
                EnsureFormIs(Sets, ExpType);
                if Compatible(LeftType, ExpType^.BaseType)
                then SetComparison(InOp) else SemanticError(197)
              end
            else
              begin
                if not Compatible(LeftType, ExpType)
                then

                  { may be real/integer mix }

                  if Compatible(LeftType, IntType)
                  then
                    begin
                      FloatInteger(NextToTop);
                      LeftType := RealType
                    end
                  else
                    if Compatible(ExpType, IntType)
                    then
                      begin
                        FloatInteger(TopOfStack);
                        ExpType := RealType
                      end;
                if Compatible(LeftType, ExpType)
                then
                  case LeftType^.Form of
                    Scalars, Subranges :
                      if Compatible(LeftType, RealType)
                      then RealComparison(RelOperator)
                      else OrdinalComparison(RelOperator);
                    Pointers :
                      if RelOperator in [LtOp, LeOp, GtOp, GeOp]
                      then SemanticError(199)
                      else PnterComparison(RelOperator);
                    Sets :
                      if RelOperator in [LtOp, GtOp]
                      then SemanticError(200)
                      else SetComparison(RelOperator);
                    Arrays :
                      if not String(LeftType)
                      then SemanticError(201)
                      else
                        StringComparison
                          (RelOperator, LeftType^.InxType^.Max);
                    CAPSchema : SemanticError(254);
                    Records, Files : SemanticError(202)
                  end
                else SemanticError(198)
              end;
            ExpType := BoolType
          end
      end { subexpression };

    procedure Expression;

      begin { expression }
        SubExpression(ExpContext);
        EliminateConditions
      end { expression };

    procedure BooleanExpression(CondContext: SetOfSymbols);

      begin { booleanexpression }
        SubExpression(CondContext);
        if not Compatible(ExpType, BoolType) then SemanticError(106)
      end { booleanexpression };

{

 11.11 Statement analysis.
 
 Analysis of the different Pascal statements is carried out by sub-
 procedures  of  the procedure Statement called within StatementSe-
 quence.
 
 The semantic processing of statement labels  is implemented by the
 procedures   Statement,   NestedStatement   and  GotoStatement  as
 described in module 10.
 
 The procedure ForStatement  must  check  whether  a  for-statement
 control-variable  is  threatened  by an assigning reference in any
 procedure or function declared in the same  block.  The  procedure
 Threaten  examines  every  assigning  reference, and maintains for
 each block scope an identifier-set Threatened of simple  variables
 declared  in  that  scope,  but assigned within one of the (block)
 scopes contained by it. The  for-statement  analyser  checks  that
 each  control-variable  does  not belong to the threatened set for
 its scope.
 
 The control-variable is protected  from  rogue-assignments  within
 the  for loop, by placing it  in  the identifier-set  ControlVars,
 prior to analysis of the body  of  the  for-statement.   Assigning
 references  vetted  by  the  procedure Threaten are permitted only
 if the destination variable  is  not   a  member  of  ControlVars.
 The  control-variable  is removed from  the set when  analysis  of
 the for-statement is complete.

                                                                     }

    procedure StatementSequence(Context: SetOfSymbols);
      forward;

    procedure Statement(Context: SetOfSymbols);

      var FirstId: IdEntry;

      procedure Assignment(VarId: IdEntry);

        var LVarType, LVarPart: TypEntry;

        begin { assignment }
          Selector([Becomes] + Context, VarId);
          if NewRecVar
          then TailoredFactorCheck(VarType^.Representation);
          if SimpleVar or (VarId^.Klass = Field)
          then Threaten(VarId, WriteableVars);
          LVarType := VarType;
          if TagVar then LVarPart := VntSelector else LVarPart := nil;
          Accept(Becomes);
          Expression(Context);
          CheckAssignment(LVarType, ExpType);
          if LVarPart <> nil
          then AssignTag(LVarPart^.Representation)
          else Assign(LVarType^.Representation)
        end { assignment };

      procedure NestedStatement(Context: SetOfSymbols);

        begin
          OpenLabelDepth;
          Statement(Context);
          CloseLabelDepth
        end { nestedstatement };

      procedure GotoStatement;

        var LabelFound: LabelEntry;

        begin { gotostatement }
          Accept(GoToSy);
          if Symbol = IntConst
          then
            begin
              CheckLabel(LabelFound);
              LabelJump(LabelFound^.LabelledCode, LevelFound)
            end;
          Accept(IntConst)
        end { gotostatement };

      procedure CompoundStatement;

        begin { compoundstatement }
          Accept(BeginSy);
          StatementSequence([EndSy] + Context);
          Accept(EndSy)
        end { compoundstatement };

      procedure IfStatement;

        var ForFalseAction, FollowingStatement: CodeLabel;

        begin { ifstatement }
          FutureCodeLabel(FollowingStatement);
          Accept(IfSy);
          BooleanExpression([ThenSy, ElseSy] + Context);
          FutureCodeLabel(ForFalseAction);
          JumpOnFalse(ForFalseAction);
          Accept(ThenSy);
          NestedStatement([ElseSy] + Context);
          if Symbol = ElseSy
          then
            begin
              Jump(FollowingStatement);
              NxIsCodeLabel(ForFalseAction);
              AcceptSymbol;
              NestedStatement(Context)
            end
          else NxIsCodeLabel(ForFalseAction);
          NxIsCodeLabel(FollowingStatement)
        end { ifstatement };

      procedure CaseStatement;

        label 9;

        type
          CaseEntry = ^CaseRecord;
          CaseRecord = record
                         Value1, Value2: ObjectValue;
                         NextCase: CaseEntry
                       end;

        var
          CaseType: TypEntry;
          FirstCase, ThisCase, NextCase: CaseEntry;
          FollowingStatement: CodeLabel;

        procedure NewCaseLabel;

          var
            Followers: SetOfSymbols;
            LabelType: TypEntry;
            FirstValue, SecondValue, LabelValue: ObjectValue;
            ThisCase, LastCase: CaseEntry;

          begin
            Followers := [Comma, Colon];
            if ICLPascal then Followers := Followers + [Thru];
            ConstExpression
              (Followers + Context, LabelType, LabelValue);
            EnsureOrdinal(LabelType);
            if LabelType <> Unknown
            then
              if Compatible(LabelType, CaseType)
              then
                begin
                  FirstValue := LabelValue;
                  SecondValue := FirstValue;
                  if Symbol = Thru
                  then
                    begin
                      AcceptSymbol;
                      ConstExpression([Comma, Colon] + Context,
                                      LabelType, LabelValue);
                      EnsureOrdinal(LabelType);
                      if not Compatible(LabelType, CaseType)
                      then SemanticError(211)
                      else
                        if OrderedValues(LabelValue, FirstValue)
                        then SemanticError(212)
                        else SecondValue := LabelValue
                    end;
                  ThisCase := FirstCase;
                  LastCase := nil;
                  while ThisCase <> nil do
                    with ThisCase^ do
                      begin
                        if not Disjoint(Value1, Value2,
                                        FirstValue, SecondValue)
                        then SemanticError(210);
                        LastCase := ThisCase;
                        ThisCase := NextCase
                      end;
                  new(ThisCase);
                  with ThisCase^ do
                    begin
                      Value1 := FirstValue;
                      Value2 := SecondValue;
                      if SameValue(FirstValue, SecondValue)
                      then NxIsCase(LabelValue)
                      else NextIsRange(FirstValue, SecondValue);
                      NextCase := nil
                    end;
                  if LastCase = nil
                  then FirstCase := ThisCase
                  else LastCase^.NextCase := ThisCase
                end
              else SemanticError(211)
          end;

        begin { casestatement }
          FutureCodeLabel(FollowingStatement);
          Accept(CaseSy);
          Expression([OfSy, Comma, Colon] + Context);
          CaseType := ExpType;
          EnsureOrdinal(CaseType);
          OpenCase;
          Accept(OfSy);
          FirstCase := nil;
          if Symbol <> OtherwiseSy
          then
            repeat
              while true do
                begin
                  NewCaseLabel;
                  if Symbol <> Comma then goto 9;
                  AcceptSymbol
                end;
              9 : ;
              Accept(Colon);
              NestedStatement
                ([Semicolon, EndSy, OtherwiseSy] + Context);
              Jump(FollowingStatement);
              if Symbol = OtherwiseSy
              then Error(Missing(Semicolon), StartOfSymbol);
              if Symbol = Semicolon then AcceptSymbol
            until (Symbol in ([EndSy, OtherwiseSy] + Context));
          if Symbol = OtherwiseSy
          then
            begin
              AcceptSymbol;
              OtherCases;
              StatementSequence([EndSy] + Context);
              Jump(FollowingStatement)
            end;
          Accept(EndSy);
          CloseCase;
          NextCase := FirstCase;
          while NextCase <> nil do
            begin
              ThisCase := NextCase;
              NextCase := ThisCase^.NextCase;
              dispose(ThisCase)
            end;
          NxIsCodeLabel(FollowingStatement)
        end { casestatement };

      procedure WhileStatement;

        var ToTestCondition, FollowingStatement: CodeLabel;

        begin { whilestatement }
          FutureCodeLabel(FollowingStatement);
          Accept(WhileSy);
          NewCodeLabel(ToTestCondition);
          FlowPoint(Source^.Position.LineNumber);
          BooleanExpression([DoSy] + Context);
          JumpOnFalse(FollowingStatement);
          Accept(DoSy);
          NestedStatement(Context);
          Jump(ToTestCondition);
          NxIsCodeLabel(FollowingStatement)
        end { whilestatement };

      procedure RepeatStatement;

        var ThisStatement: CodeLabel;

        begin { repeatstatement }
          NewCodeLabel(ThisStatement);
          Accept(RepeatSy);
          StatementSequence([UntilSy] + Context);
          FlowPoint(Source^.Position.LineNumber);
          Accept(UntilSy);
          BooleanExpression(Context);
          JumpOnFalse(ThisStatement)
        end { repeatstatement };

      procedure ForStatement;

        var
          ForVarId: IdEntry;
          ForVarType: TypEntry;
          ForMin, ForMax: ObjectValue;
          Increasing: Boolean;

        begin { forstatement }
          Accept(ForSy);
          if Symbol = Ident
          then
            begin
              SearchId([PresetVars, Vars], ForVarId);
              ForVarType := ForVarId^.IdType;
              if LevelFound < BlockLevel
              then SemanticError(220)
              else
                if InSet(Display[BlockLevel].Threatened, ForVarId)
                then SemanticError(222)
                else
                  if InSet(ControlVars, ForVarId)
                  then SemanticError(225)
                  else
                    if not Ordinal(ForVarType)
                    then
                      begin
                        SemanticError(110);
                        ForVarType := Unknown
                      end;
              with ForVarId^ do
                begin
                  if VarKind <> LocalVar then SemanticError(221);
                  StackReference(false, VarAddress)
                end
            end
          else ForVarType := Unknown;
          GetBounds(ForVarType, ForMin, ForMax);
          Accept(Ident);
          CheckContext([Becomes, ToSy, DoSy] + Context);
          Accept(Becomes);
          Expression([ToSy, DoSy] + Context);
          if not Compatible(ForVarType, ExpType)
          then SemanticError(223);
          if Symbol = ToSy
          then Increasing := (Operator = Plus) else Increasing := true;
          Accept(ToSy);
          Expression([DoSy] + Context);
          if not Compatible(ForVarType, ExpType)
          then SemanticError(224);
          OpenFor(Increasing, ForMin, ForMax);
          Accept(DoSy);
          Include(ControlVars, ForVarId);
          NestedStatement(Context);
          CloseFor;
          Exclude(ControlVars, ForVarId)
        end { forstatement };

      procedure WithStatement;

        { analysis of the iterative record-variable-list }
        { is implemented recursively, to handle the      }
        { implied nested scopes correctly                }

        var VarId: IdEntry;

        begin

          { withstatement }
          { first symbol is withsy on initial call, }
          { comma on subsequent recursive calls     }

          AcceptSymbol;
          if Symbol = Ident
          then SearchId(ReadableVars, VarId) else VarId := DummyVarId;
          Accept(Ident);
          Selector([Comma, DoSy] + Context, VarId);
          EnsureFormIs(Records, VarType);
          OpenScope(RecordScope);
          OpenWith(ScopeLevel);
          with Display[ScopeLevel] do
            begin
              Locals := VarType^.FieldScope;
              RecordType := VarType;
              FieldsPacked := VarType^.PackedRecord;
              if VarId^.Klass = ReadOnlyVars then ReadOnlyScope := true
            end;
          if Symbol = Comma
          then WithStatement
          else
            begin
              Accept(DoSy);
              NestedStatement(Context)
            end;
          CloseWith;
          CloseScope
        end { withstatement };

      begin { statement }
        if Symbol = IntConst
        then
          begin
            DefineLabel;
            AcceptSymbol;
            Accept(Colon)
          end;
        if Symbol = PragmaSy then PragmaList(StatBegSys + [Ident] + Context);
        CheckContext(StatBegSys + [Ident] + Context);
        if Symbol in StatBegSys + [Ident]
        then
          begin
            FlowPoint(Source^.Position.LineNumber);
            OpenLabelDepth;
            case Symbol of
              Ident :
                begin
                  SearchId(WriteableVars + [Func, Proc], FirstId);
                  AcceptSymbol;
                  if FirstId^.Klass = Proc
                  then Call(Context, FirstId) else Assignment(FirstId)
                end;
              GoToSy : GotoStatement;
              BeginSy : CompoundStatement;
              IfSy : IfStatement;
              CaseSy : CaseStatement;
              WhileSy : WhileStatement;
              RepeatSy : RepeatStatement;
              ForSy : ForStatement;
              WithSy : WithStatement
            end;
            CloseLabelDepth;
            CheckContext(Context)
          end
        else FlowPoint(Source^.Position.LineNumber)
      end { statement };

    procedure StatementSequence {Context : setofsymbols};

      var Followers: SetOfSymbols;

      begin { statementsequence }
        Followers := [Semicolon] + StatBegSys;
        if ICLPascal then Followers := Followers + [PragmaSy];
        Statement(Followers + Context);
        while Symbol in Followers do
          begin
            Accept(Semicolon);
            Statement(Followers + Context)
          end
      end { statementsequence };

    procedure StatementPart;

      begin { statementpart }
        if BlockLevel = GlobalLevel
        then
          begin
            EnterProgram(ProgId, Source^.Position.LineNumber);
            VerifyProgParams
          end
        else EnterPfBody(BlockIdEntry, Source^.Position.LineNumber);
        PresetBlock;
        InitLabelDepth;
        FlowPoint(Source^.Position.LineNumber);
        repeat

          { for syntax error recovery }

          Accept(BeginSy);
          StatementSequence(BlockBegSys + [EndSy]);
          Accept(EndSy);
          if (BlockIdEntry^.BlockKind = ExternalBlock) and 
             (Symbol = Semicolon)
          then
            { extern procs/funcs should not have a body. }
            Error(188, BlockIdEntry^.Declaration);

        until (Symbol = BlockFollower) or (Symbol in BlockBegSys);
        PostSetBlock;
        if BlockLevel = GlobalLevel
        then ExitProgram
        else
          with BlockIdEntry^ do
            if Klass = Func
            then LeaveFunction(Result, IdType^.Representation)
            else LeaveProcedure
      end { statementpart };

    begin { block }
      ReadableVars := [Vars, PresetVars, ReadOnlyVars, Field];
      WriteableVars := ReadableVars - [ReadOnlyVars];
      BlockContext := BlockBegSys + StatBegSys - [CaseSy];
      StartSet(ControlVars);
      FutureStatementLabel(FinalPart);
      repeat
        if Symbol = LabelSy then LabelDeclarationPart;
        if Symbol = ConstSy then ConstDefinitionPart;
        if Symbol = TypeSy then TypeDefinitionPart;
        if Symbol = VarSy then DeclarationPart(Vars);
        if Symbol = PresetSy then DeclarationPart(PresetVars);
        if Symbol = ReadOnlySy then DeclarationPart(ReadOnlyVars);
        while Symbol in [ProcSy, FuncSy] do PfDeclaration;
        if ICLPascal
        then CheckNextOrContext(BlockBegSys + StatBegSys, BlockBegSys)
        else CheckNextOrContext(StatBegSys, BlockBegSys)
      until Symbol in StatBegSys;
      StatementPart;
      DsposeSet(ControlVars);

    end { block };

  begin { programme }
    StartList(Externals);
    OpenScope(ActualBlock);
    OpenStackFrame;
    ProgramHeading;
    Accept(Semicolon);
    EntryLabel := ProgId^.ProgBody;
    OpenCodeSpace(EntryLabel);
    ProgId^.ProgBody := EntryLabel;
    repeat

      { for syntax error recovery }

      Block(Period, ProgId)
    until Symbol = Period;
    FileScope(ProgId);
    CloseCodeSpace;
    CloseStackFrame;
    DisposeScope;
    CloseScope;
    DsposeList(Externals)
  end { programme };

begin
  { end of module }
end.