{

                          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.

 21.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 "varref.pf"
#include "codeutils.pf"
#include "statstore.pf"
#include "withstmts.pf"
#include "ctlstructs.pf"
#include "expeval.pf"
#include "assgncode.pf"
#include "objvalues.pf"
#include "generator.pf"

{procedure CheckManuals(ManualScope: DispRange; List: ManualList);
  forward;
}

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 RestoreFile (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;

{


 21.2  File-Checks

 Operations on a file-variable are subject to  run-time  checks  to
 verify  that the file variable is defined, that its mode and posi-
 tion are consistent with the intended input/output operation,  and
 that  no  reference is currently extended to the file buffer vari-
 able.  These checks are performed  by  the  procedures  FileVaria-
 bleCheck,  FileModeCheck, FilePosition and CheckLockedFile respec-
 tively.

 In addition, the pre-assertions for the put operation require that
 the  buffer-variable  be  checked  against  the 'undefined' value.
 This is achieved by creating a degenerate manual list containing a
 single  item corresponding to the file buffer variable.  Conceptu-
 ally, this 'buffer item' is regarded as a field of the file  vari-
 able  and  code to check the undefined variable is generated using
 the representation field of the file element type.

 The post-assertions for read, readln, reset, and get require  that
 the  buffer-variable  be  reset  to  the  'undefined' value if the
 operation leaves the file positioned at end of  file.   The  post-
 assertions for all write operations require the buffer variable be
 reset unconditionally.  This is achieved by creating a  degenerate
 manual  list containing a single buffer item and calling procedure
 PresetManuals to generate code to reset the buffer variable to the
 'modified' value.

 Code generation for the file-checks required by the pre-assertions
 for  a  given  I/O  operation  is  triggered  by calling procedure
 DoFileChecks  immediately  prior  to  generating  code   for   the
 input/output operation itself.

 Note that since:

      writeln (f,e1,e2,e3)

 is defined as equivalent to:

      write(f,e1) ; write(f,e2) ; write(f,e3) ; writeln(f)

 the pre- and post-assertions for write must be verified by  making
 a call to DoFileChecks for each implied component write statement.


                                                                     }

procedure LoadFileReference;

  var FileEntry: StackEntry;

  begin
    GetIOBase(FileEntry);
    if FileEntry^.Kind = Address then PushNewAccess(FileEntry, false);
    Push(FileEntry)
  end { loadfilefreference };

procedure LoadFileAddress;

  var FileEntry: StackEntry;

  begin
    GetIOBase(FileEntry);
    LoadAddress(FileEntry);
    FreeEntry(FileEntry)
  end { loadfileaddress };

procedure LoadFileDescriptor;
visible;

  var FileEntry: StackEntry;

  begin
    GetIOBase(FileEntry);
    FileEntry^.DataRep := IntegerRepresentation;
    Load(FileEntry);
    FreeEntry(FileEntry)
  end { loadfiledescriptor };

procedure FileVariableCheck(FileOp: StdProcFuncs);

  begin
    LoadFileDescriptor;
    {case FileOp of
      Resetp : Pcode1(TrapIfFalse, 13);
      Getp, Readp, Readlnp : Pcode1(TrapIfFalse, 15);
      Putp, Pagep, Writep, Writelnp : Pcode1(TrapIfFalse, 10);
      Eoff : Pcode1(TrapIfFalse, 40);
      Eolnf : Pcode1(TrapIfFalse, 41)
    end}
  end { filevariablecheck };

procedure FileModeCheck(Mode: FileModes);

  begin
    LoadFileDescriptor;
    {if Mode = Inspection
    then Pcode3(CheckReadMode) else Pcode3(CheckWriteMode)}
  end { filemodecheck };

procedure FilePositionCheck(FileOp: StdProcFuncs);

  begin
    LoadFileDescriptor;
    {Pcode3(EndOfFile);
    case FileOp of
      Getp, Readp, Readlnp : Pcode1(TrapIfTrue, 16);
      Eolnf : Pcode1(TrapIfTrue, 42)
    end							}
  end { filepositioncheck };

procedure CheckLockedFile;

  var FileEntry: StackEntry;

  begin
    LoadFileReference;
    Pop(FileEntry);
    with FileEntry^ do Adjustment := Adjustment + FileLockOffset;
    LoadAddress(FileEntry);
    {Pcode1(LoadBit, FileLockBit);
    Pcode1(TrapIfTrue, 6);		}
    FreeEntry(FileEntry)
  end { checklockedfile };

procedure CheckUndefinedBuffer;

  var ChecksList: ManualList;
      BufferItem: ManualEntry;

  begin
    StartManuals(ChecksList);
    with SelectedFile^.FileType^ do
      begin
        CreateItem(FelType^.Representation, BufferItem);
        SetItShape(BufferItem, Field);
        SetItCode(BufferItem, Field, ValueChecks);
        AppendManual(ChecksList, BufferItem);
        LoadFileReference;
        FieldReference(BufferOffset, false);
        if not TextFile then IndirectReference(false);
        OpenWith(FrameLevel);
        {CheckManuals(FrameLevel, ChecksList);		}
        CloseWith
      end;
    DisposeManuals(ChecksList)
  end { checkundefinedbuffer };

procedure PostsetBuffer (FileOp : StdProcFuncs);
visible;

  var PresetList: ManualList;
      BufferItem: ManualEntry;
      ExitLabel: CodeLabel;

  begin
    FutureCodeLabel(ExitLabel);
    StartManuals(PresetList);
    with SelectedFile^.FileType^ do
      begin
        if FileOp in [Resetp, Getp, Readp, Readlnp]
        then
          begin
            LoadFileDescriptor;
            {Pcode3(EndOfFile);
            JumpTo(ExitLabel, IfFalse)			}
          end;
        CreateItem(FelType^.Representation, BufferItem);
        SetItShape(BufferItem, Field);
        SetItCode(BufferItem, Field, Presets);
        AppendManual(PresetList, BufferItem);
        LoadFileReference;
        FieldReference(BufferOffset, false);
        if not TextFile then IndirectReference(false);
        OpenWith(FrameLevel);
        PresetManuals(FrameLevel, PresetList);
        CloseWith
      end;
    DisposeManuals(PresetList);
    NxIsCodeLabel(ExitLabel)
  end { postsetbuffer };

procedure DoFileChecks (FileOp : StdProcFuncs);
visible;

  begin
    case FileOp of
      Resetp :
        begin
          FileVariableCheck(Resetp);
          CheckLockedFile
        end;
      Rewritep : CheckLockedFile;
      Getp, Readp, Readlnp :
        begin
          FileVariableCheck(FileOp);
          FileModeCheck(Inspection);
          FilePositionCheck(FileOp);
          CheckLockedFile
        end;
      Putp, Pagep, Writep, Writelnp :
        begin
          FileVariableCheck(FileOp);
          FileModeCheck(Generation);
          if FileOp = Putp then CheckUndefinedBuffer;
          CheckLockedFile
        end;
      Eoff : FileVariableCheck(Eoff);
      Eolnf :
        begin
          FileVariableCheck(Eolnf);
          FilePositionCheck(Eolnf)
        end
    end
  end { dofilechecks };

{


 21.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 FileOperation (Which : StdProcFuncs);
visible;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Checks in Requested then DoFileChecks(Which);
        case Which of
          Resetp :
            begin
              LoadFileAddress;
              {Pcode3(ResetFile)}
            end;
          Rewritep :
            begin
              LoadFileAddress;
              {Pcode3(RewriteFile)}
            end;
          Getp :
            begin
              LoadFileDescriptor;
              {Pcode3(GetFile)}
            end;
          Putp :
            begin
              LoadFileDescriptor;
              {Pcode3(PutFile)}
            end
        end;
        if Checks in Requested then PostsetBuffer(Which)
      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;
          { buffer postset performed by subsequent get }
        end
  end { readbuffer };

procedure WriteBuffer;
visible;

  var Expression: StackEntry;

  begin
    if CodeIsToBeGenerated
    then
      with SelectedFile^ do
        begin
          Pop(Expression);
          if Checks in Requested then SelectCheck(Expression, 18);
          with FileType^ do
            begin
              LoadFileReference;
              BufferReference
                (PackedFile, false, FelType^.Representation);
              Push(Expression);
              Assign(FelType^.Representation)
            end;
          { buffer postset performed by subsequent put }
        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: StackEntry;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Format = Fixed
        then
          begin
            CheckRange(1, MCMaxint, 58);
            Pop(FracDigits)
          end;
        if Format <> Default
        then
          begin
            CheckRange(1, MCMaxint, 58);
            Pop(TotalWidth)
          end
        else
          begin
            new(TotalWidth);
            TotalWidth^ := DefaultWidth^;
            if WriteMode = CharKind
            then TotalWidth^.TheConst.Ival := 1
          end;
        Pop(Expression);
        if Checks in Requested then DoFileChecks(Writep);
        Load(Expression);
        Load(TotalWidth);
        if Format = Fixed then Load(FracDigits);
        LoadFileDescriptor;
        {case WriteMode of
          IntKind : Pcode3(WriteInteger);
          RealKind :
            if Format = Fixed
            then Pcode3(WriteFixedReal) else Pcode3(WriteFloatedReal);
          CharKind : Pcode3(WriteCharacter);
          BoolKind : Pcode3(WriteBoolean);
          StringKind, DefaultKind :
        end;}
        if Checks in Requested then PostsetBuffer(Writep);
        if Format = Fixed then FreeEntry(FracDigits);
        FreeEntry(TotalWidth);
        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);
        if Checks in Requested then DoFileChecks(Writep);
        StringSize := ActualLength.Ival;
        if StringSize > MCBytesPerWord
        then LoadAddress(Expression) else Load(Expression);
        {InlineNumber(StringSize);}
        Load(TotalWidth);
        LoadFileDescriptor;
        {Pcode3(WriteCString);}
        if Checks in Requested then PostsetBuffer(Writep);
        FreeEntry(Expression);
        FreeEntry(TotalWidth)
      end
  end { writestring };

procedure ReadLayout;
visible;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Checks in Requested then DoFileChecks(Readlnp);
        LoadFileDescriptor;
        {Pcode3(ReadLine);}
        if Checks in Requested then PostsetBuffer(Readlnp)
      end
  end { readlayout };

procedure WriteLayout;
visible;

  var Formatter: StackEntry;

  begin
    if CodeIsToBeGenerated
    then
      begin
        Pop(Formatter);
        if Checks in Requested then DoFileChecks(Writelnp);
        LoadFileDescriptor;
        {with Formatter^ do
          if SameValue(TheConst, LineFeed)
          then Pcode3(WriteLine) else Pcode3(PageFile);}
        if Checks in Requested then PostsetBuffer(Writelnp);
        FreeEntry(Formatter)
      end
  end { writelayout };

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 };

{


 21.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.

 Special P-codes are used by the P-machine to perform the  transfer
 operation.   If  runtime  checks  have  been selected, variants of
 these P-codes are employed which additionally check for  undefined
 source  elements  using  the  CheckValue extracted from the source
 array TypeRepresentation.


                                                                     }

procedure LoadCAPEls(BoundPairBlock: RuntimeAddress);

  begin
    with BoundPairBlock do
      begin
        AccessWord(BlockLevel, WordOffset + 1, LoadOp);
        AccessWord(BlockLevel, WordOffset, LoadOp);

      end;
    {Pcode0(SubInteger);
    Pcode0(Inc1)		}
  end { loadcapels };

procedure LoadCAPSize (ForPackedCAP: Boolean;
                       BoundPairBlock: RuntimeAddress);
visible;

  begin
    with BoundPairBlock do
      if ForPackedCAP
      then AccessWord(BlockLevel, WordOffset + 2, LoadOp)
      else
        begin
          AccessWord(BlockLevel, WordOffset, LoadRefOp);
          {Pcode0(SizeCAP)}
        end
  end { loadcapsize };

procedure EmitTransfer(Which: StdProcFuncs;
                       ElementsPerWord: MCBitRange);

  var Instruction: Pcodes;

  begin
    Instruction :=
      TransferCodes[Checks in Requested, Which = Unpackp];
    {Pcode4(Instruction, ElementsPerWord)}
  end { emittransfer };

function ConstantIndex: Boolean;

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

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

  var PackedBase, UnpackedBase, Index: StackEntry;
      PackedEls: MCScalar;
      Convertible, ConstIndex: Boolean;
      ElsPerWord: 2..MCBitsPerWord;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Which = Packp then Pop(PackedBase);
        PackedEls := PkHighBound.Ival - PkLowBound.Ival + 1;
        if ConstantIndex
        then
          begin
            CheckRange
              (UpLowBound.Ival, UpHighBound.Ival,
                 26 + 3 * ord(Which = Unpackp));
            CheckRange
              (-MCMaxint, UpHighBound.Ival - PackedEls + 1,
                 28 + 3 * ord(Which = Unpackp));
            ConstIndex := true
          end
        else ConstIndex := false;
        with PackedRep do
          if WordSize > 1
          then Convertible := false
          else Convertible := (BitSize <= MCBitsPerWord div 2);
        if CodeIsToBeGenerated
        then
          begin
            InxReference
              (false, UpLowBound, UpHighBound, UnpackedRep);
            Pop(UnpackedBase);
            if (Checks in Requested) and (not ConstIndex)
            then
              with UnpackedBase^.Indices^ do
                begin
                  SelectCheck
                    (TheIndex, 26 + 3 * ord(Which = Unpackp));
                  Push(TheIndex);
                  CheckRange
                    (-MCMaxint, UpHighBound.Ival - PackedEls + 1, 1);
                  Pop(TheIndex);
                  SelectCheck(TheIndex, 28 + 3 * ord(Which = Unpackp))
                end;
            if Which = Unpackp then Pop(PackedBase);
            if Convertible
            then
              begin
                LoadAddress(UnpackedBase);
                LoadAddress(PackedBase);
                {InlineNumber(PackedEls);}
                ElsPerWord := MCBitsPerWord div PackedRep.BitSize;
                {if (Which = Unpackp) and (Checks in Requested)
                then InlineNumber(PackedRep.CheckValue.Magnitude);}
                EmitTransfer(Which, ElsPerWord)
              end
            else
              begin
                if Which = Packp
                then LoadAddress(UnpackedBase)
                else LoadAddress(PackedBase);
                if Which = Packp
                then LoadAddress(PackedBase)
                else LoadAddress(UnpackedBase);
                {Pcode1(Move, PackedEls * PackedRep.WordSize)}
              end;
            FreeEntry(UnpackedBase);
            FreeEntry(PackedBase)
          end
      end
  end { arrayarrayop };

procedure CheckArrayCAPTransfer(LowBound, HighBound: MCIntegerForm;
                                CAPBpAddress: RuntimeAddress);

  var IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;

  begin
    Pop(IndexEntry);
    new(IndexRange);
    with IndexRange^ do
      begin
        Lower := LowBound;
        Upper := HighBound;
        CAPBounds := false
      end;
    new(LimitedRange);
    with LimitedRange^ do
      begin
        CAPBounds := true;
        BpAddress := CAPBpAddress
      end;
    GetEntry(CheckedEntry);
    with CheckedEntry^ do
      begin
        RunError := 1;
        DataRep.Min := IndexEntry^.DataRep.Min;
        DataRep.Max := IndexEntry^.DataRep.Max;
        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;

  var CAPPackedBase, UnpackedBase, IndexEntry: StackEntry;
      Convertible: Boolean;
      ElsPerWord: 2..MCBitsPerWord;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Which = Packp then Pop(CAPPackedBase);
        if ConstantIndex
        then
          begin
            Pop(IndexEntry);
            Load(IndexEntry);
            SaveValue(IndexEntry);
            Push(IndexEntry)
          end;
        with PackedRep do
          if WordSize > 1
          then Convertible := false
          else Convertible := (BitSize <= MCBitsPerWord div 2);
        InxReference(false, UpLowBound, UpHighBound, UnpackedRep);
        Pop(UnpackedBase);
        if (Checks in Requested)
        then
          with UnpackedBase^.Indices^ do
            begin
              SelectCheck(TheIndex, 26 + 3 * ord(Which = Unpackp));
              Push(TheIndex);
              CheckArrayCAPTransfer
                (-MCMaxint, UpHighBound.Ival, PkLowBound.Address);
              Pop(TheIndex);
              SelectCheck(TheIndex, 28 + 3 * ord(Which = Unpackp))
            end;
        if Which = Unpackp then Pop(CAPPackedBase);
        if Convertible
        then
          begin
            LoadAddress(UnpackedBase);
            LoadAddress(CAPPackedBase);
            LoadCAPEls(PkLowBound.Address);
            ElsPerWord := MCBitsPerWord div PackedRep.BitSize;
            {if (Which = Unpackp) and (Checks in Requested)
            then InlineNumber(PackedRep.CheckValue.Magnitude);}
            EmitTransfer(Which, ElsPerWord)
          end
        else
          begin
            if Which = Packp
            then LoadAddress(UnpackedBase)
            else LoadAddress(CAPPackedBase);
            LoadCAPSize(true, PkLowBound.Address);
            if Which = Packp
            then LoadAddress(CAPPackedBase)
            else LoadAddress(UnpackedBase);
            {Pcode0(MoveCAP)}
          end;
        FreeEntry(CAPPackedBase);
        FreeEntry(UnpackedBase)
      end
  end { arraycapop };

procedure CheckCAPArrayTransfer(CAPBpAddress: RuntimeAddress;
                                LowBound, HighBound: MCIntegerForm);

  var IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;

  begin
    Pop(IndexEntry);
    new(IndexRange);
    with IndexRange^ do
      begin
        CAPBounds := true;
        BpAddress := CAPBpAddress
      end;
    new(LimitedRange);
    with LimitedRange^ do
      begin
        Lower := LowBound;
        Upper := HighBound;
        CAPBounds := false
      end;
    GetEntry(CheckedEntry);
    with CheckedEntry^ do
      begin
        RunError := 1;
        DataRep.Min := IndexEntry^.DataRep.Min;
        DataRep.Max := IndexEntry^.DataRep.Max;
        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;
                      BpRep, UnpackedRep,
                      PackedRep: TypeRepresentation;
                      PkLowBound, PkHighBound: ObjectValue );
visible;

  var PackedBase, CAPUnpackedBase: StackEntry;
      Convertible: Boolean;
      PackedEls: MCScalar;
      ElsPerWord: 2..MCBitsPerWord;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Which = Packp then Pop(PackedBase);
        PackedEls := PkHighBound.Ival - PkLowBound.Ival + 1;
        with PackedRep do
          if WordSize > 1
          then Convertible := false
          else Convertible := (BitSize <= MCBitsPerWord div 2);
        InxCAPReference
          (false, UpLowBound, UpHighBound, BpRep,
             UnpackedRep);
        Pop(CAPUnpackedBase);
        if Checks in Requested
        then
          with CAPUnpackedBase^.Indices^ do
            begin
              SelectCheck(TheIndex, 26 + 3 * ord(Which = Unpackp));
              Push(TheIndex);
              CheckCAPArrayTransfer
                (UpLowBound.Address, PkLowBound.Ival,
                   PkHighBound.Ival);
              Pop(TheIndex);
              SelectCheck(TheIndex, 28 + 3 * ord(Which = Unpackp))
            end;
        if Which = Unpackp then Pop(PackedBase);
        if Convertible
        then
          begin
            LoadAddress(CAPUnpackedBase);
            LoadAddress(PackedBase);
            {InlineNumber(PackedEls);}
            ElsPerWord := MCBitsPerWord div PackedRep.BitSize;
            {if (Which = Unpackp) and (Checks in Requested)
            then InlineNumber(PackedRep.CheckValue.Magnitude);}
            EmitTransfer(Which, ElsPerWord)
          end
        else
          begin
            if Which = Packp
            then LoadAddress(CAPUnpackedBase)
            else LoadAddress(PackedBase);
            if Which = Packp
            then LoadAddress(PackedBase)
            else LoadAddress(CAPUnpackedBase);
            {Pcode1(Move, PackedEls * PackedRep.WordSize)}
          end;
        FreeEntry(PackedBase);
        FreeEntry(CAPUnpackedBase)
      end
  end { caparrayop };

procedure ChekCAPCAPTransfer(CAP1BpAddress, CAP2BpAddress:
                               RuntimeAddress);

  var IndexEntry, CheckedEntry: StackEntry;
      IndexRange, LimitedRange: RangeEntry;

  begin
    Pop(IndexEntry);
    new(IndexRange);
    with IndexRange^ do
      begin
        CAPBounds := true;
        BpAddress := CAP1BpAddress
      end;
    new(LimitedRange);
    with LimitedRange^ do
      begin
        CAPBounds := true;
        BpAddress := CAP2BpAddress
      end;
    GetEntry(CheckedEntry);
    with CheckedEntry^ do
      begin
        RunError := 1;
        DataRep.Min := IndexEntry^.DataRep.Min;
        DataRep.Max := IndexEntry^.DataRep.Max;
        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;
                    BpRep, UnpackedRep,
                    PackedRep: TypeRepresentation;
                    PkLowBound,PkHighBound: CAPBound );
visible;

  var CAPPackedBase, CAPUnpackedBase: StackEntry;
      Convertible: Boolean;
      ElsPerWord: 2..MCBitsPerWord;

  begin
    if CodeIsToBeGenerated
    then
      begin
        if Which = Packp then Pop(CAPPackedBase);
        with PackedRep do
          if WordSize > 1
          then Convertible := false
          else Convertible := (BitSize <= MCBitsPerWord div 2);
        InxCAPReference
          (false, UpLowBound, UpHighBound, BpRep,
             UnpackedRep);
        Pop(CAPUnpackedBase);
        if Checks in Requested
        then
          with CAPUnpackedBase^.Indices^ do
            begin
              SelectCheck(TheIndex, 26 + 3 * ord(Which = Unpackp));
              Push(TheIndex);
              ChekCAPCAPTransfer
                (UpLowBound.Address, PkLowBound.Address);
              Pop(TheIndex);
              SelectCheck(TheIndex, 28 + 3 * ord(Which = Unpackp))
            end;
        if Which = Unpackp then Pop(CAPPackedBase);
        if Convertible
        then
          begin
            LoadAddress(CAPUnpackedBase);
            LoadAddress(CAPPackedBase);
            LoadCAPEls(PkLowBound.Address);
            ElsPerWord := MCBitsPerWord div PackedRep.BitSize;
            {if (Which = Unpackp) and (Checks in Requested)
            then InlineNumber(PackedRep.CheckValue.Magnitude);}
            EmitTransfer(Which, ElsPerWord)
          end
        else
          begin
            if Which = Packp
            then LoadAddress(CAPUnpackedBase)
            else LoadAddress(CAPPackedBase);
            LoadCAPSize(true, PkLowBound.Address);
            if Which = Packp
            then LoadAddress(CAPPackedBase)
            else LoadAddress(CAPUnpackedBase);
            {Pcode0(MoveCAP)}
          end;
        FreeEntry(CAPPackedBase);
        FreeEntry(CAPUnpackedBase)
      end
  end { capcapop };

{


 21.5  New/Dispose

 The parameters to new and dispose are saved in fields of the  glo-
 bal  record  variable  HPRequests  by  one  call  to the procedure
 HeapRecord  and  zero  or  more  subsequent  calls  to   procedure
 TailorRequest.   The effect of these is to preserve a reference to
 the pointer variable, and to  chain  the  initial  and  subsequent
 tailored  requests for heap storage on a linear list referenced by
 fields FirstReq and LastReq of HPRequests.  Note  that  since  the
 storage required for a variant record is the sum of its fixed part
 and largest variant, a call new(p) will in  general  over-allocate
 heap  storage  for  all  but the largest variant.  A call new(p,c)
 however, will tailor storage exactly, if the variant labelled by c
 has  no  nested variants.  Note that this is secure only if subse-
 quent checks are generated to ensure the tag field is never set to
 a  value  other  than  c,  and  that  p^ is never referenced in an
 assignment statement, or used as a factor.

 The checks for consistency between new and dispose  are  generated
 by  presetting the selector fields to the appropriate values after
 storage has been allocated.  In addition, the  preselection  flags
 are  set in the control word of the record to indicate the variant
 selectors are effectively 'locked'.  Code for these checks is gen-
 erated by procedure PreSelectVariants.  Corresponding code to ver-
 ify a subsequent dispose is generated by procedure  CheckPreselec-
 tedVariants.

 The P-machine automatically presets newly allocated  heap  storage
 so that each word is initially 'undefined'.  For domain types that
 require  manual  presetting  via  generated  code,  the  procedure
 PresetHeap  will  pass a preset list containing a single heap-item
 to the code-generating procedure PresetManuals.  Domain types con-
 taining  embedded files are similarly processed by procedure Post-
 SetHeap.

 Security against the use of 'dangling' or 'undefined' pointers  is
 provided  by  a  method described by Fischer and Leblanc whereby a
 'key' is embedded by the P-machine in both  the  pointer-variable,
 and the dynamic variable.  Every pointer reference is subsequently
 checked to ensure the keys match.  On  a  dispose,  the  P-machine
 garbage  collector  erases  the heap key and dangling pointers are
 subsequently detected by key  mismatch.   This  technique  is  not
 totally  secure  since  the erased key location may coincidentally
 re-acquire the same value as actual data after re-allocation,  but
 the probability of this happening is very low.


                                                                     }

procedure PreservePtrReference(HeapOp: StdProcFuncs);

  var Entry: StackEntry;
      ResultSize: WordRange;

  begin
    with HpRequests do
      begin
        if HeapOp = Disposep
        then
          begin
            Pop(Entry);
            case Entry^.Kind of
              Reference :
                begin
                  PointerEntry := Entry;
                  with PointerEntry^ do
                    begin
                      RunError := 0;
                      DataRep := DefaultRepresentation
                    end
                end;
              AConstant :
                begin
                  PredictedError(3);
                  FreeEntry(Entry);
                  GetReference(PointerEntry)
                end;
              Operation :
                begin
                  Load(Entry);
                  ResultSize := PtrRepresentation.WordSize;
                  GetReference(PointerEntry);
                  with PointerEntry^ do
                    begin
                      Acquire(ResultSize, BaseAddress);
                      with BaseAddress do
                        if ResultSize = 1
                        then
                          AccessWord(BlockLevel, WordOffset, StoreOp)
                        else
                          begin
                            AccessWord
                              (BlockLevel, WordOffset, LoadRefOp);
                            {Pcode1(StoreMultiple, ResultSize)}
                          end
                    end;
                  FreeEntry(Entry)
                end
            end
          end
        else Pop(PointerEntry);
        if Checks in Requested then SaveAddress(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);
    LoadAddress(PtrEntry);
    FreeEntry(PtrEntry)
  end { loadptrentry };

procedure CheckDispose;

  begin
    with HpRequests do
      begin
        LoadPtrAddress;
        {Pcode0(LoadPointer);
        if LastReq^.ReqLevel > 0
        then Pcode1(CheckDsp2, LastReq^.ReqLevel)
        else Pcode0(CheckDsp1)}
      end
  end { checkdispose };

procedure CheckPreselectedVariants;

  var ThisReq: RequestEntry;
      SelectorEntry: StackEntry;

  begin
    with HpRequests do
      if FirstReq <> LastReq
      then
        begin
          ThisReq := FirstReq;
          repeat
            ThisReq := ThisReq^.Next;
            with ThisReq^ do
              begin
                LoadPtrReference;
                IndirectReference(false);
                FieldReference(SelectorField, false);
                Pop(SelectorEntry);
                Load(SelectorEntry);
                FreeEntry(SelectorEntry);
                {InlineNumber(SelectorValue);
                Pcode0(TestIEqual);
                Pcode1(TrapIfFalse, 22)}
              end
          until ThisReq = LastReq
        end
  end { checkpreselectedvariants };

procedure PreselectVariants;

  var ThisReq: RequestEntry;
      CheckValue: ObjectValue;
      LockSettings: MCWordForm;

  procedure LoadFirstWord;

    var PtrEntry: StackEntry;

    begin
      LoadPtrReference;
      Pop(PtrEntry);
      PtrEntry^.DataRep.WordSize := 1;
      Load(PtrEntry);
      FreeEntry(PtrEntry)
    end { loadfirstword };

  begin
    with HpRequests do
      if FirstReq <> LastReq
      then
        begin
          LockSettings.WValue := 0;
          ThisReq := FirstReq;
          repeat
            ThisReq := ThisReq^.Next;
            with ThisReq^ do
              begin
                LoadPtrReference;
                IndirectReference(false);
                FieldReference(SelectorField, false);
                SetIval(SelectorValue, CheckValue);
                StackConstant(CheckValue);
                Assign(IntegerRepresentation);
                MCSetBit(LockSettings, 3 * ReqLevel - 2)
              end
          until ThisReq = LastReq;

          { store preselection locks }
          {InlineNumber(LockSettings.WValue);}
          LoadFirstWord;
          {Pcode0(StoreIndirect);}

          { store request levels }
          {InlineNumber(LastReq^.ReqLevel);}
          LoadFirstWord;
          {Pcode1(AdjustMinus, 2);
          Pcode0(StoreIndirect)}
        end
  end { preselectvariants };

procedure PostsetHeap;

  var PostsetList: ManualList;
      HeapItem: ManualEntry;

  begin
    StartManuals(PostsetList);
    with HpRequests do
      begin
        CreateItem(FirstReq^.Request, HeapItem);
        SetItShape(HeapItem, Vars);
        SetItCode(HeapItem, Vars, Postsets);
        AppendManual(PostsetList, HeapItem);
        if HeapItem^.ItsCode <> None
        then
          begin
            LoadPtrReference;
            IndirectReference(false);
            OpenWith(FrameLevel);
            PostsetManuals(FrameLevel, PostsetList);
            CloseWith
          end
      end;
    DisposeManuals(PostsetList)
  end { postsetheap };

procedure PresetHeap;

  var PresetList: ManualList;
      HeapItem: ManualEntry;

  begin
    StartManuals(PresetList);
    with HpRequests do
      begin
        CreateItem(FirstReq^.Request, HeapItem);
        SetItShape(HeapItem, Vars);
        SetItCode(HeapItem, Vars, Presets);
        AppendManual(PresetList, HeapItem);
        if HeapItem^.ItsCode <> None
        then
          begin
            LoadPtrReference;
            IndirectReference(false);
            OpenWith(FrameLevel);
            PresetManuals(FrameLevel, PresetList);
            CloseWith
          end
      end;
    DisposeManuals(PresetList)
  end { presetheap };

procedure HeapRequest (Requested: TypeRepresentation);
visible;

  var ThisReq: RequestEntry;

  begin
    if CodeIsToBeGenerated
    then
      begin
        new(ThisReq);
        with ThisReq^ do
          begin
            Next := nil;
            Request := Requested;
            ReqLevel := 0
          end;
        with HpRequests do
          begin
            FirstReq := ThisReq;
            LastReq := ThisReq
          end
      end
  end { heaprequest };

procedure TailorRequest (SelectorRep, SelectedRep: TypeRepresentation);
visible;

  var ThisReq: RequestEntry;

  begin
    if CodeIsToBeGenerated
    then
      with HpRequests do
        begin
          new(ThisReq);
          with ThisReq^ do
            begin
              Next := nil;
              Request := SelectedRep;
              ReqLevel := LastReq^.ReqLevel + 1;
              {SelectorValue := SelectedRep.CheckValue.Magnitude;}
              SelectorField := SelectorRep.Selector
            end;
          LastReq^.Next := ThisReq;
          LastReq := ThisReq
        end
  end { tailorrequest };

procedure HeapOperation (WhichPf: StdProcFuncs);
visible;

  var Amount: WordRange;
      ThisReq: RequestEntry;

  begin
    if CodeIsToBeGenerated
    then
      with HpRequests do
        begin
          PreservePtrReference(WhichPf);
          if (WhichPf = Disposep) and (Checks in Requested)
          then
            begin
              CheckDispose;
              CheckPreselectedVariants;
              PostsetHeap
            end;
          LoadPtrAddress;
          Amount := LastReq^.Request.WordSize;
          {if WhichPf = Newp
          then Pcode1(New1, Amount) else Pcode1(Dispose1, Amount);}
          if (WhichPf = Newp) and (Checks in Requested)
          then
            begin
              PresetHeap;
              PreselectVariants
            end;

          { now discard the requests }
          while FirstReq <> nil do
            begin
              ThisReq := FirstReq;
              FirstReq := ThisReq^.Next;
              dispose(ThisReq)
            end;
          FreeEntry(PointerEntry)
        end
  end { heapoperation };

begin
{ end of module }
end.