Stars of Shareware: Programmierung/SOURCE.mdf/programm/msdos/pascal/pxl214a/pxllist.pas

Pascal/Delphi Source File | 1993-02-14 | 52.5 KB | 1,367 lines

{$R-}    {Range checking off}                                         {.CP14}
{$B-}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}

Unit PXLLIST;

Interface

Uses
  Crt,
  Dos,
  PXLINIT;

procedure ListIt;

{===========================================================================}

Implementation

procedure ListIt;                                                     {.CP15}
const
   TableSize               = 2521;
   Digits                  = 5;
   TabChr                  = #0;
   DummyHdrSeg             = #255;
   AtStart:    set of char = ['A'..'Z'];
   MiddleSet:  set of char = ['A'..'Z','0'..'9','_'];
   HexNumbers: set of char = ['A'..'F','0'..'9'];
   NumZ9:      set of char = ['0'..'9'];
   Num19:      set of char = ['1'..'9'];
   PlusMinus:  set of char = ['+','-'];
   TabSize: byte = 8;
   MaxHeader = 5;
type                                                                  {.CP20}
   Ref          =   ^Item;
   WPt          =   ^WordType;
   TableNum     =   0..TableSize;
   WordType     =   record
                       Key:    Str20;
                       Name:   Str20;
                       First:  Ref;
                    end;
   Item         =   record
                       LinNum: 0..MaxInt;
                       Next:   Ref;
                    end;
   Incs        =    (CantFind,TooDeep,Started,Ended,OK);
   HdSegType   =    (Left,Center,Right);
   HdPgType    =    (First,Other);
   HdLineType  =    array[Left..Right] of string;
   HdType      =    array[1..MaxHeader] of HdLineType;
   HeaderType  =    array[First..Other] of HdType;
   BLine       =    string[1];
   ProcPtr     =  ^ProcWord;
   ProcWord    =  record
                     Name:   Str20;
                     Key:    Str20;
                     LinNum: 0..MaxInt;
                     Next:   ProcPtr;
                  end;
var                                                                   {.CP26}
   FirstProc:     ProcPtr;
   Header:         HeaderType;
   NumOfWords:     TableNum;
   T:              array[TableNum] of WPt;
   Tp:             WPt;
   InRec,
   MaxLess,
   Max,Longest,
   ScanCount,K,
   Occur, PCount,
   Pager,Depth:    integer;
   HeaderMark:     Str3;
   Cut,Uncut:      Str2;
   Cuts,Uncuts:    array[1..3] of Str2;
   OpLen,ClLen,
   B:              byte;
   RecDepth,
   CaseDepth:      array[1..20] of integer {byte} ;
   IncLine,
   UndLn,
   LineEnd,UC:     string;
   IncMark:        string[8];
   CountingProc,
   NextIsProc,
   AltHeaders,
   LongOne,NoLine: boolean;
   IncState:       Incs;

   procedure BlankHeaderLines(Content: BLine);                        {.CP10}
   var
      LNo:    integer;
      HS:     HdSegType;
   begin
      for LNo := 1 to MaxHeader do
         for HS := Left to Right do
            Header[First][LNo,HS] := Content;
      Header[Other] := Header[First]
   end; {BlankHeaderLines}

   function IsBlank(HL: HdLineType): boolean;                          {.CP8}
   var
      Sg: HdSegType;
   begin
      IsBlank := True;
      for Sg := Left to Right do
         if (HL[Sg]<>'') and (HL[Sg]<>DummyHdrSeg) then IsBlank := False;
   end; {IsBlank}

   function HeaderLineNo(var H: HdType):integer;                       {.CP8}
   var
      Nr: integer;
   begin
      Nr := MaxHeader;
      while (Nr>0) and IsBlank(H[Nr]) do dec(Nr);
      HeaderLineNo := Nr
   end; {HeaderLineNo}

   procedure GetHeaderInstruction(Line: string);                      {.CP25}
   var
      IStrg: string;
      Cue:   Str3;
      Col:   integer;

   (* What this is supposed to do:
         "{" + ".H" triggers header function.  Possibilities are
         .HN  = no header at all
         .HnL = Left side of Header line #n
         .HnC = Center of Header line #n
         .HnR = Right side of Header line #n
         .HnN = No Header line #n
         .HA  = reverse Alternate page headers (for b-to-b printing)
         .HTn = Tab size (default is 8)
         .HPLnn = nn lines per page incl header (default: 66 - BottomMargin)
      Text for header line segment begins 1 col AFTER end of symbol
      Within header line text:
         .Fn = file name
         .Fd = file date (style: July 4,1776)
         .Ft = file time (style: 2:00 pm)
         .Pd = present (or printout) date (style: 7/4/76)
         .Pd = present (or printout) time (style: 14:00 )
         .Id = ID (from PXL.ID)
          #  = page number   *)

      procedure ResetMaxLin(S: string);                             {.CP24}
      {This is activated by an .HPLnn command in the text or in PXL.HDR.}
      {Be careful.  It sets the number of lines printed, not the length }
      {of the paper.  It will override the BottomMargin set in PXL.PAS. }
      {If your printer is set up to put fewer than the number set here, }
      {you get a mess.  Ordinarily, strange paper sizes can be set with }
      {PXLINST.  Of course, you have to give up FF's do to that.        }
      var
         NumStr: Str20;
         K,E:    integer;
      begin
         if S[1]='L' then begin
            K := 2;
            NumStr := '';
            while (S[K] in NumZ9) and (K<=length(S)) do begin
               NumStr := NumStr + S[K];
               inc(K)
            end; {while 0..9}
            if length(NumStr)>0 then val(NumStr,K,E);
            if (K>0) and (E=0) then MaxLin := K        {if error, do nothing}
         end {if L}
      end; {ResetMaxLin}

      procedure SetTabSize(S: string);                              {.CP14}
      var
         K,C: integer;
         NumeralStr: string;
      begin
         NumeralStr := '';
         B := 1;
         while (S[B] in NumZ9) and (B<=length(S)) do begin
            NumeralStr := NumeralStr + S[B];
            inc(B);
         end; {while NumZ9}
         val(NumeralStr,K,C);
         if C=0 then TabSize := K     {Leave at default unless ABSOLUTELY Ok}
      end; {SetTabSize}

      function FixedUpHeaderLine(L: string): string;                {.CP10}
      begin
         while pos('.Fn',L)>0 do Replace('.Fn',FileName,L);
         while pos('.Fd',L)>0 do Replace('.Fd',FileDate,L);
         while pos('.Pd',L)>0 do Replace('.Pd',PrintDate,L);
         while pos('.Ft',L)>0 do Replace('.Ft',FileTime,L);
         while pos('.Pt',L)>0 do Replace('.Pt',PrintTime,L);
         while pos('.Id',L)>0 do Replace('.Id',UserID,L);
         If L='' then L := DummyHdrSeg;
         FixedUpHeaderLine := L
      end; {FixedUpHeaderLine}

      procedure InterpretInstruction(Strg: string);                 {.CP17}
      const
         Symbols:  set of char = ['C','L','N','R'];
      var
         HNo:  byte;
         HSg:  HdSegType;
         C:    char;
         Pg:   HdPgType;

      begin {InterpretInstruction}
        C := Strg[1];
        delete(Strg,1,1);
        if C='N' then
           BlankHeaderLines(DummyHdrSeg)
        else if C='P' then
           ResetMaxLin(Strg)
        else if C = 'T' then
           SetTabSize(Strg)
        else if C = 'A' then
           AltHeaders := True {Can be turned on but not off}
        else if C in Num19 then begin                            {.CP28}
           HNo := ord(C) - $30;
           if HNo<1 then HNo := 1;
           if HNo>MaxHeader then HNo := MaxHeader;
           C := Strg[1];
           delete(Strg,1,2);        {eat both this char and delimiting space}
           if C in Symbols then begin
              if C='N' then begin
                 if (Page<2) and IsBlank(Header[Other][HNo])
                    then Pg := First
                    else Pg := Other;
                 for HSg := Left to Right do
                    Header[Pg][HNo,HSg] := DummyHdrSeg
              end {if N}
              else begin
                 case C of
                    'L':  HSg := Left;
                    'C':  HSg := Center;
                    'R':  HSg := Right;
                 end; {case}
                 Strg := FixedUpHeaderLine(Strg);
                 if (Page>1) or (Header[First][HNo,HSg]<>'')
                      then Pg := Other
                    else Pg := First;
                 for Pg := Pg to Other do Header[Pg][HNo,HSg] := Strg;
              end {else not N}
           end {if Symbol}
        end {else if 1..9}
      end; {InterpretInstruction}

   begin {GetHeaderInstruction}                                     {.CP13}
      Cue := HeaderMark;
      while pos(Cue,Line)>0 do begin
         Col := pos(Cue,Line) + 3;
         IStrg := '';
         while (Line[Col]<>'}') and (Col<=length(Line)) do begin
            IStrg := IStrg + Line[Col];
            inc(Col)
         end; {while}
         Line := Copy(Line,succ(Col),255);
         InterpretInstruction(IStrg)
      end {while}
   end; {GetHeaderInstruction}

   function HeaderLine(H: HdLineType): string;                        {.CP21}
   var
      Spaces,
      Wid,K:    integer;
      Temp:     string;
      Pg:       HdPgType;
      Sg:       HdSegType;   C: char;
   begin
      Temp := '';
      Wid := pred(Inst.Bt[LW]);
      if Page<2
         then Pg := First
         else Pg := Other;
      if AltHeaders and not Odd(Page) then begin
         Temp := H[Left];
         H[Left] := H[Right];
         H[Right] := Temp;
      end; {if Alternate}
      for Sg := Left to Right do begin
         while pos('#',H[Sg])>0  do      {Must update page number every page}
            Replace('#',StrgI(Page,1),H[Sg]);
         if H[Sg]=DummyHdrSeg then H[Sg] := '';
      end; {for Sg}
      repeat               {Splice left & right segs --chopping if necessary}
         Spaces := length(H[Left]) + length(H[Right]);
         if Spaces>Wid then begin
             if length(H[Right])>0 then delete(H[Right],1,1)
             else if length(H[Left])>0 then dec(H[Left,0])
         end {if Spaces}
      until Spaces<=Wid;
      Temp := H[Left];           {Overprint line with Center segment} {.CP10}
      for K := 1 to (Wid - Spaces) do Temp := Temp + #32;
      Temp := Temp + H[Right];
      if H[Center]<>'' then begin
         Spaces :=  (Wid - length(H[Center])) div 2;
         for K := 1 to length(H[Center]) do
            Temp[K+Spaces] := H[Center,K]
      end; {if Center}
      HeaderLine := Temp;
   end; {HeaderLine}

   procedure MakeFirstHeader(var Fil: text);                          {.CP25}
   var
      Lin:    string;

      function GotDefaultHeaderFromFile: boolean;
      const
         FName: string = 'PXL.HDR';
      var
         F:      text;

         function ZeroSize: boolean;
         var
            Fb:     file of byte;
         begin
            assign(Fb,FName);
            reset(Fb);
            ZeroSize := FileSize(Fb)=0;
            close(Fb)
         end; {ZeroSize}

      begin {GotDefaultHeaderFromFile}
         if FindFile(FName) then begin
            GotDefaultHeaderFromFile := True;    {Even if nothing in PXL.PRN}
            if not ZeroSize then begin     {Can't use FileSize on text files}
               assign(F,FName);
               reset(F);
               while not Eof(F) do begin
                  readln(F,Lin);
                  if pos(HeaderMark,Lin)<>0 then begin
                     GetHeaderInstruction(Lin)
                  end {if Cue}
               end; {while not Eof}
               close(F)
            end {if >0}
         end {if FindFile}
         else
            GotDefaultHeaderFromFile := False
      end; {GotDefaultHeaderFromFile}

      procedure MakeStandardDefaultHeader;                            {.CP14}
      begin
         Header[First][1,Right] := FileTime + ', ' + FileDate;
         if XRefOnly
            then Header[First][1,Left] :='Cross-Reference of: '
            else Header[First][1,Left] := 'File: ';
         Header[First][1,Left] := Header[First][1,Left] + FileName;
         if length(UserID)>0 then
            Header[First][1,Left] := Header[First][1,Left]
                                     + '  [' + UserID + ']';
         Header[Other][1] := Header[First][1];
         Header[Other][1,Right] := 'Page #'
      end; {MakeStandardDefaultHeader}

      procedure LoadFirstHeader(var F: text);                         {.CP16}
      var
         L:      string;
         B,Col:  byte;
      begin
         reset(Fil);
         repeat
            readln(Fil,L);
            B := pos(HeaderMark,L);
            if B>0 then begin
               GetHeaderInstruction(L);
               delete(L,1,B);
               while (L[1]<>'}') and (L<>'')  do delete(L,1,1)
            end {if >0}
         until B=0;
      end; {LoadFirstHeader}

   begin {MakeFirstHeader}                                             {.CP9}
      BlankHeaderLines('');
      if not GotDefaultHeaderFromFile then MakeStandardDefaultHeader;
      reset(Fil);                                        {Fille arrives open}
      readln(Fil,Lin);
      if pos(HeaderMark,Lin)<>0 then LoadFirstHeader(F);  {Check top of file}
      reset(Fil);                                {Return file open but reset}
      PageLineNumber := HeaderLineNo(Header[First]) + 2;
   end; {MakeFirstHeader}

   procedure PrintHeader(var PLine: integer); {Print header line(s)}  {.CP20}
   var
      K,Nr:   integer;
      Pg:     HdPgType;
   begin
      {$I-}
      writeln(Lst,'');
      {$I+}
      if not (IOresult=0) then
         CantCont('','Printer''s out');
      if GotPrnData then write(Lst,Istring[SetLg]);         {Set normal pica}
      if Page<2
         then Pg := First
         else Pg := Other;
      Nr := HeaderLineNo(Header[Pg]);
      for K := 1 to Nr do                                             {.CP13}
         writeln(Lst,HeaderLine(Header[Pg][K]));
      if GotPrnData then
         if NumberLines then write(Lst,Istring[SetSm]);             {or Elite}
      writeln(Lst);
      inc(Page);
      PLine := 2 + Nr;
   end; {PrintHeader}

   procedure PrintControl(var PageLineNumber: integer);               {.CP21}
   var
      Sym: string[8];
      I, J, Err: integer;
   begin
      if pos(concat('{.','PA}'),Line)<>0 then
         PageLineNumber := succ(MaxLin)
      else if pos(concat('{.','CP'),Line) <>0 then begin
         I := pos(concat('{.','CP'),Line) + 4;
         Sym := '';
         while Line[I] in NumZ9 do begin
            Sym := concat(Sym,Line[I]);
            I := succ(I);
         end {while};
         val(Sym,I,Err);
         if Err<>0 then I := 0;  {in case print control symbol is bungled}
         if PageLineNumber > (MaxLin-I) then PageLineNumber := succ(MaxLin);
      end {if}
   end; {PrintControl}

   procedure ReadingMatterI;                                          {.CP16}
   begin
      if XRefOnly then begin
         Blank(9,12);
         CenterCRT('Scanning ' +  FileName,10,Bright,0)
      end {if XrefOnly}
      else begin
         Blank(8,12);
         if not Xref then
            CenterCRT('Sending ' + FileName + ' to ' + OutputDevice,
                      10,Bright,0)
         else
            CenterCRT('Scanning ' + FileName + ' and sending to '
                      + OutputDevice + '.', 10,Bright,0)
      end {else not XRO}
   end; {ReadingMatterI}

   procedure ReadingMatterII;                                          {.CP5}
   begin
      Blank(8,8);
      CenterCRT('Sending cross-reference to ' + OutputDevice,
                10,Bright,Inside)
   end; {ReadingMatterII}

   procedure NewPage(Pager: integer);                                 {.CP18}
   var
      I:           integer;
   begin
      if Inst.Bt[FF]=12 then begin
         {$I-}
         write(Lst,#12);
         {$I-}
         if IOresult<>0 then CantCont('','Printer''s out.');
      end {if FF}
      else begin
         {$I-}
         writeln(Lst);
         {$I-}
         if IOresult<>0 then CantCont('','Printer''s out.');
         for I := succ(Pager) to Inst.Bt[FF] do writeln(Lst);
      end {no FF}
   end; {NewPage}

   procedure PrintTable;                                              {.CP17}
   var
      I:           TableNum;
      Lin:         integer;
      NumPerLine:  byte;

      procedure Compress(var N: TableNum);                            {.CP11}
      var
         I: TableNum;
      begin
         N := 0;
         for I := 0 to TableSize do
            if T[I] <> Nil then begin
               T[N] := T[I];
               inc(N)
            end; {if T[I]}
      end; {Compress}

      procedure Sort(Lo, Hi: integer); {Quicksort}                    {.CP31}
      var
         Low,High: TableNum;
         Mid,Temp: WPt;
      begin
         repeat                                 {Pick split points}
            Mid := T[(Lo+Hi) div 2];
            Low := Lo;
            High := Hi;
            repeat                                 {partitions}
               while T[Low]^.Key<Mid^.Key do Inc(Low);
               while T[High]^.Key>Mid^.Key do dec(High);
               if Low<=High then begin
                  Temp := T[Low];
                  T[Low] := T[High];
                  T[High] := Temp;
                  if Low<TableSize then inc(Low);
                  if High>0 then dec(High)
               end {if Low<=}
            until Low > High;
            {recursively sort shorter sub-segment}
            if (High-lo) < (Hi-Low) then begin
               if Lo < High then Sort(Lo,High);
               Lo := Low
            end {if (High}
            else begin
               if Low < Hi then Sort(Low,Hi);
               Hi := High;
            end {else}
         until Hi <= Lo
      end; {Sort}

      procedure PageOut;                                               {.CP7}
      begin
         NewPage(Lin);
         PrintHeader(Lin);
         writeln(Lst);
         inc(Lin)
      end; {PageOut}

      procedure PrintWord(W: WordType);                               {.CP20}
      var
         X,Y,Z:      Ref;
         Num:        integer;
         B:          byte;

      begin {PrintWord}                                               {.CP10}
         if Lin>MaxLin then PageOut;
         X := W.First; Y := X^.Next; X^.Next := Nil;
         while Y<>Nil do begin         {inky pinky pider, reversing pointers}
            Z := Y^.Next; Y^.Next := X; X := Y; Y := Z;
         end; {while Y<>Nil}
         Num := 0;
         Write(Lst,#32,W.Name);
         for B := 1 to Longest-length(W.Name) do write(Lst,#32);
         repeat                                  {write line numbers} {.CP21}
            if Num=NumPerLine then begin              {new line if necessary}
               Num := 0;
               writeln(Lst);
               inc(Lin);
               if Lin>MaxLin then begin
                  PageOut;
                  Write(Lst,#32,W.Name);
                  for B := 1 to Longest-length(W.Name) do
                     write(Lst,#32)
               end {if Lin}
               else
                  Write(Lst,#32:(succ(Longest)))
            end; {if Num}
            inc(Num);
            write(Lst,X^.LinNum:Digits);
            X := X^.Next
         until X=Nil;
         writeln(Lst);
         inc(Lin)
      end; {PrintWord}

      procedure PrintPL;  {Print list of procedures & functions}      {.CP15}
      var
         B:      byte;

         procedure PrintAProc;             {print one line in proc/func list}
         var
            B: byte;
         begin
            write(Lst,#32,FirstProc^.Name);
            for B := 1 to Longest-length(FirstProc^.Name) do write(Lst,#32);
            writeln(Lst,FirstProc^.LinNum:Digits);
            inc(I);
            GotoXY(30,16);
            Write(I:5);
            FirstProc := FirstProc^.Next;
         end; {PrintAProc}

      begin {PrintPL}                                                 {.CP19}
         if (Lin+PCount+5) > MaxLin then
            PageOut
         else begin
            writeln(Lst);
            inc(Lin)
         end; {else}
         writeln(Lst,'Procedures and Functions:');
         writeln(Lst);
         if FirstProc^.Next=nil then               {Just one proc/func in list}
            PrintAProc
         else
            while (FirstProc<>Nil) and not enough do begin
               inc(Lin);
               if Lin > MaxLin then PageOut;
               PrintAProc;
               Enough := Escape
            end {while}
      end; {PrintPL}

   begin {PrintTable}                                                 {.CP15}
      if NumberLines then
         if Mrk then Max := Max+10 {take account of space for beg/end count}
         else Max := Max + 6;
      NumPerLine := (Max-Longest) div Digits;
      Compress(NumOfWords);
      Sort(0,pred(NumOfWords));
      PrintHeader(Lin);
      writeln(Lst);
      writeln(Lst,'Crosslisting of Identifiers:');
      writeln(Lst);
      WriteCRT('X-Ref Lines:   ',16,15,Bright);
      Lin := Lin + 3;
      I := 0;
      while (I<NumOfWords) and not Enough do begin {print XRef lines} {.CP15}
         PrintWord(T[I]^);
         inc(I);
         GotoXY(30,16); write(I:5);                   {keep user entertained}
         Enough := Escape
      end; {while}
      if (FirstProc<>Nil) and not Enough then PrintPL;
      writeln(Lst);
      write(Lst,'Lines: ',LineNumber,'    Identifiers: ',ScanCount,
         '    Occurrences: ',Occur);
      if PCount>0 then
         writeln(Lst,'    Procedures: ',PCount)
      else
         writeln(Lst)
   end; {PrintTable}

   procedure ScanAndHash(var UC,Line: string; LinNo: integer);        {.CP18}
   var
      Ident:      WordType;
      Len,I:      byte;
      Col:        integer;

      procedure Calamity;
      begin
         ClrScr;
         PXLRectangle;
         CenterCRT('CALAMITY',11,Bright,0);
         WriteCRT('Too many @$#%'+#237+'@! identifiers',13,25,Bright);
         WriteCRT('    I can''t handle that.',14,25,Bright);
         CloseCarefully(F);
         RestoreScreen;
         Halt
      end; {Calamity}

      procedure Hash(Ident: WordType);                                 {.CP17}
      var
         Found:     boolean;
         ID:        record
                       case byte of
                          1: (Key: str20);
                          2: (O:   word);                   {integer);}
                          3: (Arr: array[0..20] of byte);
                    end;
         X:         Ref;
         H:         longint; {avoid trouble during re-hash}
         D,Start:   TableNum;
      begin
         ID.Key := Ident.Key;
         inc(Occur);
         H := ID.O mod TableSize;             {hash using 1st 2 bytes of key}
         Start := H;
         new(X);X^.LinNum := LinNo; Start := H; D := 1;
         repeat                                                       {.CP26}
            if T[H]^.Key = ID.Key then begin          {found the Key        }
               Found := True;
               X^.Next := T[H]^.First;                   {add line # to list}
               T[H]^.First := X;
            end {if found key}
            else if T[H] = Nil then begin             {empty place --new key}
               Found := True;
               inc(ScanCount);                            {count it         }
               if length(ID.Key)>Longest then             {update Longest   }
                   Longest := length(ID.Key);
               New(Tp);
               Tp^.Key := ID.Key;                         {set up new key   }
               Tp^.Name := Ident.Name;                    {and name         }
               Tp^.First := X;                            {and first line # }
               T[H] := Tp;                                {& put in hash tbl}
               X^.Next := Nil
            end {else if new}
            else begin                                {place occupied       }
               Found := False;
               H := H + ID.Arr[ID.Arr[0]];    {re-hash using last byte of key}
               if H>=TableSize then H := H - TableSize;
               if H=Start then Calamity
            end {else --place otherwise occupied}
         until Found
      end; {Hash}

   begin  {ScanAndHash}                                               {.CP16}
      GotoXY(30,14); write(LinNo:5);                  {keep user entertained}
      Col := 1;
      Len := length(UC);
      while Col<=Len do begin                                {creep along UC}
         if UC[Col]<>#32 then begin                  {looking for non-blanks}
            Ident.Key := ''; Ident.Name := '';
            I := Col + 20;                    {20 chars is max key length}
            while (UC[Col]<>#32) and (Col<=Len) do begin {read non-blanks}
               if Col<I then begin
                  Ident.Key := Ident.Key + UC[Col];
                  Ident.Name := Ident.Name + Line[Col]
               end; {if Col}
               inc(Col);
            end; {while}
            Hash(Ident)                          {put into the hash table}
         end {if not blank}
         else
            inc(Col);
      end {while}
   end; {ScanAndHash}

   procedure Underline (var Line: string);                             {.CP6}
   var
      K,J:         integer;
      B:           byte;
      InMiddle,
      InHex:    Boolean;

      procedure ProcProc(Name: string); {PROCess PROCedure}         {.CP15}
      var                                 {ie, add new proc name to list}
         Temp,PLptr:  ProcPtr;
         B:           byte;
      begin
         New(PLptr);
         PLptr^.Name := '';
         PLptr^.Key := '';
         if length(Name)>20 then Name[0] := #20;
         for B := 1 to length(Name) do begin
            PLptr^.Name := PLptr^.Name + Name[B];
            PLptr^.Key := PLptr^.Key + UpCase(Name[B]);
         end; {for B}
         PLptr^.LinNum := LineNumber;
         PLptr^.Next := Nil;
         if FirstProc = Nil then begin   {.CP19}           {if list is empty}
            FirstProc := PLptr;
         end {if first procedure}
         else if FirstProc^.Key <= PLptr^.Key then begin  {if >= 1st in list}
            Temp := FirstProc;
            while (Temp^.Next<>Nil) and (Temp^.Next^.Key<PLptr^.Key) do
               Temp := Temp^.Next;
            if Temp^.Next=Nil then          {if > end of list, append}
               Temp^.Next := PLptr
            else if (Temp^.Next^.Key<>PLptr^.Key) then begin
               PLptr^.Next := Temp^.Next;  {if between, insert}
               Temp^.Next := PLptr;
            end; {if not duplicate}        {Note: if =, do nothing}
         end {else if after first}
         else begin                                        {if < 1st in list}
            PLptr^.Next := FirstProc;
            FirstProc := PLptr;
         end {else put before the first}
      end; {ProcProc}

      procedure Ins (var Line,UC :string; Op,Cl:InsType);              {.CP5}
      var
         Z,Len,B:     byte;
         K,Col:       integer;
         Obj:         ResWType;

         function NextResWd: ResWType;                                {.CP17}
         {Returns next res word wd from line or '' if EOL found first.      }
         {                                                                  }
         {Archaeological note: This function belongs to the 1989 stratum.   }
         {It replaced a clumsy one dating from the earliest, 1984 ELIST era.}
         {ELIST kept the reserved words in a simple array, and went through }
         {it once per line, using TP's pos() function to search for all oc- }
         {currences of each reserved word.  In April, 1989, W. L. Peavy sent}
         {me a lovely bug about record-end troubles.  Fixing it required the}
         {identifiers to be peeled out & examined in order.  The slowness of}
         {that process forced me to rethink the search pattern.  The upshot }
         {is a new method (here and in PXLMENU, LoadReserv) which makes the }
         {overall process about 40% faster.                                 }
         var
            GotOne:     boolean;
            PossObj:    string;
            P:          ResWPtrType;
         begin                                                        {.CP18}
            GotOne := False;
            repeat
               repeat
                  inc(K)
               until (UC[K]<>#32) or (K>length(UC));
               if K<=length(UC) then begin
                  if NextIsProc then begin
                     NextIsProc := False;
                     PossObj := '';
                     while UC[K]<>#32 do begin    {get it;   Note; last char}
                        PossObj := PossObj + Line[K];      {on line is blank}
                        inc(K)
                     end; {while not blank}
                     ProcProc(PossObj);            {Put it in Proc/func list}
                  end {if NextIsProc}                      {in UC is a blank}
                  else if Rsv[UC[K]]=nil then {if no res wd has this initial}
                     while UC[K]<>#32 do inc(K)                     {pass it}
                  else if K<length(UC) then begin {if poss initial}   {.CP20}
                     Col := K;                 {mark beginning of identifier}
                     PossObj := '';
                     while UC[K]<>#32 do begin
                        PossObj := PossObj + UC[K];
                        inc(K);
                     end; {while not blank}         {if PossObj not too long}
                     if length(PossObj)<=MaxResLen then begin
                        P := Rsv[PossObj[1]];    {cmp res wds w this initial}
                        while (P^.R<>PossObj) and (P^.Next<>nil) do
                           P := P^.Next;
                        if P<>nil then GotOne := PossObj=P^.R;
                     end {if not too long for a res wd}
                  end {else starts with possible char}
               end {if not EoL}
            until GotOne or (K>=length(UC));
            if GotOne
               then NextResWd := PossObj
               else NextResWd := '';
         end; {NextResWd}

      begin {Ins}                                                     {.CP16}
         Col := 1;
         repeat
            K := Col;
            Obj := NextResWd;
            if Obj<>'' then begin                     {We have a Res Wd}
               Len := length(Obj);
               if MarkWCaps then
                  for B := Col to Col+pred(Len) do            {Capitalize It}
                     Line[B] := upcase(Line[B])
               else if not MarkWCR then begin
                  insert(Cl,Line,Col+Len);                 {Insert Closing  }
                  insert(Op,Line,Col);                     {Insert Opening  }
               end {if not CR}
               else begin                               {Make overprint line}
                  while length(UndLn)<pred(Col) do              {with blanks}
                     UndLn := UndLn + #32;
                  for B := Col to Col+pred(Len) do          {and underscores}
                     UndLn := UndLn + '_';
               end; {else MarkWCR}
               for B := Col to Col+pred(Len) do            {blank Obj in UC }
                  UC[B] := #32;
               if Xref then begin                                     {.CP22}

    {The procedure list will show the first occurance of the procedure and }
    {function names (presumaby their declarations) in the IMPLEMENTATION   }
    {section, not in the interface.  (ALL occurrances are shown in the reg-}
    {ular identifier list, of course.)  If you want it to show the inter-  }
    {face declarations instead, you can brace out the 5 lines marked below.}

              if      { <----- Leave the "if" }
    {====  beginning of brace-out section for interface declarations  ====}
                     Obj='UNIT' then
                     CountingProc := False
                  else if Obj='IMPLEMENTATION' then
                     CountingProc := True
                  else if CountingProc and                 {Mark Proc & Func}
   {=======  end of brace-out section for interface declarations   =========}

                  ((Obj='PROCEDURE') or (Obj='FUNCTION')) then begin
                     inc(PCount);
                     NextIsProc := True
                  end; {if Counting}
               end; {if XRef}

               for B := 1 to OpLen+ClLen do                            {.CP3}
                  insert(#32,UC,Col);                 {Blanks to match up UC}
               Col := Col + Len + OpLen + ClLen;         {move to end of Obj}

               if NumberLines then begin                              {.CP24}
                  if (Obj='BEGIN') or
                  (Obj='REPEAT') or (Obj='CASE') then {count begin/end}
                     inc(Depth)
                  else if (Obj='END')  then begin
                     if InRec=0 then begin
                        if Line[Col]<>'.' then dec(Depth)
                     end {if not InRec}
                     else begin
                        Depth := RecDepth[InRec];
                        dec(InRec)
                     end {else if InRec}
                  end {else if END}
                  else if (Obj='UNTIL') then
                     dec(Depth)
                  else if Obj='RECORD' then begin
                     inc(InRec);
                     RecDepth[InRec] := Depth;
                     inc(Depth)
                  end {else if RECORD}
               end; {if NumberLines}
            end {if Obj<>''}
         until Obj = '';
         if MarkWCR and (UndLn<>'') then
            while length(UndLn)<pred(length(Line)) do
              UndLn := UndLn + #32;
      end; {procedure Ins}

      procedure BlankBrackets(var UC: string);                        {.CP18}
      var
         I,J,PosCut,
         PosUnCut:       byte;
      begin
         if Cut <> '' then begin     {already in a bracket --check for close}
            PosUnCut := pos(UnCut,UC);
            if PosUnCut=0 then                  {no close}
               for I := 1 to length(UC) do      {blank all of UC}
                  UC[I] := #32
            else begin                          {has closer}
               if UnCut = '*)' then
                  inc(PosUnCut);
               for I := 1 to PosUnCut do        {blank UC to closer}
                  UC[I] := #32;
               Cut := ''; UnCut := ''
            end {else}
         end; {if Cut}
         while (pos(Cuts[1],UC)<>0) or                                {.CP29}
               (pos(Cuts[2],UC)<>0) or
               (pos(Cuts[3],UC)<>0) do begin   {UC contains openers}
            J := length(UC);
            for I := 1 to 3 do begin               {find first opener}
               PosCut := pos(Cuts[I],UC);
               if (PosCut>0) and
                  (PosCut<J) then begin
                     Cut := Cuts[I];
                     UnCut := UnCuts[I];
                     J := PosCut
               end {if}
            end; {for I}
            PosCut := J;
            PosUncut := pos(UnCut,copy(UC,succ(pos(Cut,UC)),255));
            if PosUnCut<>0 then begin  {If there's a closer, find its posit}
               PosUnCut := PosUnCut + PosCut;
               if UnCut = '*)' then
                  inc(PosUnCut);
               for I := PosCut to PosUnCut do         {blank UC in brackets}
                  UC[I] := #32;
               Cut := '';                             {reset Cut & UnCut}
               UnCut := ''
            end {there's a closer}
            else                                {if no closer}
               for I := PosCut to length(UC) do      {blank rest of UC}
                  UC[I] := #32;
         end {while openers in UC}
      end; {BlankBrackets}

      procedure ClearIdentifiers (var UC: string);                    {.CP10}
      var
         I:           byte;
      begin
         InMiddle := False; InHex := False;
         for I := 1 to length(UC) do
            if UC[I] = #32 then begin                               {a blank}
               InMiddle := False;
               InHex := False
            end {if blank}
            else if UC[I] = '$' then begin        {start of hex number}{.CP5}
               InHex := True;
               InMiddle := False;
               UC[I] := #32
            end {else $}
            else
               if InMiddle then begin                {in an identifier}{.CP6}
                  if not (UC[I] in MiddleSet) then begin
                     UC[I] := #32;
                     InMiddle := False
                  end {if not UC}
               end {if InMiddle}
               else if InHex then begin               {in a hex number}{.CP8}
                  if not (UC[I] in HexNumbers) then InHex := False;
                  if InHex or not (UC[I] in AtStart) then UC[I] := #32
               end {else Hex number}
               else if (UC[I] in AtStart) then
                  InMiddle := True                           {start an ident}
               else
                  UC[I] := #32
      end; {ClearIdentifiers}

   begin {Underline}                                                   {.CP7}
      UC := Line;                                    {Prepare guide template}
      UndLn := '';
      for B := 1 to length(UC) do UC[B] := UpCase(UC[B]);      {All capitals}
      BlankBrackets(UC);                   {Remove all comments & quotations}
      ClearIdentifiers(UC);             {Remove everything not an identifier}
      Ins(Line,UC,Opening,Closing);   {Insert printer chars around Key words}
   end; {Underline}

   procedure PrintLine;               {Print one line}                {.CP26}
   var
      B,
      RealLength:  byte;
      Opener:      string;
   begin
      RealLength := length(Line) - 2;       {Length w/o pad or print symbols}
      Opener := '';
      if Mrk or XRef then Underline(Line);
      if (NumberLines) then begin            {write line number or spaces}
         if NoLine or (RealLength=0) then begin    {if a continuation    }
            Opener := Opener + '     ';
            if Mrk then
               Opener := Opener + '       '            {spaces only      }
            else
               Opener := Opener + '  '
         end {if NoLine}
         else begin                                {if beginning new line}
            Opener := Opener + StrgI(LineNumber,5);      {write line numb}
            if Mrk then
               Opener := Opener + ' ' + StrgI(Depth,2) + '    '  {& depth}
            else
               Opener := Opener + '  ';                         {no depth}
            NoLine := False
         end {else --not NoLine}
      end; {if Numberlines}
      if XRef then                                                {.CP22}
         ScanAndHash(UC,Line,LineNumber)                 {Scan for X-ref}
      else begin
         GotoXY(46,16);                           {Keep user entertained}
         write(LineNumber:5)
      end; {else not XRef}
      Line := copy(Line,2,length(Line)-2);               {remove padding}
      if MarkWCR and (UndLn<>'') then begin
         delete(UndLn,1,1);
         while length(UndLn)<length(Line) do
            UndLn := #32 + Undln;
      end; {if UndLn}
      if (length(IncMark)>0) or (length(IncLine)>0) then begin
         for B := RealLength to pred(MaxLess) do
             Line := Line + #32;
         Line := Line + IncLine + IncMark;
         IncLine := '';
         IncState := OK;
      end; {if IncMark}
      if not XRefOnly then begin
         if MarkWCR and (UndLn<>'') then begin
            while UndLn[length(UndLn)]=#32 do
               dec(UndLn[0]);
            for B := 1 to length(Opener) do
               UndLn := #32 + UndLn;
            writeln(Lst,Opener,Line,^M,UndLn);        {Enfin! WRITE here}
         end {if UndLn}
         else
            writeln(Lst,Opener,Line);                 {or here}
      end; {if not XRefOnly}
      if LongOne then
         NoLine := True
      else begin
         NoLine := False;
         inc(LineNumber)
      end {else if not NoLine}
   end; {PrintLine}

   procedure TabSpace; {make room for tabs (every TabSize chars)}     {.CP15}
   var
      B,Col,Nchrs: byte;

      procedure StartLineEnd;
      begin
         LineEnd := '';
         LongOne := True
      end; {StartLineEnd}

   begin {TabSpace}
      if Line[1]=TabChr then begin    {turn ldg TabChr to Tab & strip others}
         Line[1] := #9;
         while Line[2]=TabChr do delete(Line,2,1)
      end; {if Line[1]}
      Col := 1;                                                       {.CP26}
      while Col<= length(Line) do begin
         if Line[Col]=#9 then begin                   {if Tab in that column}
            Delete(Line,Col,1);                             {remove Tab char}
            Nchrs := Col mod TabSize;
            if Nchrs=0 then Nchrs := TabSize;
            Nchrs := 9 - Nchrs;                  {number of blanks to insert}
            for B := 1 to Nchrs do begin
               insert(TabChr,Line,Col);                      {insert TabChrs}
               if not LongOne then                      {Check if overlength}
                  if length(Line)>Max then StartLineEnd;
            end; {for B}
            Col := Col + pred(Nchrs);                {move Col to end of Tab}
            if LongOne then begin                   {re-cut Line and LineEnd}
               B := length(Line) - Nchrs;
               while not (Line[B] in [#32,TabChr]) do dec(B);    {find blank}
               Nchrs := length(Line) - B;
               for B := 1 to Nchrs do begin                     {shift chars}
                  LineEnd := Line[length(line)] + LineEnd;
                  delete(Line,length(line),1)
               end {for B}
            end {if LongOne}
         end; {if Line[Col] is Tab}
         inc(Col)                                             {increment Col}
      end {while Col}
   end; {TabSpace}

   procedure FixRemainder;                                            {.CP17}
   var
      B:           byte;
   begin
      while (LineEnd[1]=#32) and (LineEnd<>'') do       {Strip leading}
         delete(LineEnd,1,1);                           {blanks from LineEnd}
      B := 1;
      while (LineEnd[B]=TabChr) and (B<=length(LineEnd)) do        {get past}
         inc(B);                                                    {TabChrs}
      while (LineEnd[B]=#32) and (length(LineEnd)>=B) do      {strip further}
         delete(LineEnd,B,1);                                        {blanks}
      B := 1;
      while (B<length(Line)) and (Line[B]=' ') do begin      {Pad LineEnd to}
         inc(B);                                                 {line it up}
         LineEnd := ' ' + LineEnd
      end {while (B<}
   end; {FixRemainder}

   procedure DeTab; {turn initial Tab chars into blanks}              {.CP10}
   var
      B:           byte;
   begin
      for B := 1 to length(Line)do
         if Line[B]=TabChr then Line[B] := #32;
   end; {DeTab}

   procedure CutIt(Mx: integer); {Cut line at last}                   {.CP16}
   var                            {possible blank}
      B,Col:       byte;
      Temp:        string;
   begin {CutIt}
      B := Mx;
      while (B>0) and (Line[B]<>' ') do dec(B); {Find last blank space}
      Col := 1;
      while (Col<=B) and (Line[Col]=' ') do inc(Col);       {find 1st non-sp}
      if (Col>=B) then B := Mx;
      Temp := copy(Line,1,pred(B));
      delete(Line,1,pred(B));                                     {Chop line}
      LineEnd := Line + LineEnd;                     {Remainder into LineEnd}
      Line := Temp;
      LongOne := True;                                             {Set flag}
   end; {CutIt}

   procedure SetMax;                                                  {.CP15}
   begin
      if NumberLines
         then Max := 68
         else Max := 79;
      if GotPrnData then begin
         if NumberLines then
            if Mrk then
               Max := Inst.Bt[SW] - 12
            else
               Max := Inst.Bt[SW] - 8
         else
            Max := pred(Inst.Bt[LW]);
      end; {else GotPrnData}
   end; {SetMax}

   procedure XRBillboard;                                              {.CP9}
   begin
      if XRef then
         WriteCRT('Program lines:',14,15,Bright)
      else begin
         WriteCRT('--- Not Cross-Referencing ---',14,26,Bright);
         WriteCRT('    Printing Line: ',16,26,Bright)
      end {else}
   end; {XRBillboard}

   procedure TotItUp;                                                  {.CP6}
   begin
      GotoXY(49,14); write('Identifiers: ',ScanCount:5);
      GotoXY(49,15); write('Procedures:  ',Pcount:5);
      GotoXY(49,16); write('Occurrences: ',Occur:5)
   end; {TotItUp}

   procedure MarkInc;  {insert INC marker in Line}                    {.CP15}
   var
      B,Indent:    byte;
   begin
      IncMark := '';
      for B := 2 to IFN do IncMark := IncMark + '*';
      case IncState of
         Started:  IncLine := '<=== Including '
                              + IFileName[IFN] + ' ';
         Ended:    IncLine := '<=== Finished '
                              + IFileName[succ(IFN)] + ' *';
         TooDeep:  IncLine := '<=== Too many includes.  Can''t include it.';
         CantFind: Incline := '<=== Couldn''t find it.';
      end; {case}
   end; {MarkInc}

   procedure Include;                                                 {.CP10}
   var
      B,E:         byte;
      ComString:   CMD;
      IncFile:     boolean;

      function DepthOK: boolean;
      begin
         DepthOK := IFN < NoIncFiles
      end; {DepthOK}

      procedure TryToOpen(FName: string; var F: text);                 {.CP10}
      begin
         assign(F,FName);
         {$I-}
         reset(F);
         {$I+}
         if IOresult=0
            then IncState := Started
            else IncState := CantFind
      end; {TryToOpen}

   begin  {Include}                                                   {.CP16}
      B := Pos('{$'+'I',Line) + 3;
      E := Pos('}',Line);
      if (E<>0) and (E>B) then begin
         ComString := Copy(Line,B,E-B);   {Peel out string}
         if ComString[1] in PlusMinus then
            IncFile := False              {It's an IO check}
         else if not Turbo3 then
            IncFile := ComString[1]=#32   {T4 needs blank for INClude}
         else
            IncFile := True;              {T3 doesn't & has no IFDEF}
      end {if E...}
      else begin
         ComString := '';
         IncFile := False
      end; {else}
      if IncFile then begin                        {if an INCLUDE}    {.CP14}
         ComString := InCapitals(Strip(ComString,[#32]));
         inc(IFN);
         IFileName[IFN] := ComString;
         if DepthOK then begin                     {if Inc depth left}
            FixUpFileName(IFileName[IFN]);
            TryToOpen(IFileName[IFN],IFil[IFN]);          {try name as found}
            if IncState=CantFind then begin
               while (pos(':',IFileName[IFN])<>0)         {if no go as found}
                     or (pos('\',IFileName[IFN])<>0) do
                        delete(IFileName[IFN],1,1);   {try same path as main}
               IFileName[IFN] := PathSign + IFileName[IFN];
               TryToOpen(IFileName[IFN],IFil[IFN]);
            end; {if couldn't find}
            if IncState=CantFind then    {if still no go, search path} {.CP9}
               if FindFile(IFileName[IFN]) then begin    {if found}
                  Assign(IFil[IFN],IFileName[IFN]);         {set up new file}
                  Reset(IFil[IFN]);
                  IncState := Started
               end; {if file found}
            if IncState=Started then             {if file found (somewhere)}
               CenterCRT('Including ' + IFileName[IFN],
                         12,Bright,Inside)    {showing where found}
            else begin                        {If file not found  }   {.CP11}
               Blank(12,12);                                 {report failure}
               FixUpFileName(IFileName[IFN]);
               CenterCRT('Can''t find '+IFileName[IFN],
                          12,Bright,Inside);
               dec(IFN);
            end; {if can't find it}
            while (pos(':',IFileName[IFN])<>0)           {strip pathmarks}
               or (pos('\',IFileName[IFN])<>0) do        {for printout}
                  delete(IFileName[IFN],1,1);
         end {if inc depth left}
         else begin                         {report no inc depth left} {.CP8}
            CenterCRT('Too many Include files',12,Bright,Inside);
            dec(IFN);
            IncState := TooDeep
         end; {else --no inc depth left}
         MarkInc;
      end {if IncFile}
   end; {Include}

   procedure CutAndPrint;                                             {.CP26}
   begin
      if LongOne then begin
         Line := LineEnd;
         LongOne := False
      end {if LongOne}
      else begin
         readln(IFil[IFN],Line);
         if EOF(IFil[IFN]) and (IFN>1) then begin
            CloseCarefully(IFil[IFN]);
            dec(IFN);
            IncState := Ended;
            MarkInc
         end; {if Eof}
         if not Vanilla then begin
            if pos('{',Line)<>0 then begin
               if pos('{.',Line)<>0 then begin
                  if pos(HeaderMark,Line)<>0 then GetHeaderInstruction(Line);
                  if (pos('{'+'.C',Line)<>0) or (pos('{'+'.P',Line)<>0) then
                     PrintControl(PageLineNumber);
               end; {if '{.'}
               if Pos('{'+'$I',Line)=1 then Include
            end; {if '{'}
         end; {if not Vanilla}
         if PageLineNumber=-1 then PrintHeader(PageLineNumber);
      end; {else --read next line}
      LineEnd := '';                                                  {.CP15}
      MaxLess := Max - length(IncMark) - length(IncLine);
      if length(Line)>MaxLess then CutIt(MaxLess);{CutIt sets LongOne = True}
      if pos(#9,Line)<>0 then TabSpace;
      if LineEnd<>'' then FixRemainder; {pad LineEnd w matching blanks}
      if Pos(TabChr,Line)<>0 then DeTab;
      Line := ' ' + Line + ' ';                   {Pad line w blanks at ends}
      inc(PageLineNumber);
      Pager := PageLineNumber;
      if (PageLineNumber>MaxLin) and not XRefOnly then begin
         NewPage(Pager);
         PrintHeader(PageLineNumber);
      end; {if (PageLine.. }
      PrintLine;
   end; {CutAndPrint}

   procedure Initialize;                                              {.CP18}
   var
      HS: HdSegType;
      K: integer;
   begin
      assign(Lst,OutputDevice); rewrite(Lst);
      if GotPrnData then begin
         write(Lst,Istring[PreP]);
         PrePSent := True
      end {if GotPrnData}
      else
         PrePSent := False;
      CursorOff;
      for K := 1 to NoIncFiles do IFileName[K] := '';
      for K := 1 to 20 do begin
         RecDepth[K] := 0;
         CaseDepth[K] := 0
      end; {for K}
      HeaderMark := '{' + '.H'; AltHeaders := False;                  {.CP14}
      Occur := 0; ScanCount := 0; PCount := 0;
      for K := 0 to TableSize do T[K] := Nil; Longest := 0;
      OpLen := length(Opening); ClLen := length(Closing);
      Cut := ''; UnCut := ''; Depth := 0; InRec := 0;
      LongOne := False; NoLine := False; Enough := False;
      Cuts[1] := '(*'; Cuts[2] := '{'; Cuts[3] := #39;
      UnCuts[1] := '*)'; UnCuts[2] := '}'; UnCuts[3] := #39;
      LineNumber := 1; Page := 1; IncState := OK;
      IFN := 1; assign(IFil[1],FileName); FileName := Shortened(FileName);
      MakeFirstHeader(IFil[1]);
      IncMark := ''; IncLine := '';  NextIsProc := False;
      QuitStrg := Istring[SetLg];
      FirstProc := Nil;
      SetMax;
   end; {Initialize}

begin {ListIt}                                                        {.CP23}
   ReadingMatterI;
   Enough := Escape;
   if not Enough then begin
      Initialize;
      if FFeed then NewPage(1);
      if not XRefOnly then PageLineNumber := -1;
      XRBillboard;
      while (LongOne or not EOF(IFil[IFN])) and not Enough do begin
         CutAndPrint;
         Enough := Escape
      end; {while}
      for B := IFN to 1 do CloseCarefully(IFil[IFN]);    {Close source files}
      if not XRefOnly then NewPage(Pager);
      if XRef and not Enough then begin
         XRefOnly := True;          {used as a flag  --more clever than good}
         ReadingMatterII;             {Hmm.  Isn't that what "kludge" means?}
         PrintTable;
         TotItUp;
         NewPage(Pager)
      end; {if XRef and not Enough}
   end {if not Enough}
end; {ListIt}

End. {Unit PXLLIST}