Topspeed_JPI/TS-V3/REP16/GENLISTS.MOD

IMPLEMENTATION MODULE GenLists;
(*
 *  REPERTOIRE
 *  Release 1.6
 *  By Charles Bradford and Cole Brecheen
 *  (c) Copyright 1985-1992 PMI
 *  Green Bay, Wisconsin
 *  All rights reserved
 *  (414) 468-6040
 *
 *  $Header:   D:/logfiles/mods/genlists.mov   1.6   30 Dec 1990 17:41:34   coleb  $
 *
 *)


(*EntryDiag:
IMPORT Diagnostics;
:EntryDiag*)

IMPORT ErrorManager;
IMPORT LowLevel;
IMPORT M2Strings;
IMPORT Numbers;
IMPORT NumTypes;
IMPORT PosUtils;
IMPORT StrEdit;
IMPORT StrConv;
IMPORT SYSTEM;
IMPORT VStorage;

VAR
  ModInitialized : BOOLEAN;

  PROCEDURE Init();
    BEGIN
      IF ModInitialized THEN
        RETURN;
      ELSE
        ModInitialized := TRUE;
      END;
(*EntryDiag:
      Diagnostics.Init();
:EntryDiag*)

      ErrorManager.Init();
      LowLevel.Init();
      M2Strings.Init();
      Numbers.Init();
      NumTypes.Init();
      PosUtils.Init();
      StrEdit.Init();
      StrConv.Init();
      VStorage.Init();
(*EntryDiag:
      Diagnostics.diagS( 'Entering GenLists', '' );
:EntryDiag*)

      ErrorFlag := NoListError;
      DiagMode := FALSE;

(*EntryDiag:
      Diagnostics.diagS( 'Exiting GenLists', '' );
:EntryDiag*)
    END Init;

  CONST
    InitKey = 53304;
    NoMemErStr = "Lack Memory";
    RangeErStr = "GenList ref. out of range";
    Circularity = "Can't insert a list into itself";

  TYPE
    GenList = POINTER TO GenListRec;
    ElmtPtr = POINTER TO GenElmt;
    GenElmt =
      RECORD
        FromBlock : BOOLEAN;
        (*We have to track this because the BlockToList procedure
          could assign addresses and sizes to a data area that it
          did not get from the Storage module.*)
        size : CARDINAL;
        prv, nxt : ElmtPtr;
        type : CARDINAL;
        CASE : CARDINAL OF
        (* Changed from tagged to untagged variant 14 Nov 87
           because Stony Brook actually enforces matched
           references.  Making type a tag never did anything for
           us anyway. *)
          0 :
          elem : SYSTEM.ADDRESS;
        | ListCode :
          Lelem : POINTER TO GenList;
        | StrCode :
          Selem : POINTER TO ARRAY [0..255] OF CHAR;
        (*Using extremely large strings here seem to blow the
          RTD's workspace, for some reason.*)
        | 65530 :
          handle : VStorage.MemHandle;
        | 65529 :
          Ielem : POINTER TO INTEGER;
        | 65528 :
          Celem : POINTER TO CARDINAL;
        | 65527 :
          Belem : POINTER TO BOOLEAN;
        | 65526 :
          Chelem : POINTER TO CHAR;
        END;
      END;

    BlockDescriptor =
      RECORD
        ElmtRecsAddr : SYSTEM.ADDRESS;
        ElmtRecsSize : CARDINAL;
        DataAddr : VStorage.MemHandle;
        DataSize : CARDINAL;
      END;

    GenListRec =
      RECORD
        ParentList : GenList;
      (*This has to be the first field in the record.*)
        InitCheck : CARDINAL;
        BlockList : GenList;
      (*A list of BlockDescriptors.  Used only when the list is
        allocated with BlockToList.*)
        current, lngth : CARDINAL;
        first, now, last : ElmtPtr;
      END;


  PROCEDURE AdrOfList(VAR TheList : GenList) : SYSTEM.ADDRESS;
    BEGIN
      RETURN SYSTEM.ADR(TheList);
    END AdrOfList;


  PROCEDURE AdrToList(TheAddr : SYSTEM.ADDRESS; TheSize : CARDINAL; VAR
      TheList : GenList) : BOOLEAN;
    BEGIN
      IF TheSize # SYSTEM.TSIZE(GenList) THEN
        RETURN FALSE;
      ELSE
        LowLevel.Move(TheAddr, SYSTEM.ADR(TheList), TheSize);
        RETURN TRUE;
      END;
    END AdrToList;



  PROCEDURE ListMove(TheList : GenList; spot : CARDINAL) : BOOLEAN;
    VAR
      dist1, dist2, dist3, SmallestDist : INTEGER;
    BEGIN
      IF spot=0 THEN
      (*diag*)
        ErrorFlag := RefToZero;
        RETURN FALSE;
      END;
      WITH TheList^ DO
        IF spot>lngth THEN
          current := lngth;
          now := last;
          ErrorFlag := RefPastEnd;
          RETURN FALSE;
        ELSE
          dist1 := INTEGER(spot)-1;
          dist2 := INTEGER(spot)-INTEGER(lngth);
          dist3 := INTEGER(spot)-INTEGER(current);
        (*Now we need to know which of these is smallest.*)
          IF ABS(dist1)>ABS(dist2) THEN
            IF ABS(dist2)>ABS(dist3) THEN
              SmallestDist := dist3;
            ELSE
              now := last;
              current := lngth;
              SmallestDist := dist2;
            END;
          ELSE
            IF ABS(dist1)>ABS(dist3) THEN
              SmallestDist := dist3;
            ELSE
              now := first;
              current := 1;
              SmallestDist := dist1;
            END;
          END;
          IF SmallestDist>0 THEN
            WHILE (current<spot) AND (now#NIL) DO
              now := now^.nxt;
              INC(current);
            END;
          ELSE
            WHILE (current>spot) AND (now#NIL) DO
              now := now^.prv;
              DEC(current);
            END;
          END;
        END;
      END;
      ErrorFlag := NoListError;
      RETURN TRUE;
    END ListMove;


  PROCEDURE MoveToSpot(TheList : GenList; spot : CARDINAL);
    VAR
      TmpStr: ARRAY [0..47] OF CHAR;
    BEGIN
      IF NOT ListMove(TheList,spot) THEN
        StrConv.CardinalToStr( spot, 0, TmpStr );
        M2Strings.Insert( "Can't move to list spot ", TmpStr, 0 );
        ErrorManager.WARN(TmpStr);
      END;
    END MoveToSpot;


  PROCEDURE GetChildList(TheList : GenList; spot : CARDINAL; VAR
      Child : GenList);
    BEGIN
      MoveToSpot( TheList, spot );
      IF (TheList^.now^.type#ListCode) OR (TheList^.now^.size# SYSTEM.TSIZE(
          GenList)) THEN
        ErrorFlag := NoSuchList;
        ErrorManager.WARN('Non-list passed to GetChildList');
        RETURN;
      END;
      VStorage.ReadMem(TheList^.now^.handle, 0,
          SYSTEM.ADR(Child), SYSTEM.TSIZE(GenList));
      ErrorFlag := NoListError;
    END GetChildList;


  PROCEDURE CircularLinkage( ElmtAdr: SYSTEM.ADDRESS; ElmtSize:
      CARDINAL; BigList : GenList; GoingUp: BOOLEAN ): BOOLEAN;
    (*Here we are trying to detect attempts to insert a list into
      itself, or into one of its own sublists, or into a list
      into which it has already been inserted.*)
    VAR
      tmpsize, cnt, TypeCode, ListEnd : CARDINAL;
      tmpadr : SYSTEM.ADDRESS;
      SubList, SmallList: GenList;
    BEGIN
      IF (NOT DiagMode) OR (BigList = NIL) THEN
        RETURN FALSE;
      END;
      IF NOT AdrToList( ElmtAdr, ElmtSize, SmallList ) THEN
        RETURN FALSE;
      END;
      IF SmallList = NIL THEN
        (*Note that it's okay to have more than one NIL list
          in a list.*)
        RETURN FALSE;
      END;
      IF (SmallList = BigList) THEN
        ErrorFlag := corruption;
        RETURN TRUE;
      END;
      IF GoingUp AND (BigList^.ParentList # NIL) THEN
        IF CircularLinkage( ElmtAdr, ElmtSize, BigList^.ParentList, TRUE ) THEN
          RETURN TRUE;
        END;
      END;
      ListEnd := ListLength( BigList );
      FOR cnt := 1 TO ListEnd DO
        GetElmtAdr( BigList, cnt, tmpadr, tmpsize, TypeCode );
        IF TypeCode = ListCode THEN
          GetChildList( BigList, cnt, SubList );
          IF (SmallList = SubList) THEN
            ErrorFlag := corruption;
            RETURN TRUE;
          ELSE
            IF CircularLinkage( ElmtAdr, ElmtSize, SubList, FALSE ) THEN
              RETURN TRUE;
            END;
          END;
        END;
      END;
      RETURN FALSE;
    END CircularLinkage;


  PROCEDURE InitResponse(msg : ARRAY OF CHAR);
  (*All calls to InitResponse are diagnostic.  Remove them from
    finished programs.*)
    VAR
      TmpStr : ARRAY [0..79] OF CHAR;
    BEGIN
      StrEdit.AssignStr('Uninit. list passed to ', TmpStr);
      StrEdit.Append(TmpStr, msg);
      ErrorManager.WARN(TmpStr);
    END InitResponse;


(* ===========================
   Exported procedures.
   =========================== *)


  PROCEDURE NewList(VAR TheList : GenList);
    VAR
      size : CARDINAL;
    BEGIN
      IF (NOT ModInitialized) THEN Init() END;
      size := SYSTEM.TSIZE(GenListRec);
      VStorage.DosAlloc(TheList, SYSTEM.TSIZE(GenListRec));
      TheList^.InitCheck := InitKey;
      TheList^.ParentList := NIL;
      TheList^.BlockList := NIL;
      TheList^.current := 0;
      TheList^.lngth := 0;
      TheList^.first := NIL;
      TheList^.now := NIL;
      TheList^.last := NIL;
      ErrorFlag := NoListError;
    END NewList;


  PROCEDURE BlockToList(TheAddr: SYSTEM.ADDRESS; BlockSize: CARDINAL;
      delimiter1, delimiter2: ARRAY OF CHAR; RecSize, TypeCode:
      CARDINAL; VAR TheList: GenList);

  (*We're doing a lot of stuff to avoid problems with disposing
    of lists created this way.  The problems tend to arise
    because the Storage module doesn't know that any of this stuff
    has been allocated except the big contiguous areas for the
    data and the list.*)

  VAR
    cnt, spot1, spot2, Delim1Len, Delim2Len, elements: CARDINAL;
    TmpBlockDescr: BlockDescriptor;
    TmpList: GenList;
    TwoDelimiters, FixedLengthRecs: BOOLEAN;
    BlockAdr: SYSTEM.ADDRESS;

    PROCEDURE MakeOneList(TheList: GenList);
    VAR
      Tmptr, OldPtr: ElmtPtr;
      CheckStr: ARRAY [0..15] OF CHAR;
      SubList: GenList;
      EndFound : BOOLEAN;
      tmpadr: SYSTEM.ADDRESS;
    BEGIN
      IF (NOT FixedLengthRecs) AND TwoDelimiters THEN
        spot2 := spot1;
        IF TypeCode < 65000 THEN
          (* getting type from file, so make room for it *)
          INC(spot2, 2);
        END;
        IF 0 = PosUtils.PosAdr(delimiter2, LowLevel.AddAddr(BlockAdr, spot2),
                 BlockSize - spot2) THEN
          (* If an ending delimiter starts this list, it is a null
            list, so exit without putting any elements in it *)
          spot1 := spot2;
          RETURN;
        END;
      END;
      OldPtr := NIL;
      EndFound := FALSE;
      WHILE (cnt <= (elements - 1)) AND (NOT EndFound) DO
        Tmptr := ElmtPtr( LowLevel.AddAddr(TmpBlockDescr.ElmtRecsAddr,
            (cnt * SYSTEM.TSIZE(GenElmt))));
          (*Tmptr gets the address of the next unused area of the
            list block.*)
        INC(cnt);
        IF TwoDelimiters AND (Delim1Len > 0) THEN
          spot1 := PosUtils.PosAdr(delimiter1,
              LowLevel.AddAddr(BlockAdr, spot1), BlockSize -
              spot1) + Delim1Len + spot1;
          IF spot1 > BlockSize THEN
            spot1 := BlockSize;
          END;
          (*We've found the next delimiter1*)
        END;
        IF TypeCode < 65000 THEN
          (*Any type code above 65000 REPERTOIRE considers one of
            its own.  Because it doesn't know what this type code
            is, we leave room to get it from the block.*)
          tmpadr := LowLevel.AddAddr(BlockAdr, spot1);
          LowLevel.Move( tmpadr, SYSTEM.ADR(Tmptr^.type), 2);
          IF Tmptr^.type = ListCode THEN
            (*Now we call ourselves recursively.*)
            NewList(SubList);
            LowLevel.Move(SYSTEM.ADR(SubList), LowLevel.AddAddr(BlockAdr,
                spot1 - 2), SYSTEM.TSIZE(GenList));
            (*We're using an unused part of the data block for
              the data area of SubList.*)
            Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1 - 2);
            SubList^.ParentList := TheList;
            MakeOneList(SubList);
            INC(spot1, Delim2Len);
          ELSE
            Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1 + 2);
          END;
        ELSE
          (*We do know what the type code is--we assume it's not in
            the block.*)
          Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1);
            (*Tmptr^.elem gets the address of some area of the data
              block.*)
          Tmptr^.type := TypeCode;
        END;
        IF NOT FixedLengthRecs THEN
          IF Tmptr^.type = ListCode THEN
            RecSize := 4;
          ELSE
            spot2 := PosUtils.PosAdr(delimiter2,
                LowLevel.AddAddr(BlockAdr, spot1), BlockSize -
                spot1) + spot1;
            IF TypeCode < 65000 THEN
              (*We don't know what the type code is--we want to get
                it from the block--so we assume the first two bytes
                contain it.*)
              IF (spot1 + 2) > spot2 THEN
                (*Something is horribly wrong; try to slip out
                  without being noticed.*)
                RETURN;
              END;
              RecSize := (spot2 - spot1) - 2;
            ELSE
              (*We know what the type code is, so we assume it's not
                in the block.*)
              RecSize := spot2 - spot1;
            END;
            spot1 := spot2 + Delim2Len;
            (*spot1 should now be pointing at the byte
              immediately following the delimiter2 that we just found.*)
          END;
          LowLevel.Fill(SYSTEM.ADR(CheckStr), HIGH(CheckStr) + 1, 0C);
(*
IF cnt >= 171 THEN
  Diagnostics.diagA( 'BlockAdr', BlockAdr );
  Diagnostics.diagC( 'spot1', spot1 );
  Diagnostics.diagC( 'BlockSize', BlockSize );
  Diagnostics.diagS( 'CheckStr', CheckStr );
END;
*)
          IF (spot1+Delim2Len) >= BlockSize THEN
            (* Corrects an OS/2 segmentation fault. *)
            EndFound := TRUE;
          ELSE
            tmpadr := LowLevel.AddAddr(BlockAdr, spot1);
            LowLevel.Move( tmpadr, SYSTEM.ADR(CheckStr), Delim2Len);
            IF TwoDelimiters AND (M2Strings.CompareStr(CheckStr, delimiter2) = 0) THEN
              (*We've found two delimiter2's in a row, so this list
                is ended.*)
              EndFound := TRUE;
            END;
          END;
        ELSE
          spot1 := cnt * RecSize;
        END;
        Tmptr^.FromBlock := TRUE;
        Tmptr^.size := RecSize;
        Tmptr^.prv := OldPtr;
        IF OldPtr = NIL THEN
          TheList^.current := 1;
          TheList^.first := Tmptr;
          TheList^.now := Tmptr;
        ELSE
          OldPtr^.nxt := Tmptr;
        END;
        OldPtr := Tmptr;
        INC(TheList^.lngth);
      END;
      Tmptr^.nxt := NIL;
      TheList^.last := Tmptr;
    END MakeOneList;

  BEGIN
    IF (NOT ModInitialized) THEN Init() END;
    (*BlockToList*)
    IF NOT Initialized(TheList) THEN
    (*diag*)
      InitResponse('BlockToList');
      RETURN;
    END;
    Delim1Len := M2Strings.Length(delimiter1);
    Delim2Len := M2Strings.Length(delimiter2);
    TwoDelimiters := FALSE;
    IF VStorage.InEms( VStorage.MemHandle(TheAddr) ) THEN
      BlockAdr := VStorage.LockMem( VStorage.MemHandle(TheAddr) );
      VStorage.UnLockMem( VStorage.MemHandle(TheAddr) );
    ELSE
      BlockAdr := TheAddr;
    END;
    IF ((Delim1Len>0) OR (Delim2Len>0)) AND (RecSize>0) THEN
      (*diag*)
      ErrorManager.WARN("Delim-RecSize conflict");
      RETURN;
    END;
      (*Next determine how many elements are in the block.*)
    FixedLengthRecs := RecSize > 0;
    IF FixedLengthRecs THEN
      elements := BlockSize DIV RecSize;
    ELSE
      (*The records are going to be of variable length.*)
      IF M2Strings.CompareStr(delimiter1, delimiter2) # 0 THEN
        TwoDelimiters := TRUE;
      END;
      cnt := 0;
      elements := 0;
      REPEAT
        (*We count the delimiter2s in the block to determine how
          many list elements there will be.*)
        spot1 := PosUtils.PosAdr(delimiter2, LowLevel.AddAddr(BlockAdr, cnt),
            BlockSize - cnt);
        IF spot1 < (BlockSize - cnt) THEN
          INC(elements);
        END;
        INC(cnt, spot1 + Delim2Len);
      UNTIL cnt >= BlockSize;
    END;
(*
Diagnostics.diagC( 'elements', elements );
*)
    IF (VAL(LONGINT, elements) * VAL(LONGINT,
        SYSTEM.TSIZE(GenElmt))) > NumTypes.L65535 THEN
      ErrorManager.WARN('RecSize too small');
      (*User has probably reduced RecNameLength to the point
        that the list's controlling records will take up more
        space than its data.  If so, user needs to reduce size of
        ThisChunk in NdxBones.ReadNdx.*)
      RETURN;
    END;
    NewList(TmpList);
    TheList^.BlockList := TmpList;
    WITH TmpBlockDescr DO
      DataAddr := VStorage.MemHandle(TheAddr);
      DataSize := BlockSize;
      ElmtRecsSize := elements * SYSTEM.TSIZE(GenElmt);
      VStorage.DosAlloc(ElmtRecsAddr, ElmtRecsSize);
        (*Allocates a contiguous area of memory for the GenList.
          Note that we can't just append a list element for every
          RecSize'd area of the block using ListInsert because
          that would allocate an unnecessary, fragmented copy of
          the block.*)
    END;
    ListInsert(TmpBlockDescr, 0, TheList^.BlockList, 65535);
      (*Insert the BlockDescriptor into the BlockList, using 0 as
        the type code.*)
    IF elements = 0 THEN
      RETURN;
    END;
    (*From here down we're actually building TheList.*)
    spot1 := 0;
      (*spot1 tracks the position of the last delimiter1 we've
        found.*)
    spot2 := 0;
      (*spot2 tracks the position of the last delimiter2 we've
        found.*)
    cnt := 0;
      (*cnt tracks the number of elements we've processed.*)
    MakeOneList(TheList);
      (*MakeOneList processes elements until all elements have
      been processed or until two delimiter2's are found in a row.*)
    IF FixedLengthRecs AND ((BlockSize MOD RecSize) # 0) THEN
      (*Note that we may already have allocated lots of memory
        for the list.  If you're sure it's invalid, you have to
        DisposeList(TheList) when BlockToList returns FALSE.*)
      ErrorFlag := underflow;
      ErrorManager.WARN('Bad Recsize');
      RETURN;
    END;
    ErrorFlag := NoListError;
  END BlockToList;



  PROCEDURE ChangeTypeCode(VAR TheList : GenList; spot, NewTypeCode :
      CARDINAL);
    BEGIN
      MoveToSpot( TheList, spot );
      TheList^.now^.type := NewTypeCode;
    END ChangeTypeCode;


  PROCEDURE CopyList(InList : GenList; VAR OutList : GenList);
    VAR
      spot, OldSize, OldType, lngth : CARDINAL;
      OldAdr : SYSTEM.ADDRESS;
      OldChild, NewChild : GenList;
    BEGIN
      IF (NOT ModInitialized) THEN Init() END;
      ErrorFlag := NoListError;
      IF NOT Initialized(InList) THEN
      (*diag*)
        InitResponse('Copy');
        RETURN;
      END;
      NewList(OutList);
      lngth := ListLength(InList);
      FOR spot := 1 TO lngth DO
        GetElmtAdr(InList, spot, OldAdr, OldSize, OldType);
        IF OldType=ListCode THEN
          VStorage.ReadMem(InList^.now^.handle, 0,
              SYSTEM.ADR(OldChild), SYSTEM.TSIZE(GenList));
          IF OldChild = NIL THEN
            NewChild := NIL;
          ELSE
            CopyList(OldChild, NewChild);
              (*recursive call*)
          END;
          OldAdr := SYSTEM.ADR(NewChild);
          OldSize := SYSTEM.TSIZE(GenList);
        END;
        ListInsertAdr(OldAdr, OldSize, OldType, OutList, spot);
      END;
      IF NOT ListMove( OutList, 1 ) THEN
        (*Do nothing; point is just to reset current to 1 for
          convenience of screen system.*)
      END;
    END CopyList;


  PROCEDURE DisconnectLists( VAR sublist, mainlist: GenList );
    VAR
      ListEnd, cnt, TypeCode, tmpsize: CARDINAL;
      tmpadr: SYSTEM.ADDRESS;
      tmplist: GenList;
    BEGIN
      ListEnd := ListLength( mainlist );
      FOR cnt := 1 TO ListEnd DO
        GetElmtAdr( mainlist, cnt, tmpadr, tmpsize, TypeCode );
        IF (TypeCode = ListCode) AND AdrToList( tmpadr, tmpsize, tmplist ) THEN
          IF (sublist = tmplist) THEN
            mainlist^.now^.type := 0;
            sublist^.ParentList := NIL;
          ELSE
            IF Initialized( tmplist ) THEN
              DisconnectLists( sublist, tmplist );
            END;
          END;
        END;
      END;
    END DisconnectLists;


  PROCEDURE DisposeList(VAR TheList : GenList);
    VAR
      TmpBlockDescr : BlockDescriptor;
      TypeCode : CARDINAL;
    BEGIN
      IF NOT Initialized(TheList) THEN
        (*diag*)
(*
        InitResponse('DisposeList');
  If you want to guarantee that your code is free of needless
  calls to DisposeList, you may want to reinsert this.
  Reinsertion may also help you avoid subtle design problems.
  For people just learning to use REPERTOIRE, though, this causes
  needless irritations, so we commented it out.
*)
        RETURN;
      END;
      IF TheList^.ParentList # NIL THEN
        ErrorManager.WARN("Disposal of sublist before parent");
      END;
      ListDelete(TheList, 1, TheList^.lngth);
      WITH TheList^ DO
        InitCheck := 0;
          (*This zeroes the InitCheck in what will become phantom
            memory.  It's not strictly necessary, but it helps
            detect cases where two GenLists point at the same
            thing.*)
        IF BlockList#NIL THEN
          WHILE ListLength(BlockList)>0 DO
            GetElmt(BlockList, 1, TmpBlockDescr, TypeCode);
            WITH TmpBlockDescr DO
              VStorage.DosDealloc(ElmtRecsAddr, ElmtRecsSize);
              VStorage.DeallocMem( VStorage.MemHandle(DataAddr), DataSize );
            END;
            ListDelete(BlockList, 1, 1);
          END;
          VStorage.DosDealloc(BlockList, SYSTEM.TSIZE(GenListRec));
        END;
      END;
      VStorage.DosDealloc(TheList, SYSTEM.TSIZE(GenListRec));
      TheList := NIL;
      ErrorFlag := NoListError;
    END DisposeList;


  PROCEDURE ElmtNow(TheList : GenList) : CARDINAL;
    BEGIN
      IF NOT Initialized(TheList) THEN
      (*diag*)
        RETURN 0;
      END;
      RETURN TheList^.current;
    END ElmtNow;


  PROCEDURE GetElmt(TheList : GenList; spot : CARDINAL; VAR TheElmt :
    ARRAY OF SYSTEM.BYTE; VAR TypeCode : CARDINAL);
    VAR
      DestSize : CARDINAL;
    BEGIN
      IF NOT Initialized(TheList) THEN
        (*diag*)
        InitResponse('Get');
        RETURN;
      END;
      MoveToSpot( TheList, spot );
      TypeCode := TheList^.now^.type;
      DestSize := HIGH(TheElmt)+1;
      WITH TheList^.now^ DO
        IF size<=DestSize THEN
          (*We test for this first because we're not going to
            allow overflows.*)
          VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), size);
          IF size<DestSize THEN
            ErrorFlag := underflow;
            IF TypeCode=StrCode THEN
              LowLevel.PokeByte(0C,
                  LowLevel.seg(SYSTEM.ADR(TheElmt)),
                  LowLevel.ofs(SYSTEM.ADR(TheElmt))+size);
                (*We do this to make sure we have a null
                  terminator at the end of our string.*)
(*
            ELSE
                WARN('Underflow in GetElmt.');
                You may want to reinsert this message
                if you encounter problems with confused
                data types in your lists, but it is
                cumbersome in most situations.
*)
            END;
            RETURN;
          END;
        ELSE
          VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), DestSize);
          IF (TypeCode = StrCode) AND (size> (DestSize + 1)) THEN
            IF INTEGER(DestSize) > LowLevel.ScanEQ( DestSize, 0C,
                SYSTEM.ADR(TheElmt) ) THEN
              (* We found a null somewhere in TheElmt; no need to worry. *)
              ErrorFlag := NoListError;
              RETURN;
            END;
          END;
          IF (TypeCode#StrCode) OR (size> (DestSize + 1)) THEN
            (*If it's a string, we're not going to signal an
              overflow if size exceeds DestSize by only one,
              because the difference is just the null terminator
              that we probably appended in the ListInsert.*)
            ErrorFlag := overflow;
            ErrorManager.WARN('GetElmt Overflow');
            RETURN;
          END;
        END;
      END;
      ErrorFlag := NoListError;
    END GetElmt;


  PROCEDURE GetElmtAdr(TheList : GenList; spot : CARDINAL; VAR
      ReadAddr : SYSTEM.ADDRESS; VAR TheSize : CARDINAL; VAR TypeCode :
      CARDINAL);
    BEGIN
      IF NOT Initialized(TheList) THEN
      (*diag*)
        InitResponse('Get');
        RETURN;
      END;
      MoveToSpot( TheList, spot );
      WITH TheList^.now^ DO
        ReadAddr := VStorage.LockMem(handle);
        VStorage.UnLockMem(handle);
      (* since we unlock here, the returned address is not
         guaranteed to be good after the calling program does
         anything that affects VStorage memory allocation *)
        TypeCode := type;
        TheSize := size;
      END;
      ErrorFlag := NoListError;
    END GetElmtAdr;


  PROCEDURE GetParentList(TheList : GenList; VAR Parent : GenList);
    BEGIN
      IF TheList^.ParentList=NIL THEN
        ErrorFlag := NoSuchList;
        ErrorManager.WARN("No parent");
        RETURN;
      END;
      Parent := TheList^.ParentList;
      ErrorFlag := NoListError;
    END GetParentList;


  PROCEDURE Initialized(TheList : GenList) : BOOLEAN;
    BEGIN
      IF (NOT ModInitialized) THEN Init() END;
      IF TheList=NIL THEN
        ErrorFlag := NoInit;
        RETURN FALSE;
      ELSIF TheList^.InitCheck=InitKey THEN
        ErrorFlag := NoListError;
        RETURN TRUE;
      ELSE
        ErrorFlag := NoInit;
        RETURN FALSE;
      END;
    END Initialized;


  PROCEDURE JoinLists(VAR MergedList, SurvivingList : GenList; spot :
      CARDINAL);
    VAR
      TmpList1, TmpList2 : GenList;
      len1, len2 : LONGINT;
    BEGIN
      IF (NOT Initialized(MergedList)) OR (NOT Initialized(
          SurvivingList)) THEN
      (*diag*)
        InitResponse('Join');
      END;
      len1 := Numbers.Lc(ListLength(MergedList));
      len2 := Numbers.Lc(ListLength(SurvivingList));
      IF (len1+len2)> NumTypes.L65535 THEN
      (*diag*)
        ErrorManager.WARN("Join too long");
        RETURN;
      END;
      IF len1> NumTypes.L0 THEN
        IF len2=NumTypes.L0 THEN
          SurvivingList^ := MergedList^;
          SurvivingList^.lngth := 0;
          (*Because it's going to by INCed by MergedList^.lngth
            below.*)
          SurvivingList^.BlockList := NIL;
          (*Because MergedList^.BlockList is going to be joined
            to it below.*)
        ELSIF spot>SurvivingList^.lngth THEN
          SurvivingList^.last^.nxt := MergedList^.first;
          MergedList^.first^.prv := SurvivingList^.last;
          SurvivingList^.last := MergedList^.last;
        ELSIF spot<=1 THEN
          MergedList^.last^.nxt := SurvivingList^.first;
          SurvivingList^.first^.prv := MergedList^.last;
          SurvivingList^.first := MergedList^.first;
        ELSE
          IF ListMove(SurvivingList,spot) THEN
          END;
          WITH SurvivingList^ DO
            now^.prv^.nxt := MergedList^.first;
            MergedList^.first^.prv := now^.prv;
            MergedList^.last^.nxt := now;
            now^.prv := MergedList^.last;
          END;
        END;
        INC(SurvivingList^.lngth, MergedList^.lngth);
        SurvivingList^.now := SurvivingList^.first;
        SurvivingList^.current := 1;
      END;
      IF (MergedList^.BlockList#NIL)
          AND (ListLength(MergedList^.BlockList)>0) THEN
        IF SurvivingList^.BlockList=NIL THEN
          NewList(TmpList1);
          SurvivingList^.BlockList := TmpList1;
        ELSE
          TmpList1 := SurvivingList^.BlockList;
        END;
        TmpList2 := MergedList^.BlockList;
        JoinLists(TmpList2, TmpList1, 65535);
      (*recursive call*)
      END;
      VStorage.DosDealloc(MergedList, SYSTEM.TSIZE(GenListRec));
      MergedList := NIL;
    END JoinLists;


  PROCEDURE ListDelete(TheList : GenList; spot, HowMany : CARDINAL);
    VAR
      ElementsDeleted : CARDINAL;
      NewPrv, NewNxt : ElmtPtr;
      SubList : GenList;
    BEGIN
      IF NOT Initialized(TheList) THEN
        (*diag*)
        InitResponse('Delete');
        RETURN;
      END;
      IF HowMany=0 THEN
        ErrorFlag := NoListError;
        RETURN;
      ELSIF spot>TheList^.lngth THEN
        ErrorFlag := RefPastEnd;
        ErrorManager.WARN(RangeErStr);
        RETURN;
      END;
      MoveToSpot( TheList, spot );
      ElementsDeleted := 0;
      NewPrv := TheList^.now^.prv;
      LOOP
        WITH TheList^.now^ DO
          IF type=ListCode THEN
            VStorage.ReadMem(handle, 0, SYSTEM.ADR(SubList),
                SYSTEM.TSIZE(GenList));
              (*We can't use GetChildList for this operation
                because the list is corrupt between deletion of
                the first and last elements.*)
            IF Initialized(SubList) THEN
              SubList^.ParentList := NIL;
                (*DisposeList normally checks for a non-NIL
                  ParentList to detect disposals of sublists before
                  parents.  This disables the check.*)
              DisposeList(SubList);
            END;
          END;
            (* 8 Jul 88:  took following statement out of ELSIF clause
               so as to deallocate the 4-byte pointer to the GenListRec.  We
               were previously leaking memory 4 bytes per sublist. *)
          IF NOT FromBlock THEN
            (*We can't deallocate the data area if it was
              allocated as part of a big block.  Instead, we'll
              deallocate it in DisposeList.*)
            VStorage.DeallocMem(handle, size);
          END;
          INC(ElementsDeleted);
          NewNxt := nxt;
        END;
        IF (ElementsDeleted<HowMany) AND (NewNxt#NIL) THEN
          TheList^.now := NewNxt;
          IF (NewNxt^.prv#NIL) AND (NOT NewNxt^.prv^.FromBlock) THEN
            VStorage.DosDealloc(NewNxt^.prv, SYSTEM.TSIZE(GenElmt));
          END;
        ELSE
          WITH TheList^ DO
            DEC(lngth, ElementsDeleted);
            IF NOT now^.FromBlock THEN
              VStorage.DosDealloc(now, SYSTEM.TSIZE(GenElmt));
            END;
            IF NewPrv#NIL THEN
              (*Establish the forward link.*)
              NewPrv^.nxt := NewNxt;
            ELSE
              (*We've deleted the first element of TheList.*)
              first := NewNxt;
            END;
            IF NewNxt#NIL THEN
              (*Establish the backward link.*)
              NewNxt^.prv := NewPrv;
              now := NewNxt;
            ELSE
              (*We've deleted the last element of TheList.*)
              now := NewPrv;
              last := NewPrv;
              DEC(current);
              (*Note that current will go to zero here if we delete
                the only remaining element of TheList.  That should
                be correct, since it's initialized to zero.*)
            END;
            EXIT;
          END;
        END;
      END;
      ErrorFlag := NoListError;
    END ListDelete;


  PROCEDURE ListInsert(Element : ARRAY OF SYSTEM.BYTE; TypeCode : CARDINAL;
      TheList : GenList; spot : CARDINAL);
    BEGIN
      ListInsertAdr(SYSTEM.ADR(Element), HIGH(Element)+1, TypeCode, TheList,
          spot);
    END ListInsert;


  PROCEDURE ListInsertAdr(ReadAddr : SYSTEM.ADDRESS; TheSize : CARDINAL;
      TypeCode : CARDINAL; TheList : GenList; spot : CARDINAL);
  (* inserts a unit TheSize long starting at ReadAddr *)
    VAR
      tmp : ElmtPtr;
      TmpElmt : GenElmt;
      TmpAdr : SYSTEM.ADDRESS;
      Indirector : POINTER TO GenList;
      DiagSize : CARDINAL;

    BEGIN
      IF (TypeCode = ListCode) AND DiagMode THEN
        IF CircularLinkage( ReadAddr, TheSize, TheList, TRUE ) THEN
          ErrorManager.WARN( Circularity );
        END;
      END;
      ErrorFlag := NoListError;
      IF NOT Initialized(TheList) THEN
      (*diag*)
        InitResponse('Insert');
        RETURN;
      END;
      IF TypeCode=StrCode THEN
        TmpElmt.size := 1+ LowLevel.ScanEQ(TheSize,0C,ReadAddr);
      (*This makes sure the null terminator gets included with
        the string, if there is one.  If the string completely
        fills its array, there won't be a null terminator, so
        we have to put one in when we copy out of the list in
        GetElmt and NextElmt.*)
      ELSE
        TmpElmt.size := TheSize;
        (*Store the size of the data area to be allocated.*)
      END;
      IF NOT VStorage.AllocMem(TmpElmt.handle,TmpElmt.size) THEN
      (*Allocate the data area.*)
        ErrorFlag := InsuffMem;
        ErrorManager.WARN(NoMemErStr);
        RETURN;
      END;
      TmpAdr := VStorage.LockMem(TmpElmt.handle);
    (* locks the allocated area into memory (allows us to use
       expanded memory) *)
      LowLevel.Move(ReadAddr, TmpAdr, TmpElmt.size);
      (*Copy the element into the data area.*)
      IF TypeCode=StrCode THEN
        LowLevel.Fill( LowLevel.AddAddr(TmpAdr, TmpElmt.size-1), 1, 0C);
      (* if string, store null terminator *)
      END;
      VStorage.UnLockMem(TmpElmt.handle);
      WITH TheList^ DO
        IF (NOT ListMove(TheList,spot)) AND (ErrorFlag=RefToZero) THEN
        (*diag*)
          ErrorManager.WARN(RangeErStr);
          RETURN;
        END;
        DiagSize := SYSTEM.TSIZE(GenElmt);
        VStorage.DosAlloc(tmp, DiagSize);
        tmp^.type := TypeCode;
        IF TypeCode=ListCode THEN
          Indirector := ReadAddr;
          IF Initialized(Indirector^) THEN
            (* 23 Dec 88:  added this check for NIL to fix bug discovered
               by the people at LaserMaster Corp. *)
            Indirector^^.ParentList := TheList;
          END;
        END;
        IF now=NIL THEN
        (*This only happens when we have a null list.  Otherwise
          ListMove will have stopped before going past the last
          element in the list.*)
          tmp^.nxt := NIL;
          tmp^.prv := NIL;
          last := tmp;
          first := tmp;
          current := 1;
        ELSE
          IF (spot>lngth) THEN
            tmp^.prv := now;
            tmp^.nxt := NIL;
            now^.nxt := tmp;
            INC(current);
            last := tmp;
          ELSE
            tmp^.prv := now^.prv;
            now^.prv := tmp;
            tmp^.nxt := now;
            IF tmp^.prv#NIL THEN
            (*We know we're not on the first element of the list.*)
              tmp^.prv^.nxt := tmp;
            ELSE
            (*tmp is the new first element of the list.*)
              first := tmp;
            END;
           END;
        END;
        tmp^.elem := TmpElmt.elem;
        tmp^.size := TmpElmt.size;
        tmp^.FromBlock := FALSE;
        now := tmp;
        INC(lngth);
      END;
      IF ErrorFlag = RefPastEnd THEN
        ErrorFlag := NoListError;
      END;
    END ListInsertAdr;


  PROCEDURE ListLength(TheList : GenList) : CARDINAL;
    (*Number of elements at this node of the list.*)
    BEGIN
      IF NOT Initialized(TheList) THEN
        (*diag*)
        InitResponse('ListLength');
        RETURN 0;
      END;
      ErrorFlag := NoListError;
                                (*added 30 Oct 86*)
      RETURN TheList^.lngth;
    END ListLength;


  PROCEDURE ListReplace(Element : ARRAY OF SYSTEM.BYTE; TypeCode : CARDINAL;
      TheList : GenList; spot : CARDINAL);
    BEGIN
      ListReplaceAdr(SYSTEM.ADR(Element), HIGH(Element)+1, TypeCode, TheList,
          spot);
    END ListReplace;


  PROCEDURE ListReplaceAdr(ReadAddr : SYSTEM.ADDRESS; TheSize, TypeCode :
      CARDINAL; TheList : GenList; spot : CARDINAL);
    VAR
      StrLen, DestSize : CARDINAL;
      ChildList, CheckList : GenList;
      tmp : ElmtPtr;
      Indirector : POINTER TO GenList;
      TmpAdr : SYSTEM.ADDRESS;
    BEGIN
      ErrorFlag := NoListError;
      IF NOT Initialized(TheList) THEN
      (*diag*)
        InitResponse('Replace');
        RETURN;
      END;
      MoveToSpot( TheList, spot );
      WITH TheList^.now^ DO
        IF (type = ListCode) THEN
          (*Now we have to dispose of the old list UNLESS it's
            identical to what replaces it.*)
          GetChildList(TheList, spot, ChildList);
          IF (TypeCode # ListCode) OR (NOT AdrToList( ReadAddr,
              TheSize, CheckList )) THEN
            CheckList := NIL;
          END;
          IF (CheckList # ChildList) AND (ChildList # NIL) THEN
            ChildList^.ParentList := NIL;
              (*We do this to prevent DisposeList from warning us
                about premature disposal of children.*)
            IF (CheckList # NIL) AND DiagMode THEN
              IF CircularLinkage( ReadAddr, TheSize, TheList, TRUE ) THEN
                ErrorManager.WARN( Circularity );
              END;
              IF NOT ListMove(TheList,spot) THEN
                (*Have to make sure we're still in the same spot.*)
                RETURN;
              END;
            END;
              (*Check for circularity first so you won't find
                the disposed sublist.*)
            DisposeList(ChildList);
              (*DisposeList won't mind if ChildList is NIL.*)
          END;
        END;
        IF (TypeCode=StrCode) THEN
        (*We know here that we're dealing with strings, so an
          underflow won't matter.  If the new string is shorter
          than the size of the old element's data area, we can
          copy over it without ALLOCATING and DEALLOCATING.*)
          StrLen := 1 + LowLevel.ScanEQ(TheSize,0C,ReadAddr);
        (*This makes sure the null terminator gets included with
            the string.*)
          IF StrLen<=size THEN
            TmpAdr := VStorage.LockMem(handle);
            LowLevel.Move(ReadAddr, TmpAdr, StrLen);
            LowLevel.PokeByte(0C, LowLevel.seg(TmpAdr),
                LowLevel.ofs(TmpAdr)+StrLen-1);
            (*We do this to guarantee that constant strings
              passed to open arrays will be stored with null
              terminators.*)
            VStorage.UnLockMem(handle);
            IF StrLen<size THEN
            (*We do this to let the user determine whether a
              longer string has been replaced with a shorter one,
              although it's not clear why any user would want to
              know that.*)
              ErrorFlag := underflow;
            END;
            type := TypeCode;
            RETURN;
          ELSE
            TheSize := StrLen;
          END;
        END;
        DestSize := size;
      END;
    (* We have to end the WITH here because we may change the
      TheList^.now pointer in the next few lines.*)
      IF DestSize#TheSize THEN
        IF TheList^.now^.FromBlock THEN
          VStorage.DosAlloc(tmp, SYSTEM.TSIZE(GenElmt));
          tmp^ := TheList^.now^;
          TheList^.now := tmp;
          TheList^.now^.FromBlock := FALSE;
        (*We do this because we know at this point that FromBlock
          has to be FALSE--the new data won't fit in the old
          area--and since FromBlock tells ListDelete whether it
          can dispose of memory allocated both to the data area
          and the controlling record, we can't let them get out
          of sync.*)
        (* Next, correct nxt, prv, first, and last pointers
           if affected *)
          IF spot=1 THEN
            TheList^.first := tmp;
          ELSE
            TheList^.now^.prv^.nxt := tmp;
          END;
          IF spot>=TheList^.lngth THEN
            TheList^.last := tmp;
          ELSE
            TheList^.now^.nxt^.prv := tmp;
          END;
        ELSE
          VStorage.DeallocMem(TheList^.now^.handle, TheList^.now^.size);
        END;
        TheList^.now^.size := TheSize;
        IF NOT VStorage.AllocMem( TheList^.now^.handle,
            TheList^.now^.size ) THEN
          ErrorFlag := InsuffMem;
          ErrorManager.WARN(NoMemErStr);
          RETURN;
        END;
      END;
      WITH TheList^.now^ DO
        TmpAdr := VStorage.LockMem(handle);
        LowLevel.Move(ReadAddr, TmpAdr, TheSize);
        type := TypeCode;
        IF TypeCode=ListCode THEN
          Indirector := ReadAddr;
          IF Initialized(Indirector^) THEN
            (* 23 Dec 88:  added this check for NIL to fix bug discovered
               by the people at LaserMaster Corp. *)
            Indirector^^.ParentList := TheList;
          END;
        ELSIF TypeCode=StrCode THEN
          LowLevel.PokeByte(0C, LowLevel.seg(TmpAdr),
              LowLevel.ofs(TmpAdr) + TheSize - 1 );
        END;
        VStorage.UnLockMem(handle);
      END;
    END ListReplaceAdr;


  PROCEDURE ListSize(TheList : GenList; VAR TotalElements : LONGINT;
    VAR TotalSubLists : CARDINAL; VAR TotalListSize : LONGINT) : LONGINT;
    VAR
      SubList : GenList;
      SubListTotal : CARDINAL;
      SubElements, DataSize, SubSize : LONGINT;
      firstime : BOOLEAN;
    BEGIN
      TotalElements := NumTypes.L0;
      TotalSubLists := 0;
      DataSize := NumTypes.L0;
      TotalListSize := NumTypes.L0;
      IF NOT Initialized(TheList) THEN
      (*diag*)
        RETURN DataSize;
      END;
      IF NOT ListMove(TheList,1) THEN
        RETURN DataSize;
      END;
      firstime := TRUE;
      REPEAT
        IF firstime THEN
          firstime := FALSE;
        ELSE
          IF NOT ListMove(TheList,TheList^.current+1) THEN
          END;
        END;
        IF TheList^.now^.type=ListCode THEN
          GetChildList(TheList, TheList^.current, SubList);
          DataSize := DataSize+ListSize(SubList,SubElements,
              SubListTotal,SubSize);
          INC(TotalElements);
          (*We increment our TotalElements one for the sublist.*)
          TotalElements := TotalElements+SubElements;
          (*And again for the sublist's elements.*)
          INC(TotalSubLists);
          (*We increment it one for the sublist itself.*)
          INC(TotalSubLists, SubListTotal);
          (*And again for all the sublist's sublists.*)
          TotalListSize := TotalListSize+SubSize;
        ELSE
          INC(TotalElements);
          DataSize := DataSize + Numbers.Lc(TheList^.now^.size);
          TotalListSize := TotalListSize + Numbers.Lc( TheList^.now^.size );
          INC(TotalListSize, SYSTEM.TSIZE(GenListRec));
        END;
      UNTIL TheList^.current=TheList^.lngth;
      ErrorFlag := NoListError;
      RETURN DataSize;
    END ListSize;


  PROCEDURE ListToAdr(TheList : GenList; TheAddr : SYSTEM.ADDRESS; TheSize :
      CARDINAL) : BOOLEAN;
    BEGIN
      IF TheSize # SYSTEM.TSIZE(GenList) THEN
        RETURN FALSE;
      ELSE
        LowLevel.Move(SYSTEM.ADR(TheList), TheAddr, TheSize);
        RETURN TRUE;
      END;
    END ListToAdr;


  PROCEDURE ListToBlock(TheList : GenList; delimiter1, delimiter2 :
    ARRAY OF CHAR; VAR TheAddr : SYSTEM.ADDRESS; VAR BlockSize, RecSize :
      CARDINAL);
    (*Note that the calling program is responsible for
      deallocating the memory allocated by ListToBlock.*)
    VAR
      DelimSpace, BlockPtr, SubLists : CARDINAL;
      tmpl, elements, TotalData, TotalListSize : LONGINT;
      TwoDelimiters : BOOLEAN;

    PROCEDURE CopyOut(TheList : GenList);
    (*This procedure has to be split out from the rest of
      ListToBlock because it needs to call itself recursively
      when it encounters a SubList.  Note that it operates on the
      BlockPtr variable, which is global to the ListToBlock
      procedure. The purpose of that is to prevent the recursive
      calls from writing back over the start of the block.*)
      VAR
        SubList : GenList;
        NilList: BOOLEAN;
      BEGIN
        IF NOT Initialized( TheList ) THEN
          NewList( TheList );
          NilList := TRUE;
        ELSE
          NilList := FALSE;
        END;
        IF NOT ListMove(TheList,1) THEN
          ErrorFlag := RefPastEnd;
          RETURN;
        END;
        WHILE ErrorFlag#RefPastEnd DO
          WITH TheList^.now^ DO
            IF TwoDelimiters THEN
              LowLevel.Move(SYSTEM.ADR(delimiter1),
                  LowLevel.AddAddr(TheAddr, BlockPtr),
                  M2Strings.Length(delimiter1));
              INC(BlockPtr, M2Strings.Length(delimiter1));
                (*These next two statements make the kind of block
                  produced by ListToBlock match the structure of an
                  NdxFile.  You may want to delete them if you use
                  ListToBlock for other purposes.*)
              LowLevel.Move(SYSTEM.ADR(type),
                  LowLevel.AddAddr(TheAddr, BlockPtr), 2);
              INC(BlockPtr, 2);
            END;
            IF type=ListCode THEN
              GetChildList(TheList, TheList^.current, SubList);
              CopyOut(SubList);
            ELSE
              VStorage.ReadMem(handle, 0,
                  LowLevel.AddAddr(TheAddr, BlockPtr), size);
              INC(BlockPtr, size);
            END;
          END;
          LowLevel.Move(SYSTEM.ADR(delimiter2),
              LowLevel.AddAddr(TheAddr, BlockPtr),
              M2Strings.Length(delimiter2));
          INC(BlockPtr, M2Strings.Length(delimiter2));
          IF ListMove(TheList,TheList^.current+1) THEN
          END;
        END;
        IF NilList THEN
          DisposeList( TheList );
        END;
      END CopyOut;

    BEGIN
      IF (NOT ModInitialized) THEN Init() END;
    (*ListToBlock*)
      TotalData := ListSize(TheList,elements,SubLists,TotalListSize);
      IF (TotalData> NumTypes.L65535)  THEN
      (*We've got too much data in the list to store in a
        contiguous area of memory.*)
        ErrorFlag := InsuffMem;
        RETURN;
      END;
      TwoDelimiters := FALSE;
      IF (M2Strings.Length(delimiter1)>0) OR
          (M2Strings.Length(delimiter2)>0) THEN
        IF elements> NumTypes.L65535 THEN
          ErrorFlag := InsuffMem;
          RETURN;
        END;
        DelimSpace := Numbers.C(elements *
            Numbers.Lc(M2Strings.Length(delimiter1)));
        IF NOT PosUtils.Equal(delimiter1,delimiter2) THEN
        (*We're supposed to use a separate delimiter to mark the
          start and end of each element.*)
          DelimSpace := DelimSpace + Numbers.C(elements *
              Numbers.Lc(M2Strings.Length(delimiter2)+2));
          (*It's +2 to allow room for record types.  See the
            comment above.*)
          TwoDelimiters := TRUE;
        END;
      ELSE
        DelimSpace := 0;
      END;
      BlockSize := Numbers.C(TotalData)+DelimSpace;
     (* size of block created *)
      VStorage.DosAlloc(TheAddr, BlockSize);
      tmpl := elements-Numbers.Lc(SubLists);
      (*We use tmpl to avoid a bug in Logitech's v3.0 LongInts.*)
      IF (elements > Numbers.Lc(SubLists)) AND
          ((Numbers.Lc(BlockSize) MOD (tmpl))=NumTypes.L0) THEN
        RecSize := BlockSize DIV Numbers.C(tmpl);
      (* size of each record if they're fixed-length *)
      ELSE
        RecSize := 0;
      END;
      BlockPtr := 0;
      CopyOut(TheList);
      ErrorFlag := NoListError;
    END ListToBlock;


  PROCEDURE NextElmt(TheList : GenList; HowFar : INTEGER; VAR
      TheElmt : ARRAY OF SYSTEM.BYTE; VAR TypeCode : CARDINAL);
    VAR
      DestSize, cnt : CARDINAL;
    BEGIN
      IF NOT Initialized(TheList) THEN
      (*diag*)
        InitResponse('Next');
        RETURN;
      END;
      WITH TheList^ DO
        cnt := ABS(HowFar);
        IF (TheList^.now#NIL) AND (HowFar<0) THEN
          WHILE (cnt>0) AND (TheList^.now^.prv#NIL) DO
            TheList^.now := TheList^.now^.prv;
            DEC(cnt);
            DEC(TheList^.current);
          END;
        ELSE
          WHILE (cnt>0) AND (TheList^.now^.nxt#NIL) DO
            TheList^.now := TheList^.now^.nxt;
            DEC(cnt);
            INC(TheList^.current);
          END;
        END;
      END;
      TypeCode := TheList^.now^.type;
      DestSize := HIGH(TheElmt)+1;
      WITH TheList^.now^ DO
        IF size<=DestSize THEN
        (*We test for this first because we're not going to
          allow overflows.*)
          VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), size);
          IF size<DestSize THEN
            ErrorFlag := underflow;
            IF TypeCode=StrCode THEN
              LowLevel.PokeByte(0C,
                  LowLevel.seg(SYSTEM.ADR(TheElmt)),
                  LowLevel.ofs(SYSTEM.ADR(TheElmt))+size);
              (*We do this to make sure we have a null
                terminator at the end of our string.*)
              RETURN;
            ELSE
          (*
            WARN('Underflow in NextElmt');
              Commented out, 30 Oct 86
          *)
              RETURN;
            END;
          ELSE
            ErrorFlag := NoListError;
            RETURN;
          END;
        ELSE
          VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), DestSize);
          ErrorFlag := overflow;
          ErrorManager.WARN('Overflow in NextElmt');
          RETURN;
        END;
      END;
      ErrorFlag := NoListError;
    END NextElmt;


  PROCEDURE NilList(VAR TheList : GenList);
    BEGIN
      TheList := NIL;
    END NilList;


  PROCEDURE SameList( list1, list2: GenList ): BOOLEAN;
    VAR
      tmpadr: SYSTEM.ADDRESS;
      tmpsize: CARDINAL;
    BEGIN
      IF (NOT ModInitialized) THEN Init() END;
      IF (list1 = list2) THEN
        RETURN TRUE;
      END;
      tmpsize := 4;
      IF NOT ListToAdr( list1, SYSTEM.ADR(tmpadr), tmpsize ) THEN
        RETURN FALSE;
      END;
      RETURN CircularLinkage( SYSTEM.ADR(tmpadr), tmpsize, list2, TRUE );
    END SameList;


  PROCEDURE ScanList(TheStr : ARRAY OF CHAR; TheList : GenList;
      StartingAt, EndingAt : CARDINAL; VAR FoundSpot : CARDINAL) :
      CARDINAL;
    VAR
      spot : CARDINAL;
      TmpAdr : SYSTEM.ADDRESS;
    BEGIN
    (*ScanList*)
      IF NOT Initialized(TheList) THEN
      (*diag*)
        RETURN 0;
      END;
      IF NOT ListMove(TheList,StartingAt) THEN
        RETURN 0;
      END;
      IF TheList^.now=NIL THEN
        ErrorFlag := NoListError;
        RETURN (0);
      END;
      WITH TheList^ DO
        IF (EndingAt>StartingAt) THEN
          WHILE (StartingAt<=EndingAt) AND (now#NIL) DO
            TmpAdr := VStorage.LockMem(now^.handle);
            spot := PosUtils.PosAdr(TheStr,TmpAdr,now^.size);
          (* We could use a ScanMem function here if it existed*)
            VStorage.UnLockMem(now^.handle);
            IF (spot<now^.size) THEN
              FoundSpot := spot;
              ErrorFlag := NoListError;
              RETURN (current);
            END;
            INC(StartingAt);
            INC(current);
            now := now^.nxt;
          END;
          IF now=NIL THEN
            now := last;
          END;
        ELSE
          WHILE (StartingAt>=EndingAt) AND (now#NIL) DO
            TmpAdr := VStorage.LockMem(now^.handle);
            spot := PosUtils.PosAdr(TheStr,TmpAdr,now^.size);
            VStorage.UnLockMem(now^.handle);
            IF (spot<now^.size) THEN
              FoundSpot := spot;
              RETURN (current);
            END;
            DEC(StartingAt);
            DEC(TheList^.current);
            TheList^.now := TheList^.now^.prv;
          END;
          IF now=NIL THEN
            now := first;
          END;
        END;
      END;
      RETURN (0);
     (*TheStr not found between StartingAt and EndingAt.*)
    END ScanList;


  PROCEDURE Swap2Elmts(elmt1, elmt2 : ElmtPtr);
    (* Former version swapped by exchanging list elements. It's
       easier to swap by exchanging the pointers to the data
       elements. (Makes the sort algorithm easier, too.) This
       routine is a good place to start optimizing, or even put
       it inline.
    *)
    VAR
      AuxElmt : GenElmt;
      AuxPtr1, AuxPtr2 : ElmtPtr;
    BEGIN
      IF elmt1=elmt2 THEN
        RETURN;
      END;
      (* first swap everything, both ptrs and data *)
      AuxElmt := elmt1^;
      elmt1^ := elmt2^;
      elmt2^ := AuxElmt;
      (* then put ptrs back in their original place *)
      WITH elmt1^ DO
        AuxPtr1 := prv;
        prv := elmt2^.prv;
        AuxPtr2 := nxt;
        nxt := elmt2^.nxt;
      END;
      WITH elmt2^ DO
        prv := AuxPtr1;
        nxt := AuxPtr2;
      END;
    END Swap2Elmts;


  PROCEDURE ShellSortList(TheList: GenList; CompResult: Comparator) ;
    (*
      Tri de liste suivant le tri SHELL plus rapide que le
      QuickSort dans le cas o— l'on a des listes presque tri‚es.
    *)
      VAR
        Data1Adr, Data2Adr : SYSTEM.ADDRESS;
        Ptr1, Ptr2 : ElmtPtr;
        Elem1, Elem2 : CARDINAL;
        NbElements, saut, borneSup : CARDINAL;

    BEGIN
      NbElements := ListLength(TheList);
      saut := NbElements;
      LOOP
        saut := saut DIV 2;
        IF saut # 0 THEN
          borneSup := NbElements - saut;
          Elem1  := 1;
          Ptr1 := TheList^.first;
          Elem2 := saut + 1;
          IF ListMove(TheList, Elem2) THEN END;
          Ptr2 := TheList^.now;
          WHILE Elem1 <= borneSup DO
            Data1Adr := VStorage.LockMem( Ptr1^.handle );
            VStorage.UnLockMem( Ptr1^.handle );
            Data2Adr := VStorage.LockMem( Ptr2^.handle );
            VStorage.UnLockMem( Ptr2^.handle );
            IF CompResult(Data1Adr, Ptr1^.size, Data2Adr,
                Ptr2^.size) > 0 THEN
              Swap2Elmts(Ptr1, Ptr2);
              IF Elem1 > saut THEN
                Ptr2  := Ptr1;
                Elem2 := Elem1;
                DEC(Elem1, saut);
                IF ListMove(TheList, Elem1) THEN END;
                Ptr1 := TheList^.now;
              ELSE
                INC(Elem1);
                Ptr1 := Ptr1^.nxt;
                INC(Elem2);
                Ptr2 := Ptr2^.nxt;
              END;
            ELSE
              INC(Elem1);
              Ptr1 := Ptr1^.nxt;
              INC(Elem2);
              Ptr2 := Ptr2^.nxt;
            END (* if *);
          END (* while *);
        ELSE
          EXIT;
        END (* if *);
      END (* loop *);
    END ShellSortList;


  PROCEDURE SortList(TheList : GenList; CompResult : Comparator);
   (*28 July 87:  replaced old SortList, which used a bubble
     sort, with Torbjorn Sund's version, which uses a quicksort.
     Performance: With a list size of N, bubble sort runs as
     b*N*N, QuickSort as q*N*log2(N). On a Kaypro AT at 8 MHz,
     b = 0.5 msec, q = 3.5 msec.
   *)

    PROCEDURE QSortList(lwr, upr : ElmtPtr);
      VAR
        Pivot, Curnt : SYSTEM.ADDRESS;
        PivotSize, CurntSize : CARDINAL;
        i, m : ElmtPtr;
        LwrCount, UprCount : CARDINAL;
      BEGIN
        LOOP
          (* there goes the tail recursion *)
          IF lwr=upr THEN
            EXIT;
          END;
          WITH lwr^ DO
            (* could be any, preferrably a random element *)
            Pivot := VStorage.LockMem(handle);
              (* 6 Jan 88:  inserted this lock to correct
                 oversight pointed out by Dr. Michael Anderson;
                 SortList wasn't working when EMS was installed. *)
            VStorage.UnLockMem(handle);
              (* We go ahead and unlock here because we know we
                 will be finished with this address before
                 something else gets swapped into its place. *)
            PivotSize := size;
          END;
          m := lwr;
          i := lwr;
          LwrCount := 0;
          UprCount := 0;
          WHILE i#upr DO
            i := i^.nxt;
              (* no need to worry about NIL here *)
            WITH i^ DO
              Curnt := VStorage.LockMem(handle);
                (* 6 Jan 88:  Lock/UnLock inserted.  See above. *)
              VStorage.UnLockMem(handle);
              CurntSize := size;
            END;
            IF CompResult(Pivot,PivotSize,Curnt,CurntSize)>0 THEN
              INC(LwrCount);
              m := m^.nxt;
              Swap2Elmts(m, i);
            ELSE
              INC(UprCount);
            END;
          END;
          Swap2Elmts(lwr, m);
            (* sort shortest interval first; this minimizes recursion depth *)
          IF LwrCount<UprCount THEN
            (* the IF is strictly necessary only with "fat" partitioning *)
            IF LwrCount>0 THEN
              QSortList(lwr, m^.prv);
            END;
            (* Instead of QSortList( m^.nxt, upr); *)
            lwr := m^.nxt;
          ELSE
            IF UprCount>0 THEN
              QSortList(m^.nxt, upr);
            END;
            (* instead of QSortList( lwr, m^.prv); *)
            upr := m^.prv;
          END;
        END;
      END QSortList;

    BEGIN
      WITH TheList^ DO
        QSortList(first, last);
      END;
    END SortList;


  PROCEDURE SplitList(InList : GenList; where : CARDINAL; VAR
      OutList : GenList);
    VAR
      InLength : CARDINAL;
    BEGIN
      IF NOT Initialized(InList) THEN
      (*diag*)
        InitResponse('Split');
      END;
      NewList(OutList);
      InLength := ListLength(InList);
      IF (where>InLength) OR (InLength=0) OR (where=0) THEN
        RETURN;
      END;
      IF ListMove(InList,where) THEN
      END;
      WITH InList^ DO
        OutList^.first := now;
        OutList^.current := 1;
        OutList^.now := now;
        OutList^.last := last;
        OutList^.lngth := (lngth-where)+1;
        OutList^.ParentList := ParentList;
        now := now^.prv;
        last := now;
        lngth := where-1;
        current := where-1;(* added -1 per ukah 9/15/91 *)
        IF lngth=0 THEN
          first := NIL;
        ELSE  (* added else clause per ukah 9/15/91 *)
	  last^.nxt :=NIL;
        END;
	OutList^.first^.prv:=NIL; (* ukah *)
      END;
    (*Note that we're leaving InList in charge of the
      BlockList.  OutList may have a lot of FromBlock elements
      but nothing in its BlockList.*)
    END SplitList;


BEGIN
  ModInitialized := FALSE;
END GenLists.