{

 History
 -------

 23/10/85 - many changes to specify i/o operations for 
            E-machine. (agh)
 24/10/85 - many changes to specify pack and unpack  
            operations for E-machine. (agh)
 25/10/85 - many changes to specify new and dispose heap
            operations for the E-machine. (agh)
 04/11/85 - Change calls to AccessArea and AddressArea to match
            new parameter lists. (agh)
 06/11/85 - Add bodies for SizeOfCAP, SizeRequest, SizeOperation
            StampProcedure. (agh)
 08/11/85 - Add body for WriteCAPString. (agh)
 03/12/85 - Changes to pack and unpack to support bit-level
            packing. (agh)
 04/12/85 - Changes to SizeOfCAP to use CAPSize operation. (agh)
 05/12/85 - Changes to pack and unpack procedures to improve
            bound-checking for constant and non-constant bounds. (agh)
 06/12/85 - Abandon standard operation E-codes in favour of 
            calls to the appropriate run-time system routines. (agh)
 09/12/85 - Re-name Pascal E-codes for consistency. (agh)
 --------------------------------------------------------------------
 20/12/85 - Fix bug in PushPtr to load string-constants. (agh)
 03/01/86 - Modify above to pass imp-string to rt-system. (agh)
 ----------------------------------------------------------------------
 29/01/86 - Call of StartCall inserted in HeapOperation

                                                                     }
{

                          MODULE 22


                   The Standard Procedures





 This chapter contains the code generation procedures for the stan-
 dard input/output procedures, for pack and unpack, and for new and
 dispose.  The remaining arithmetic functions  are  implemented  by
 dedicated P-codes.

 22.1  File Selection

 All input/output operations are performed with respect to an argu-
 ment  file  'selected'  as  appropriate  from Input, Output or the
 standard procedure parameter list.  Details of the  selected  file
 are  provided  by  the call to procedure SelectFile and stored for
 the duration of the I/O operation in the fields  of  a  record  of
 type  IOFileRecord.   In particular, FileType is the TypeEntry for
 the argument file type, and FileEntry is the file variable  refer-
 ence.  The statement:

      write (f,eof(g))

 indicates  that  I/O  operations  may  be  nested,  and   so   the
 IOFileRecords  are  preserved  in  a  stack whose top-most node is
 referenced by the global variable SelectedFile.  Furthermore,  the
 delayed  code-generation  strategy employed to evaluate an expres-
 sion such as:

      eof(g) or eof(h) or eof(i)

 requires  that  the  selected  file  for  each  function  must  be
 preserved,  and  restored immediately prior to code generation for
 the  function  call.   The  following  procedures  satisfy   those
 requirements  by  maintaining a stack of selected files onto which
 entries are pushed prior to any input/output code generation,  and
 popped  when  code-generation  is complete.  Delayed evaluation of
 the functions eof and eoln is provided for by procedures  SaveFile
 and RestoreFile.


                                                                     }

program StandardProcs;
  
#include "globals.x"
#include "semantics.pf"
#include "generator.pf"
#include "datareps.pf"
#include "storage.pf"
#include "objvalues.pf"
#include "varref.pf"
#include "expeval.pf"
#include "codeutils.pf"
#include "assgncode.pf"
#include "withstmts.pf"
#include "ctlstructs.pf"
#include "prologue.pf"
#include "eput.pf"

  procedure SelectFile(FType: TypEntry);
    visible;
    
    var IOFile: IOFileEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          new(IOFile);
          with IOFile^ do
            begin
              FileType := FType;
              Pop(FileEntry);
              SaveAddress(FileEntry);
              Next := SelectedFile
            end;
          SelectedFile := IOFile
        end
    end { selectfile };
  
  procedure GetIOBase(var BaseEntry: StackEntry);
    
    begin
      GetEntry(BaseEntry);
      BaseEntry^ := SelectedFile^.FileEntry^
    end { getiobase };
  
  procedure SaveFile(var IOFile: IOFileEntry);
    
    begin
      new(IOFile);
      with IOFile^ do
        begin
          FileType := SelectedFile^.FileType;
          GetIOBase(FileEntry);
          Next := nil
        end
    end { savefile };
  
  procedure RstoreFile(IOFile: IOFileEntry);
    visible;
    
    begin
      IOFile^.Next := SelectedFile;
      SelectedFile := IOFile
    end { restorefile };
  
  procedure DiscardFile;
    visible;
    
    var IOFile: IOFileEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          IOFile := SelectedFile;
          with IOFile^ do
            begin
              FreeEntry(FileEntry);
              SelectedFile := Next
            end;
          dispose(IOFile)
        end
    end { discardfile };
  
  procedure InitIO;
    visible;
    
    begin SelectedFile := nil end;
  
  
  {
  
  
   22.3  Input/Output Operations
  
   The following procedures generate code for all standard  I/O  pro-
   cedures.   For text files binary/decimal conversion is carried out
   by the appropriate P-codes.   For  non  text  files  read(f,v)  is
   treated as:
  
        v := f^; get(f))
  
   and write(f,v) as:
  
        f^ := v; put(f)
  
   The procedure WriteLayout is used to generate appropriate  P-codes
   for  both  page  and writeln, depending upon an implicitly stacked
   format control value.  The functions eolnf and eof are implemented
   by calls to FileFunction, with code generation being delayed until
   the expression value is required.
  
  
                                                                       }
  
  procedure LoadFileReference;
    
    var FileEntry: StackEntry;
    
    begin
      GetIOBase(FileEntry);
      if FileEntry^.Kind = Address then PushNewAccess(FileEntry, false);
      Push(FileEntry)
    end { loadfilefreference };
  
  procedure LoadFCBAddress;
    visible;
    
    var FileEntry: StackEntry;
    
    begin
      GetIOBase(FileEntry);
      PushAddress(FileEntry);
      FreeEntry(FileEntry)
    end { loadfcbaddress };

  procedure FileOperation(Which: StdProcFuncs; Form: IOFormat);
    visible;
    
    var
      FlagEntry, StringEntry: StackEntry;
      Size, Property: Scalar;

    procedure PushPtr(PtrEntry: StackEntry);

      begin
        if PtrEntry <> nil
        then
          begin
            PushAddress(PtrEntry);
            FreeEntry(PtrEntry)
          end
        else PushLiteral(0)
      end { PushPtr };

    procedure PushStr(StrEntry: StackEntry);

      begin
        if StrEntry <> nil
        then
          begin
            PushString(StrEntry);
            FreeEntry(StrEntry)
          end
        else PushLiteral(0)
      end { PushStr };
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          case Which of
            Resetp, Rewritep, Appendp :
              begin
                if (Form = Flagged) or (Form = Full)
                then Pop(FlagEntry) else FlagEntry := nil;
                if (Form = Named) or (Form = Full)
                then Pop(StringEntry) else StringEntry := nil;
                with SelectedFile^.FileType^ do
                  begin
                    Property := ord(TextFile);
                    Size := DataSize(FelType^.Representation);
                  end;
                StartCall(SystemRoutine[Which]);
                if NegativeStack
                then
                  begin
                    PushPtr(FlagEntry);
                    PushStr(StringEntry);
                    PushLiteral(Size);
                    PushLiteral(Property);
                    LoadFCBAddress
                  end
                else
                  begin 
                    LoadFCBAddress;
                    PushLiteral(Property);
                    PushLiteral(Size);
                    PushStr(StringEntry);
                    PushPtr(FlagEntry)
                  end;
                CallStdrd(SystemRoutine[Which]);
              end;
            Getp, Putp, Closep :
              begin
                StartCall(SystemRoutine[Which]);
                LoadFCBAddress;
                CallStdrd(SystemRoutine[Which])
              end
          end
        end
    end { fileoperation };
  
  procedure ReadBuffer;
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        with SelectedFile^ do
          begin
            LoadFileReference;
            with FileType^ do
              begin
                BufferReference
                  (PackedFile, TextFile, FelType^.Representation);
                DeReference(FelType^.Representation)
              end
          end
    end { readbuffer };
  
  procedure WriteBuffer;
    visible;
    
    var Expression: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        with SelectedFile^ do
          begin
            Pop(Expression);
            if RChecks in Requested then SelectCheck(Expression, 18);
            with FileType^ do
              begin
                LoadFileReference;
                BufferReference(PackedFile, false, FelType^.Representation);
                Push(Expression);
                Assign(FelType^.Representation)
              end
          end
    end { writebuffer };
  
  procedure ReadNumeric(ReadMode: InputKind);
    visible;
    
    var ReadEntry: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          GetEntry(ReadEntry);
          with ReadEntry^ do
            begin
              Kind := Operation;
              OpForm := ReadOp;
              Mode := ReadMode;
              case ReadMode of
                IntKind : DataRep := IntegerRepresentation;
                RealKind : DataRep := RealRepresentation
              end
            end;
          Push(ReadEntry)
        end
    end { readnumeric };
  
  procedure WriteScalars(WriteMode: OutputKind; Format: FormatKind);
    visible;
    
    var Expression, TotalWidth, FracDigits, Base: StackEntry;

    function WriteRoutine: Intrinsic;

      begin
        case WriteMode of
          IntKind : WriteRoutine := p_wri;
          CharKind : WriteRoutine := p_wrc;
          BoolKind : WriteRoutine := p_wrb;
          WordKind :WriteRoutine := p_wrw;
          RealKind :
            if Format = Fixed
            then WriteRoutine := p_wrfx else WriteRoutine := p_wrfl
        end
      end { WriteRoutine };
    
    procedure DefaultWidths;
      
      begin
        case WriteMode of
          IntKind :
            begin
              StackConstant(ElevenValue);
              Pop(TotalWidth)
            end;
          RealKind :
            begin
              StackConstant(TwentyTwoValue);
              Pop(TotalWidth)
            end;
          CharKind :
            begin
              StackConstant(OneValue);
              Pop(TotalWidth)
            end;
          BoolKind :
            begin
              StackConstant(FiveValue);
              Pop(TotalWidth)
            end;
          WordKind :
            begin
              StackConstant(EightValue);
              Pop(TotalWidth);
              StackConstant(SixteenValue);
              Pop(Base)
            end
        end
      end { DefaultWidths };
    
    procedure PopArguments;
      
      begin
        case Format of
          Fixed :
            begin
              CheckRange(1, MCMaxint, 58);
              if WriteMode = WordKind
              then
                begin
                  Pop(TotalWidth);
                  CheckRange(2, 16, 78);
                  Pop(Base)
                end
              else
                begin
                  Pop(FracDigits);
                  CheckRange(1, MCmaxint, 58);
                  Pop(TotalWidth)
                end
            end;
          Floating :
            if WriteMode = WordKind
            then
              begin
                StackConstant(EightValue);
                Pop(TotalWidth);
                CheckRange(2, 16, 78);
                Pop(Base)
              end
            else
              begin
                CheckRange(1, MCMaxint, 58);
                Pop(TotalWidth)
              end;
          Default : DefaultWidths
        end;
        
      end { PopArguments };
    
    procedure PushArguments;
      
      begin
        case WriteMode of
          IntKind, CharKind, BoolKind :
            begin
              PushValue(TotalWidth);
              FreeEntry(TotalWidth);
            end;
          RealKind :
            begin
              if NegativeStack
              then
                begin
                  if Format = Fixed then PushValue(FracDigits);
                  PushValue(TotalWidth)
                end
              else
                begin
                  PushValue(TotalWidth);
                  if Format = Fixed then PushValue(FracDigits)
                end;
              if Format = Fixed then FreeEntry(FracDigits);
              FreeEntry(TotalWidth);
            end;
          WordKind :
            begin
              if NegativeStack
              then
                begin
                  PushValue(TotalWidth);
                  PushValue(Base)
                end
              else
                begin
                  PushValue(Base);
                  PushValue(TotalWidth)
                end;
              FreeEntry(Base);
              FreeEntry(TotalWidth);
            end;
          StringKind, DefaultKind : 
        end
      end { PushArguments };
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          PopArguments;
          Pop(Expression);
          StartCall(WriteRoutine);
          if NegativeStack
          then
            begin
              PushArguments;
              PushValue(Expression);
              LoadFCBAddress
            end
          else
            begin
              LoadFCBAddress;
              PushValue(Expression);
              PushArguments
            end;
          CallStdrd(WriteRoutine);
          FreeEntry(Expression)
        end
    end { writescalars };
  
  procedure WriteString(ActualLength: ObjectValue; Format: FormatKind);
    visible;
    
    var
      Expression, TotalWidth: StackEntry;
      StringSize: MCScalar;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Format = Default then StackConstant(ActualLength);
          CheckRange(1, MCMaxint, 58);
          Pop(TotalWidth);
          Pop(Expression);
          StringSize := ActualLength.Ival;
          StartCall(p_wrst);
          if NegativeStack
          then
            begin
              PushValue(TotalWidth);
              PushLiteral(StringSize);
              PushValue(Expression);
              LoadFCBAddress
            end
          else
            begin
              LoadFCBAddress;
              PushValue(Expression);
              PushLiteral(StringSize);
              PushValue(TotalWidth)
            end;
          CallStdrd(p_wrst);
          FreeEntry(Expression);
          FreeEntry(TotalWidth)
        end
    end { writestring };
  
  procedure WriteCAPString(HighBound: CAPBound; Format: FormatKind);
    visible;

    var TotalWidth, Expression: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Format = Default
          then StackReference(false, HighBound.Address)
          else CheckRange(1, MCMaxint, 58);
          Pop(TotalWidth);
          Pop(Expression);
          StartCall(p_wrst);
          if NegativeStack
          then
            begin
              PushValue(TotalWidth);
              AccessArea(HighBound.Address, 0, MCBytesPerWord);
              Eop(PUSHVAL);
              PushValue(Expression);
              LoadFCBAddress
            end
          else
            begin
              LoadFCBAddress;
              PushValue(Expression);
              AccessArea(HighBound.Address, 0, MCBytesPerWord);
              Eop(PUSHVAL);
              PushValue(TotalWidth)
            end;
          CallStdrd(p_wrst);
          FreeEntry(Expression);
          FreeEntry(TotalWidth)
        end     
    end; { WriteCAPString }
  
  procedure ReadLayout;
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          StartCall(p_rdln);
          LoadFCBAddress;
          CallStdrd(p_rdln)
        end
    end { readlayout };
  
  procedure WriteLayout;
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          StartCall(p_wrln);
          LoadFCBAddress;
          CallStdrd(p_wrln)
        end
    end { writelayout };
  
  procedure WriteLines;
    visible;
    
    var Expression: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          CheckRange(1, MCMaxint, 79);
          Pop(Expression);
          StartCall(p_lines);
          if NegativeStack
          then
            begin
              PushValue(Expression);
              LoadFCBAddress
            end
          else
            begin
              LoadFCBAddress;
              PushValue(Expression)
            end;
          CallStdrd(p_lines);
          FreeEntry(Expression)
        end
    end { WriteLines };
  
  procedure WritePage;
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          StartCall(p_page);
          LoadFCBAddress;
          CallStdrd(p_page)
        end
    end { WritePage };
  
  procedure FileFunction(WhichFunc: StdProcFuncs);
    visible;
    
    var FuncEntry: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          GetEntry(FuncEntry);
          with FuncEntry^ do
            begin
              DataRep := BooleanRepresentation;
              Kind := Operation;
              OpGroup := AFile;
              OpForm := Stdrd;
              StdOp := WhichFunc;
              SaveFile(IOEntry)
            end;
          Push(FuncEntry)
        end
    end { filefunction };
  
  {
  
  
   22.4  Pack and Unpack
  
   The Model Compiler allows pack and unpack operations  to  be  per-
   formed between conformant as well as ordinary arrays.  In general,
   given:
  
        a: array [lu..hu] of T;
        z: packed array [lp..hp] of T;
  
   either transfer operation must be checked to verify that  no  ele-
   ment  of  the  source  array  is  undefined, and that the indexing
   expression satisfies:
  
          lu <=i<= hu            (errors D26,D29)
               i<= hu - (hp-lp)  (errors D28,D31)
  
   If neither array is conformant,  the  parameters  to  these  range
   checks  are  known  at compile-time.  If either or both arrays are
   conformant, code is  generated  to  access  the  bounds  from  the
   bound-pair blocks.  These checks are generated in the usual way by
   post-fixing a range-checking operator  to  the  index  expression-
   tree.


                                                                       }

  function ConstantIndex: Boolean;
    
    begin
      with TopStackEntry^ do ConstantIndex := Kind = AConstant
    end { constantindex };

  function UpIndexError(Which: StdProcFuncs): integer;

    begin 
      if Which = Packp 
      then UpIndexError := 26 else UpIndexError := 29
    end { UpIndexError };

  function PkIndexError(Which: StdProcFuncs): integer;

    begin
      if Which = Unpackp
      then PkIndexError := 28 else PkIndexError := 31
    end { PkIndexError };

  procedure SetBound(TheCAPBound: CAPBound; var Bound: BoundForm);

    begin
      with TheCAPBound do
        if Fixed
        then SetBndValue(Bound, Value.Ival)
        else SetBndAddress(Bound, Address)
    end { SetBound };
  
  procedure LoadCAPEls(LowBound, HighBound: CAPBound);

    begin
      with HighBound do
        if Fixed
        then Estklit(Value.Ival)
        else AccessArea(Address, 0, MCBytesPerWord);
      with LowBound do
        if Fixed
        then Estklit(Value.Ival)
        else AccessArea(Address, 0, MCBytesPerWord);
      Eop(ISUB);
      Epasop(ISUCC);
      Eop(PUSHVAL)
    end { loadcapels };
  
  procedure CheckArrayArrayTransfer(HighBound, PkLowBound,
                                    PkHighBound: ObjectValue;
                                    Error: Scalar);
    
    var
      IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;
    
    begin
      Pop(IndexEntry);
      new(IndexRange);
      with IndexRange^ do
        SetBndValue(Upper, HighBound.Ival);
      new(LimitedRange);
      with LimitedRange^ do
        begin
          SetBndValue(Lower, PkLowBound.Ival);
          SetBndValue(Upper, PkHighBound.Ival)
       end;
      GetEntry(CheckedEntry);
      with CheckedEntry^ do
        begin
          RunError := Error;
          DataRep := IndexEntry^.DataRep;
          Kind := Operation;
          OpGroup := AnInteger;
          OpForm := RangeChk;
          CheckKind := TransferChecks;
          RequiredRange := IndexRange;
          TransferRange := LimitedRange;
          EntryToCheck := IndexEntry
        end;
      Push(CheckedEntry)
    end { checkarrayarraytransfer };

  procedure ArrayArrayOp(Which: StdProcFuncs;
                         UpLowBound, UpHighBound: ObjectValue;
                         UnpackedRep, PackedRep: TypeRepresentation;
                         PkLowBound, PkHighBound: ObjectValue);
    visible;

    { This procedure is called when both packed and unpacked }
    { operands are fixed arrays.                             }
    
    var
      PackedBase, UnpackedBase, Index: StackEntry;
      Value1, Value2: ObjectValue;
      UnpackedSize: ByteRange;
      ElsPerWord: MCBitRange;
      PackedEls: integer;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Which = Packp then Pop(PackedBase);
          PackedEls := Range(PkLowBound, PkHighBound);
          if RChecks in Requested
          then
            begin
              RangeCheck(UpLowBound, UpHighBound, UpIndexError(Which));
              CheckArrayArrayTransfer
                (UpHighBound, PkLowBound, PkHighBound, 
                 PkIndexError(Which))
            end;
          InxReference(false, UpLowBound, UpHighBound, UnpackedRep);
          Pop(UnpackedBase);
          if Which = Unpackp then Pop(PackedBase);
          UnpackedSize := DataBytes(UnpackedRep);
          with PackedRep do
            if BitsPacked in Requested
            then ElsPerWord := MCBitsPerWord div BitSize
            else ElsPerWord := MCBytesPerWord div ByteSize;
          StartCall(SystemRoutine[Which]);
          if NegativeStack
          then
            begin
              PushLiteral(PackedEls);
              PushLiteral(ElsPerWord);
              PushLiteral(UnpackedSize);
              PushAddress(PackedBase);
              PushAddress(UnpackedBase)
            end
          else
            begin
              PushAddress(UnpackedBase);
              PushAddress(PackedBase);
              PushLiteral(UnpackedSize);
              PushLiteral(ElsPerWord);
              PushLiteral(PackedEls)
            end;
          CallStdrd(SystemRoutine[Which]);
          FreeEntry(UnpackedBase);
          FreeEntry(PackedBase)
        end
    end { arrayarrayop };
  
  procedure CheckArrayCAPTransfer(HighBound: ObjectValue;
                                  PkLowBound, PkHighBound: CAPBound;
                                  Error: Scalar);
    
    var
      IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;
    
    begin
      Pop(IndexEntry);
      new(IndexRange);
      with IndexRange^ do
        SetBndValue(Upper, HighBound.Ival);
      new(LimitedRange);
      with LimitedRange^ do
        begin
          SetBound(PkLowBound, Lower);
          SetBound(PkHighBound, Upper)
       end;
      GetEntry(CheckedEntry);
      with CheckedEntry^ do
        begin
          RunError := Error;
          DataRep := IndexEntry^.DataRep;
          Kind := Operation;
          OpGroup := AnInteger;
          OpForm := RangeChk;
          CheckKind := TransferChecks;
          RequiredRange := IndexRange;
          TransferRange := LimitedRange;
          EntryToCheck := IndexEntry
        end;
      Push(CheckedEntry)
    end { checkarraycaptransfer };
  
  procedure ArrayCAPOp(Which: StdProcFuncs;
                       UpLowBound, UpHighBound: ObjectValue;
                       UnpackedRep, PackedRep: TypeRepresentation;
                       PkLowBound, PkHighBound: CAPBound);
    visible;
    
    { This procedure is called when the unpacked operand is a   }
    { fixed array and the packed operand is a conformant array. }

    var
      CAPPackedBase, UnpackedBase, IndexEntry: StackEntry;
      UnpackedSize: ByteRange;
      ElsPerWord: MCBitRange;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Which = Packp then Pop(CAPPackedBase);
          if RChecks in Requested
          then
            begin
              RangeCheck(UpLowBound, UpHighBound, UpIndexError(Which));
              CheckArrayCAPTransfer
                (UpHighBound, PkLowBound, PkHighBound,
                 PkIndexError(Which))
            end;
          InxReference(false, UpLowBound, UpHighBound, UnpackedRep);
          Pop(UnpackedBase);
          if Which = Unpackp then Pop(CAPPackedBase);
          UnpackedSize := DataBytes(UnpackedRep);
          with PackedRep do
            if BitsPacked in Requested
            then ElsPerWord := MCBitsPerWord div BitSize
            else ElsPerWord := MCBytesPerWord div ByteSize;
          StartCall(SystemRoutine[Which]);
          if NegativeStack
          then
            begin
              LoadCAPEls(PkLowBound, PkHighBound);
              PushLiteral(ElsPerWord);
              PushLiteral(UnpackedSize);
              PushAddress(CAPPackedBase);
              PushAddress(UnpackedBase)
            end
          else
            begin
              PushAddress(UnpackedBase);
              PushAddress(CAPPackedBase);
              PushLiteral(UnpackedSize);
              PushLiteral(ElsPerWord);
              LoadCAPEls(PkLowBound, PkHighBound)
            end;
          CallStdrd(SystemRoutine[Which]);
          FreeEntry(CAPPackedBase);
          FreeEntry(UnpackedBase)
        end
    end { arraycapop };
  
  procedure CheckCAPArrayTransfer(UpHighBound: CAPBound;
                                  PkLowBound, PkHighBound: ObjectValue;
                                  Error: Scalar);
    
    var
      IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;
    
    begin
      Pop(IndexEntry);
      new(IndexRange);
      with IndexRange^ do
        SetBound(UpHighBound, Upper);
      new(LimitedRange);
      with LimitedRange^ do
        begin
          SetBndValue(Lower, PkLowBound.Ival);
          SetBndValue(Upper, PkHighBound.Ival)
        end;
      GetEntry(CheckedEntry);
      with CheckedEntry^ do
        begin
          RunError := Error;
          DataRep := IndexEntry^.DataRep;
          Kind := Operation;
          OpGroup := AnInteger;
          OpForm := RangeChk;
          CheckKind := TransferChecks;
          RequiredRange := IndexRange;
          TransferRange := LimitedRange;
          EntryToCheck := IndexEntry
        end;
      Push(CheckedEntry)
    end { checkcaparrraytransfer };
  
  procedure CAPArrayOp(Which: StdProcFuncs; 
                       UpLowBound, UpHighBound: CAPBound;
                       InnerMost: Boolean;
                       UnpackedRep, PackedRep: TypeRepresentation;
                       PkLowBound, PkHighBound: ObjectValue);
    visible;

    { This procedure is called when the unpacked operand is a   }
    { conformant array and the packed operand is a fixed array. }
    
    var
      PackedBase, CAPUnpackedBase: StackEntry;
      UnpackedSize, PackedSize: ByteRange;
      PackedEls: integer;
      ElsPerWord: MCBitRange;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Which = Packp then Pop(PackedBase);
          PackedEls := Range(PkLowBound, PkHighBound);
          if RChecks in Requested
          then
            begin
              CAPRangeCheck(UpLowBound, UpHighBound, UpIndexError(Which)); 
              CheckCAPArrayTransfer
                (UpHighBound, PkLowBound, PkHighBound,
                 PkIndexError(Which))
            end;
          InxCAPReference
            (false, InnerMost, UpLowBound, UpHighBound, UnpackedRep);
          Pop(CAPUnpackedBase);
          if Which = Unpackp then Pop(PackedBase);
          UnpackedSize := DataBytes(UnpackedRep);
          with PackedRep do
          with PackedRep do
            if BitsPacked in Requested
            then ElsPerWord := MCBitsPerWord div BitSize
            else ElsPerWord := MCBytesPerWord div ByteSize;
          StartCall(SystemRoutine[Which]);
          if NegativeStack
          then
            begin
              PushLiteral(PackedEls);
              PushLiteral(ElsPerWord);
              PushLiteral(UnpackedSize);
              PushAddress(PackedBase);
              PushAddress(CAPUnpackedBase)
            end
          else
            begin
              PushAddress(CAPUnpackedBase);
              PushAddress(PackedBase);
              PushLiteral(UnpackedSize);
              PushLiteral(ElsPerWord);
              PushLiteral(PackedEls)
            end;
          CallStdrd(SystemRoutine[Which]);
          FreeEntry(PackedBase);
          FreeEntry(CAPUnpackedBase)
        end
    end { caparrayop };
  
  procedure CheckCAPCAPTransfer
              (UpHighBound, PkLowBound, PkHighBound: CAPBound;
               Error: Scalar);
    
    var
      IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;
    
    begin
      Pop(IndexEntry);
      new(IndexRange);
      with IndexRange^ do
        SetBound(UpHighBound, Upper);
      new(LimitedRange);
      with LimitedRange^ do
        begin
          SetBound(PkLowBound, Lower);
          SetBound(PkHighBound, Upper)
        end;
      GetEntry(CheckedEntry);
      with CheckedEntry^ do
        begin
          RunError := Error;
          DataRep := IndexEntry^.DataRep;
          Kind := Operation;
          OpGroup := AnInteger;
          OpForm := RangeChk;
          CheckKind := TransferChecks;
          RequiredRange := IndexRange;
          TransferRange := LimitedRange;
          EntryToCheck := IndexEntry
        end;
      Push(CheckedEntry)
    end { checkcapcaptransfer };
  
  procedure CAPCAPOp(Which: StdProcFuncs; 
                     UpLowBound, UpHighBound: CAPBound;
                     InnerMost: Boolean;
                     UnpackedRep, PackedRep: TypeRepresentation;
                     PkLowBound, PkHighBound: CAPBound);
    visible;

    { This procedure is called when both operands are conformant }
    { arrays.                                                    }
    
    var
      CAPPackedBase, CAPUnpackedBase: StackEntry;
      PackedSize, UnpackedSize: ByteRange;
      ElsPerWord: MCBitRange;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          if Which = Packp then Pop(CAPPackedBase);
          if RChecks in Requested
          then
            begin
              CAPRangeCheck(UpLowBound, UpHighBound, UpIndexError(Which)); 
              CheckCAPCAPTransfer
                (UpHighBound, PkLowBound, PkHighBound, 
                 PkIndexError(Which))
            end;
          InxCAPReference
            (false, InnerMost, UpLowBound, UpHighBound, UnpackedRep);
          Pop(CAPUnpackedBase);
          if Which = Unpackp then Pop(CAPPackedBase);
          UnpackedSize := DataBytes(UnpackedRep);
          with PackedRep do
            if BitsPacked in Requested
            then ElsPerWord := MCBitsPerWord div BitSize
            else ElsPerWord := MCBytesPerWord div ByteSize;
          StartCall(SystemRoutine[Which]);
          if NegativeStack
          then
            begin
              LoadCAPEls(PkLowBound, PkHighBound);
              Pushliteral(ElsPerWord);
              PushLiteral(UnpackedSize);
              PushAddress(CAPPackedBase);
              PushAddress(CAPUnpackedBase)
            end
          else
            begin
              PushAddress(CAPUnpackedBase);
              PushAddress(CAPPackedBase);
              PushLiteral(UnpackedSize);
              PushLiteral(ElsPerWord);
              LoadCAPEls(PkLowBound, PkHighBound)
            end;
          CallStdrd(SystemRoutine[Which]);
          FreeEntry(CAPPackedBase);
          FreeEntry(CAPUnpackedBase)
        end
    end { capcapop };

{+doc 22.5  New/Dispose }
  
  procedure PreservePtrReference(HeapOp: StdProcFuncs);
    
    var
      Entry: StackEntry;
    
    begin
      with HpRequests do
        begin
          if HeapOp = Disposep
          then
            begin
              Pop(Entry);
              case Entry^.Kind of
                Reference : 
                  { dispose(p) }
                  PointerEntry := Entry;
                AConstant :
                  { dispose(nil) }
                  begin
                    Estklit(3);
                    Epasop(TRAP);
                    FreeEntry(Entry);
                    GetReference(PointerEntry)
                  end;
                Operation :
                  { dispose(f(p)) }
                  begin
                    Load(Entry);
                    GetReference(PointerEntry);
                    with PointerEntry^ do
                      begin
                        Acquire(MCBytesPerWord, Stack, BaseAddress);
                        AddressArea(BaseAddress, 0, MCBytesPerWord);
                        Eop(Estore)
                      end;
                    FreeEntry(Entry)
                  end
              end
            end
          else Pop(PointerEntry)
        end
    end { preserveptrreference };
  
  procedure LoadPtrReference;
    
    var PtrEntry: StackEntry;
    
    begin
      GetEntry(PtrEntry);
      PtrEntry^ := HpRequests.PointerEntry^;
      if PtrEntry^.Kind = Address then PushNewAccess(PtrEntry, false);
      Push(PtrEntry)
    end { loadptrreference };
  
  procedure LoadPtrAddress;
    
    var PtrEntry: StackEntry;
    
    begin
      LoadPtrReference;
      Pop(PtrEntry);
      PushAddress(PtrEntry);
      FreeEntry(PtrEntry)
    end { loadptrentry };
  
  procedure HeapRequest(Requested: TypeRepresentation);
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        with HpRequests do
          begin
            Request := Requested;
            RequestLevel := 0
          end
    end { heaprequest };
  
  procedure TailorRequest(SelectorOffset: FieldOffset;
                          SelectedRep: TypeRepresentation);
    visible;
    
    begin
      if CodeIsToBeGenerated
      then
        with HpRequests do
          begin
            Request := SelectedRep;
            RequestLevel := RequestLevel + 1
          end
    end { tailorrequest };
  
  procedure HeapOperation(WhichPf: StdProcFuncs; DomainType: TypEntry);
    visible;
    
    var
      Amount: ByteRange;
      Routine: Intrinsic;
    
    procedure ProcessHeap(PresetAction: Boolean);
    
      var
        FileList: ManualList;
        HeapItem: ManualEntry;
    
      begin
        StartManuals(FileList);
        MakeItem(HeapItem);
        HeapItem^.ItsType := DomainType;
        ChainItem(FileList, HeapItem);
        LoadPtrReference;
        IndirectReference(false);
        OpenWith(FrameLevel);
        ProcessManuals(FrameLevel, FileList, PresetAction);
        CloseWith;
        DsposeManuals(FileList)
      end { processheap };
  
    begin
      if CodeIsToBeGenerated
      then
        with HpRequests do
          begin
            PreservePtrReference(WhichPf);
            Amount := DataBytes(Request);
            if WhichPf = Disposep
            then
              begin
                if EmbeddedFile(DomainType) then ProcessHeap(false);
                if RequestLevel = 0
                then Routine := p_dispose1 else Routine := p_dispose2;
                StartCall(Routine);
                if NegativeStack
                then
                  begin
                    PushLiteral(Amount);
                    if Routine = p_dispose2 then PushLiteral(RequestLevel);
                    LoadPtrAddress
                  end
                else
                  begin
                    LoadPtrAddress;
                    if Routine = p_dispose2 then PushLiteral(RequestLevel);
                    PushLiteral(Amount)
                  end;
                CallStdrd(Routine)
              end
            else
              begin
                if RequestLevel = 0
                then Routine := p_new1 else Routine := p_new2;
                StartCall(Routine)
		if NegativeStack
                then
                  begin
                    PushLiteral(Amount);
                    if Routine = p_new2 then PushLiteral(RequestLevel);
                    LoadPtrAddress
                  end
                else
                  begin
                    LoadPtrAddress;
                    if Routine = p_new2 then PushLiteral(RequestLevel);
                    PushLiteral(Amount)
                  end;
                CallStdrd(Routine);
                if EmbeddedFile(DomainType) then ProcessHeap(true);
              end;
            FreeEntry(PointerEntry)
          end
    end { heapoperation };

{+doc 22.6 ICL Pascal Procedures }
  
  procedure SizeOfCAP(PackedSchema, InnerMost: Boolean;
                      LowBound, HighBound: CAPBound;
                      Component: TypeRepresentation);
    visible;

    var Variable, BpEntry, ResultEntry: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          Pop(Variable);
          FreeEntry(Variable);
          GetEntry(BpEntry);
          with BpEntry^ do
            begin
              Kind := Operation;
              OpGroup := ACAP;
              OpForm := CAPSize;
              BpAddress := LowBound.Address;
              SizeKnown := InnerMost;
              WordBounds := false
            end;
          GetEntry(ResultEntry);
          with ResultEntry^ do
            begin
              DataRep := IntegerRepresentation;
              DataRep.Min := 0;
              Kind := Operation;
              OpGroup := AnInteger;
              OpForm := ICLStdrd;
              ICLOp := CAPSizef;
              FirstEntry := BpEntry;
              SecondEntry := nil
            end;
          Push(ResultEntry)
        end
    end { SizeOfCAP };
  
  procedure SizeOfWCAP(PackedSchema, InnerMost: Boolean;
                       LowBound, HighBound: CAPBound;
                       Component: TypeRepresentation);
    visible;

    var Variable, BpEntry, ResultEntry: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          Pop(Variable);
          FreeEntry(Variable);
          GetEntry(BpEntry);
          with BpEntry^ do
            begin
              Kind := Operation;
              OpGroup := ACAP;
              OpForm := CAPSize;
              BpAddress := LowBound.Address;
              SizeKnown := InnerMost;
              WordBounds := true
            end;
          GetEntry(ResultEntry);
          with ResultEntry^ do
            begin
              DataRep := IntegerRepresentation;
              DataRep.Min := 0;
              Kind := Operation;
              OpGroup := AnInteger;
              OpForm := ICLStdrd;
              ICLOp := CAPSizef;
              FirstEntry := BpEntry;
              SecondEntry := nil
            end;
          Push(ResultEntry)
        end
    end { SizeOfWCAP };

  procedure SizeOfUCAP(PackedSchema, InnerMost: Boolean;
                       LowBound, HighBound: CAPBound;
                       Component: TypeRepresentation);
    visible;

    var 
      WordsNeeded, Members: Scalar;
      SizeValue: ObjectValue;
      StoreUnit: AccessUnit;
      ElsPerWord: 2..MCBitsPerWord;

    begin
      if CodeIsToBeGenerated
      then
        if InnerMost
        then
          begin
            StoreUnit := IndexUnit(PackedSchema, Component);
            Members := Range(LowBound.Value, HighBound.Value);
            case StoreUnit of
              Bits :
                begin
                  ElsPerWord := MCBitsPerWord div Component.BitSize;
                  WordsNeeded := WordsFor(Members, ElsPerWord)
                end;
              Bytes :
                begin
                  ElsPerWord := MCBytesPerWord div Component.ByteSize;
                  WordsNeeded := WordsFor(Members, ElsPerWord)
                end;
              Words :
                WordsNeeded := Members * Component.WordSize
            end;
            SetIval(WordsNeeded * MCBitsPerWord, SizeValue);
            StackConstant(SizeValue)
          end
        else
          begin
            { Multi-dimensional unbounded caps not implemented. }
            StackConstant(ZeroValue)
          end
    end { SizeOfCAP };

  procedure SizeRequest(Requested: TypeRepresentation);
    visible;

    var
      Variable: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          Pop(Variable);
          with Variable^ do
            begin
              if AccessKind = Bits
              then Requested.BitSize := BitSize
              else Requested.BitSize := MCBitsPerWord;
              if AccessKind = Bytes
              then Requested.ByteSize := ByteSize
              else Requested.ByteSize := MCBytesPerWord
            end;
          FreeEntry(Variable);
          with HpRequests do
            begin
              Request := Requested;
              RequestLevel := 0
            end
        end
    end { SizeRequest };

  procedure SizeOperation;
    visible;

    var
      BitAmount: Scalar;
      SizeValue: ObjectValue;

    begin
      if CodeIsTobeGenerated
      then
        with HpRequests do
          begin
            with Request do
              if BitSize < MCBitsPerWord
              then BitAmount := BitSize
              else
                if ByteSize <= MCBytesPerHalfWord
                then BitAmount := ByteSize * MCBitsPerByte
                else BitAmount := DataSize(Request) * MCBitsPerByte;
            SetIval(BitAmount, SizeValue);
            StackConstant(SizeValue)
          end
    end { SizeOperation };
  
  procedure StampProcedure(WhichPf: StdProcFuncs);
    visible;

    var Variable: StackEntry;
    
    begin
      if CodeIsToBeGenerated
      then
        begin
          Pop(Variable);
          StartCall(SystemRoutine[WhichPf]);
          PushAddress(Variable);
          CallStdrd(SystemRoutine[WhichPf]);
          FreeEntry(Variable)
        end
    end; { StampProcedure }
  
  begin 
  { end of module }
  end.