Power-Programmierung/CD1.mdf/pascal/utility/crossref/pxl/pxllist.pas

Pascal/Delphi Source File | 1988-05-04 | 48.0 KB | 1,262 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;                                                     {.CP10}
const
   TableSize               = 2521;
   Digits                  = 5;
   ProcName                = #158;
   TabChr                  = #0;
   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'];
   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 LineType;
   HdType      =    array[1..MaxHeader] of HdLineType;
   HeaderType  =    array[First..Other] of HdType;
var                                                                   {.CP22}
   Header:         HeaderType;
   NumOfWords:     TableNum;
   T:              array[TableNum] of WPt;
   Tp:             WPt;
   MaxLess,
   Max,Longest,
   ScanCount,K,
   Occur,PCount,
   Pager,Depth:    integer;
   Cut,Uncut:      Str2;
   Cuts,Uncuts:    array[1..3] of Str2;
   OpLen,ClLen,
   B,Inrec:        byte;
   RecDepth,
   CaseDepth:      array[1..20] of byte;
   IncLine,
   LineEnd,UC:     str255;
   IncMark:        string[8];
   Elite,Condensed,
   LongOne,NoLine: boolean;
   IncState:       Incs;

   procedure BlankHeaderLines;                                        {.CP10}
   var
      LNo:    integer;
      HS:     HdSegType;
   begin
      for LNo := 1 to MaxHeader do
         for HS := Left to Right do
            Header[First][LNo,HS] := '';
      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]<>'' 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);                      {.CP24}
      (*
      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  (Has no effect in PXL.HDR or Top Lines)
         .HPLnn = nn lines per page (default is 66 - BottomMargin)
      Text for header line segment begins 1 col AFTER end of symbol
      Within header line text:
         .Fn = file name
         .Fd = file date (long date)
         .Ft = file time (12 hr am/pm)
         .Pd = present (or printout) date (numeral)
         .Pd = present (or printout) time (24 hr)
         .Id = ID (from PXL.ID)
          #  = page number
       *)
   var
      IStrg: LineType;
      Cue:   Str3;
      Col:   integer;

      procedure ResetMaxLin(S: LineType);                             {.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, provided you can forego FF's.                           }
      var
         NumStr: Str20;
         K,E:    integer;
      begin
         if S[1]='L' then begin
            K := 2;
            NumStr := '';
            while (S[K] in NumZ9) and (K<=ord(S[0])) do begin
               NumStr := NumStr + S[K];
               inc(K)
            end; {while 0..9}
            if NumStr[0]>#0 then val(NumStr,K,E);
            if (K>0) and (E=0) then MaxLin := K        {if error, do nothing}
         end {if L}
      end; {ResetMaxLin}

      function FixedUpHeaderLine(L: LineType): 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);
         FixedUpHeaderLine := L
      end; {FixedUpHeaderLine}

      procedure InterpretInstruction(Strg: LineType);                 {.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
        else if C='P' then
           ResetMaxLin(Strg)
        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] := ''
              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 := '{' + '.H';
      while pos(Cue,Line)>0 do begin
         Col := pos(Cue,Line) + 3;
         IStrg := '';
         while (Line[Col]<>'}') and (Col<=ord(Line[0])) 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): LineType;                     {.CP21}
   var
      Spaces,K: integer;
      Temp:     LineType;
      Pg:       HdPgType;
      Sg:       HdSegType;   C: char;
   begin
      Temp := '';
      if Page<2
         then Pg := First
         else Pg := Other;
      for Sg := Left to Right do         {Must update page number every page}
         while pos('#',H[Sg])>0  do
            Replace('#',StrgI(Page,1),H[Sg]);
      repeat               {Splice left & right segs --chopping if necessary}
         Spaces := ord(H[Left,0]) + ord(H[Right,0]);
         if Spaces>79 then begin
             if H[Right,0]>#0 then delete(H[Right],1,1)
             else if H[Left,0]>#0 then dec(H[Left,0])
         end {if Spaces}
      until Spaces<=79;
      Temp := H[Left];           {Overprint line with Center segment} {.CP10}
      for K := 1 to (79 - Spaces) do Temp := Temp + #32;
      Temp := Temp + H[Right];
      if H[Center]<>'' then begin
         Spaces :=  39 - (ord(H[Center,0]) div 2);
         for K := 1 to ord(H[Center,0]) do
            Temp[K+Spaces] := H[Center,K]
      end; {if Center}
      HeaderLine := Temp;
   end; {HeaderLine}

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

      function GotDefaultHeaderFromFile: boolean;
      var
         FName:  LineType;
         F:      text;
      begin
         FName := 'PXL.HDR';
         if FindFile(FName) then begin
            assign(F,FName);
            reset(F);
            while not Eof(F) do begin
               readln(F,Lin);
               if pos('{' + '.H',Lin)<>0 then begin
                  GetHeaderInstruction(Lin)
               end {if Cue}
            end; {while not Eof}
            close(F);
            GotDefaultHeaderFromFile := True
         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 UserID[0]>#0 then
            Header[First][1,Left] := Header[First][1,Left]
                                     + '  [' + UserID + ']';
         Header[Other][1] := Header[First][1];
         Header[Other][1,Right] := 'Page #' (* + StrgI(Page,1); *)
      end; {MakeStandardDefaultHeader}

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

   begin {MakeFirstHeader}                                             {.CP9}
      BlankHeaderLines;
      if not GotDefaultHeaderFromFile then MakeStandardDefaultHeader;
      reset(Fil);
      readln(Fil,Lin);
      if pos('{'+'.H',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)}  {.CP21}
   var
      Line:   String;
      K,Nr:   integer;
      Pg:     HdPgType;
   begin
      {$I-}
      writeln(Lst);
      {$I+}
      if not (IOresult=0) then
         CantCont('','Printer''s out');
      Line := '';
      if GotPrnData then
         if Wide then                                  {Set normal Pica}
            write(Lst,Istring[CondE])
         else if Numberlines then
            write(Lst,Istring[EliteE]);
      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 Wide then                                 {Set Condensed type}
            write(Lst,Istring[CondB])
         else if NumberLines then                     {or Elite}
            write(Lst,Istring[EliteB]);
      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;                                          {.CP12}
   begin
      Blank(9,12);
      if not Xref then
         CenterCRT('Sending ' + FileName + ' to ' + OutputDevice,
               10,Bright,0)
      else if not XRefOnly then
         CenterCRT('Scanning ' + FileName + ' and sending to '
               + OutputDevice + '.', 10,Bright,0)
      else
         CenterCRT('Scanning ' +  FileName,10,Bright,0)
   end; {ReadingMatterI}

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

   procedure NewPage(Pager: integer);                                 {.CP15}
   var
      I:           integer;
   begin
(*      {$I-}
      writeln(Lst);
      {$I-}
      if IOresult<>0 then CantCont('','Printer''s out.'); *)
      if Inst[FF,1]=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[FF,1] do writeln(Lst);
      end {no FF}
   end; {NewPage}

   procedure PrintTable;                                              {.CP17}
   type
      ProcPtr   =  ^ProcWord;
      ProcWord  =  record
                      Name:   Str20;
                      LinNum: 0..MaxInt;
                      Next:   ProcPtr;
                   end;
   var
      I:           TableNum;
      Lin:         integer;
      NumPerLine:  byte;
      PL:          record
                      First: ProcPtr;
                      Last:  ProcPtr;
                   end;
      PLptr:       ProcPtr;

      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;

      procedure ProcProc; {Add new proc/func name to list}
      begin
         Delete(W.Name,1,1);                          {remove tell-tale mark}
         New(PLptr);
         PLptr^.Name := W.Name;
         PLptr^.LinNum := X^.LinNum;
         PLptr^.Next := Nil;
         if PL.First = Nil then begin
            PL.First := PLptr;
            PL.Last := PLptr
         end; {if first procedure}
         PL.Last^.Next := PLptr;
         PL.Last := PLptr
      end; {ProcProc}

      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;
         if W.Name[1]=ProcName then ProcProc;         {add to proc/func list}
         Write(Lst,#32,W.Name);
         for B := 1 to Longest-ord(W.Name[0]) 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-ord(W.Name[0]) 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,PL.First^.Name);
            for B := 1 to Longest-ord(PL.First^.Name[0]) do write(Lst,#32);
            writeln(Lst,PL.First^.LinNum:Digits);
            inc(I);
            GotoXY(30,16);
            Write(I:5);
            PL.First := PL.First^.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 PL.First=PL.Last then              {Just one proc/func in list}
            PrintAProc
         else
            while (PL.First<>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;
      PL.First := Nil; PL.Last := Nil;
      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 (PCount>0) 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: Str255; LinNo: integer);        {.CP18}
   var
      Ident:      WordType;
      Len,I:      byte;
      Col:        integer;
      ProcOrFunc: boolean;

      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:   integer);
                          3: (Arr: array[0..20] of byte);
                    end;
         X:         Ref;
         H,D,Start: TableNum;
      begin
         ID.Key := Ident.Key;
         inc(Occur);
         H := abs(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 ord(ID.Key[0])>Longest then             {update Longest   }
                   Longest := ord(ID.Key[0]);
               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; ProcOrFunc := False;
      Len := ord(UC[0]);
      while Col<=Len do begin                                {creep along UC}
         if UC[Col]<>#32 then begin                  {looking for non-blanks}
            if UC[Col] <> ProcName then begin   {if a normal character      }
               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}
               if ProcOrFunc then begin     {.CP15} {if it's a new procedure}
                  insert(ProcName,Ident.Name,1);       {mark the Name       }
                  ProcOrFunc := False
               end; {if ProcOrFunc}
               Hash(Ident)                          {put into the hash table}
            end {if not ProcName}
            else begin                           {if it's the Procedure sign}
               ProcOrFunc := True;
               inc(Col)
            end {else --ProcName}
         end {if not blank}
         else
            inc(Col);
      end {while}
   end; {ScanAndHash}

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

      procedure Ins (var Line,UC :Str255; Op,Cl:Str3);
      var
         Z,Len,B:     byte;
         K,Col:       integer;
         ShdBeMarked: boolean;
         Obj:         Str10;
      begin {Ins}
         for K := 1 to NRes do begin            {Check against Key word list}
            if Pos(Reserv[K],UC)<>0 then begin     {if Key word is in line  }
               Obj := Reserv[K];
               Col := pos(Obj,UC);
               Len := ord(Obj[0]);
               repeat                                                 {.CP15}
                  if (UC[pred(Col)]=#32) and               {if surroundings OK  }
                     (UC[Col+Len]=#32) then begin
                     insert(Cl,Line,Col+Len);              {Insert Closing  }
                     insert(Op,Line,Col);                  {Insert Opening  }
                     for B := Col to Col+pred(Len) do      {blank Obj in UC }
                        UC[B] := #32;
                     if Xref and (Obj='PROCEDURE')
                        or (Obj='FUNCTION') then begin     {Mark Proc & Func}
                        inc(PCount);
                        UC[Col+OpLen] := ProcName
                     end; {if XRef &}
                     for B := 1 to OpLen+ClLen do     {Blanks to match up UC}
                        insert(#32,UC,Col);
                     Col := Col + Len + OpLen + ClLen;   {move to end of Obj}
                     if NumberLines then begin                        {.CP23}
                        if (Obj='BEGIN') or
                        (Obj='REPEAT') or (Obj='CASE') then {count begin/end}
                           inc(Depth)
                        else if (Obj='END')  then begin {Style Critics: Yes,}
                           if InRec=0 then              {this should be a   }
                              dec(Depth)                {procedure in itself}
                           else begin                   {but, in so busy a  }
                              Depth := RecDepth[InRec]; {loop, we must avoid}
                              dec(InRec)                {overhead.          }
                           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 surroundings Okay}
                  else
                     Col := Col + Len;                    {move Col past obj}
                  if Col>(ord(Line[0])-succ(Len)) then                {.CP13}
                     ShdBeMarked := False
                  else begin                                       {Another?}
                     B := pos(Obj,copy(UC,succ(Col),ord(UC[0])-Col));  {.CP9}
                     if B=0 then                         {No, so         }
                        ShdBeMarked := False             {   Exit        }
                     else begin                          {Yes, so        }
                        Col := Col + B;                  {   Move up Col }
                        ShdBeMarked := True              {   Go again    }
                     end {else}
                  end {if Col}
               until not ShdBeMarked
            end {if Col<>0}
         end {for K --once for each word in Key word list}
      end; {procedure Ins}

   procedure BlankBrackets(var UC: Str255);                           {.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 ord(UC[0]) 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 := ord(UC[0]);
         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 ord(UC[0]) do          {blank rest of UC}
               UC[I] := #32;
      end {while openers in UC}
   end; {BlankBrackets}

   procedure ClearIdentifiers (var UC: Str255);                       {.CP29}
   var
      I:           byte;
   begin
      InMiddle := False; InHex := False;
      for I := 1 to ord(UC[0]) 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}
            InHex := True;
            InMiddle := False;
            UC[I] := #32
         end {else $}
         else
            if InMiddle then begin                         {in an identifier}
               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}
               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}                                                   {.CP9}
      UC := Line;                                    {Prepare guide template}
      for B := 1 to ord(UC[0]) 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:      LineType;
   begin
      RealLength := ord(Line[0]) - 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+ ' ' +StrgB(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,ord(Line[0])-2);                {remove padding}
      if (IncMark[0]>#0) or (IncLine[0]>#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 writeln(Lst,Opener,Line);        {Enfin! WRITE}
      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 8 chars)}      {.CP15}
   var
      B,Col,Nchrs: byte;

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

   begin
      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<= ord(Line[0]) do begin
         if Line[Col]=#9 then begin                   {if Tab in that column}
            Delete(Line,Col,1);                             {remove Tab char}
            Nchrs := Col mod 8;
            if Nchrs=0 then Nchrs := 8;
            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 ord(Line[0])>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 := ord(Line[0]) - Nchrs;
               while not (Line[B] in [#32,TabChr]) do dec(B);    {find blank}
               Nchrs := ord(Line[0]) - B;
               for B := 1 to Nchrs do begin                     {shift chars}
                  LineEnd := Line[ord(line[0])] + LineEnd;
                  delete(Line,ord(line[0]),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 (ord(LineEnd[0])>0) do       {Strip leading}
         delete(LineEnd,1,1);                           {blanks from LineEnd}
      B := 1;
      while (LineEnd[B]=TabChr) and (B<=ord(LineEnd[0])) do        {get past}
         inc(B);                                                    {TabChrs}
      while (LineEnd[B]=#32) and (ord(LineEnd[0])>=B) do      {strip further}
         delete(LineEnd,B,1);                                        {blanks}
      B := 1;
      while (B<ord(Line[0])) 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 ord(Line[0])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:        Str255;
   begin
      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;                                                  {.CP13}

      procedure UseEliteForCondensed;
      var
         I:   integer;
      begin
         Istring[CondB] := Istring[EliteB];
         Istring[CondE] := Istring[EliteE];
         for I := 1 to 3 do begin
            Inst[CondB,I] := Inst[EliteB,I];
            Inst[CondE,I] := Inst[EliteE,I]
         end; {for I}
      end; {UseEliteForCondensed}

      function CondensedElite: boolean; {T iff CondB = EliteB}         {.CP7}
      var
         I:   integer;
      begin
         CondensedElite := True;
         for I := 1 to 3 do
            if (Inst[EliteB,I]<>Inst[CondB,I]) then
               CondensedElite := False
      end; {CondensedElite}

   begin {SetMax}                                                     {.CP32}
      if not GotPrnData then
         if NumberLines
            then Max := 68
            else Max := 79
      else begin
         if Wide
            then Max := 131
            else Max := 79;
         if NumberLines and Condensed then begin
            if CondensedElite then
               Max := 120             {if so then presume both are condensed}
            else if Elite then begin  {if we have both and they're different}
               if Wide
                  then Max := 120
                  else Max := 84
            end {else if E & C}
            else                         {if we have Condensed but not Elite}
               Max := Max - 11
         end; {if NumberLines and Condensed}
         if Elite and (not Condensed) then begin
            UseEliteForCondensed;
            if Wide then Max := 95;
            if NumberLines then Max := 84
         end {if Elite & not Condensed}
         else if not (Elite or Condensed) then begin
            if wide then Max := 79;
            if NumberLines then Max := 68
         end; {if neither}
         if NumberLines and not Mrk then Max := Max + 4
      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: LineType; 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}                                                   {.CP13}
      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 (pos('-',ComString)<>0) or (pos('+',ComString)<>0)
            then IncFile := False         {Check whether include instruction}
            else IncFile := True
      end {if E...}
      else begin
         ComString := '';
         IncFile := False
      end; {else}
      if IncFile then begin                        {if an INCLUDE}     {.CP7}
         while (ComString[1]=#32) and (ComString[0]>#0) do
            delete(ComString,1,1);                    {strip leading blanks }
         while ComString[ord(ComString[0])]=#32 do    {strip trailing blanks}
            dec(ComString[0]);
         inc(IFN);                                     {move a level down   }
         IFileName[IFN] := ComString;
         if DepthOK then begin                         {if depth left}{.CP10}
            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}{.CP11}
               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 depth left}
         else begin                             {report no depth left} {.CP8}
            CenterCRT('Too many Include files',12,Bright,Inside);
            dec(IFN);
            IncState := TooDeep
         end; {else --no depth left}
         MarkInc;
      end {if IncFile}
   end; {Include}

   procedure CutAndPrint;                                             {.CP24}
   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 pos('{',Line)<>0 then begin
            if pos('{.',Line)<>0 then begin
               if pos('{'+'.H',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 '{'}
         if PageLineNumber=-1 then PrintHeader(PageLineNumber);
      end; {else --read next line}
      LineEnd := '';                                                  {.CP15}
      MaxLess := Max - ord(IncMark[0]) - ord(IncLine[0]);
      if ord(Line[0])>MaxLess then CutIt(MaxLess);{CutIt sets LongOne = True}
      if pos(#9,Line)<>0 then TabSpace;
      if ord(LineEnd[0])>0 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;                                              {.CP10}
   var
      HS: HdSegType;
      K: integer;
   begin
      for K := 1 to NoIncFiles do IFileName[K] := '';
      for K := 1 to 20 do begin
         RecDepth[K] := 0;
         CaseDepth[K] := 0
      end; {for K}
      Occur := 0; ScanCount := 0; PCount := 0;                        {.CP14}
      for K := 0 to TableSize do T[K] := Nil; Longest := 0;
      OpLen := ord(Opening[0]); ClLen := ord(Closing[0]);
      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 := '';
      if Inst[EliteB,1]=255 then Elite := False else Elite := True;
      if Inst[CondB,1]=255  then Condensed := False else Condensed := True
   end; {Initialize}

begin {ListIt}                                                        {.CP30}
   ReadingMatterI;
   Enough := Escape;
   if not Enough then begin
      assign(Lst,OutputDevice); rewrite(Lst);
      CursorOff;
      Initialize;
      SetMax;
      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  --over clever, no doubt}
         ReadingMatterII;
         PrintTable;
         TotItUp;
         NewPage(Pager)
      end; {if XRef and not Enough}
      if Wide then write(Lst,Istring[CondE]);    {Put printer back to normal}
      if Numberlines then write(Lst,Istring[EliteE])
   end {if not Enough}
end; {ListIt}

End. {Unit PXLLIST}