{.L+ }
program SList;

(*************************************************)
(*       SLIST Version 1.00A - CP/M, Z80         *)
(*                                               *)
(*        (C) Copyright 1985, Herb Bowie.        *)
(*     All commercial rights reserved.  This     *)
(*  program is licensed for non-commercial use.  *)
(*                                               *)
(* Have you payed for this program yet?  If not, *)
(* and you find it useful, then may I suggest    *)
(* that you make a small donation to its author? *)
(* Something like $10 would be wonderful.  You   *)
(* may send it to:                               *)
(*                                               *)
(*                   Herb Bowie                  *)
(*                 P.O. Box 4724                 *)
(*          Culver City, CA  90231-4724          *)
(*                                               *)
(*************************************************)

(*

NAME
  Slist.Pas

AUTHOR
  Herb Bowie.

FUNCTION
  Prints Turbo Pascal source code, and/or
  documentation.

*)

type
{$I A:SysType.Typ  }

const
{$I A:SysConst.Con }
  PIi =  1;
  PTi =  2;
  HEi =  3;
  FOi =  4;
  SXi =  5;
  FFi =  6;
  BEi =  7;
  CMi =  8;
  CCi =  9;
  SQi = 10;

  ICi = 11;
  PLi = 12;
  LLi = 13;
  POi = 14;
  MTi = 15;
  HMi = 16;
  MBi = 17;
  FMi = 18;

  MaxCodes      = 24;
  ReservedWords = 148;

  CRTRows       : integer      = 24;
  CRTColumns    : integer      = 52;
  First         : boolean      = true;
  FilePic       : string [14]  = 'F:FFFFFFFF.FFF';
  InName        : string [14]  = 'A:.PAS';
  ErrorMsg      : string [80]  = '';
  IdStartChars  : set of char  = ['A'..'Z', '_'];
  IdChars       : set of char  = ['0'..'9', 'A'..'Z', '_'];

type
  String2       = string [2];
  String10      = string [10];
  String14      = string [14];
  String23      = string [23];
  String128     = string [128];
  CodeIndexType = 1..MaxCodes;
  RsvWordIndexType = 1..ReservedWords;

var
{$I A:SysVar.Var   }
  CtrlFile      : text;
  ListFile      : text;
  InFile        : text;
  IncFile       : text;
  SXFile        : text;
  RsvFile       : text;
  InRec         : string [135];
  WorkLine      : string [192];
  Word          : string [128];
  OutLine       : string [192];
  TempLine      : string [192];
  LastName      : string [14];
  IncName       : string [14];
  SXName        : string [14];
  SXString      : string [133];
  PageStr       : string [5];
  CommentValue  : string [128];
  NextChar      : char;
  CurrChar      : char;
  LastChar      : char;
  WorkBool      : char;
  SXDrive       : char;
  SXOption      : char;
  LastLine      : integer;
  BCount        : integer;
  KCount        : integer;
  PageCt        : integer;
  LineCt        : integer;
  NextSeqCt     : integer;
  SeqCt         : integer;
  SeqCtWritten  : integer;
  InLng         : integer;
  DataLng       : integer;
  PrefixLng     : integer;
  CI            : integer;
  LastCI        : integer;
  CurrCI        : integer;
  NextCI        : integer;
  I, J          : integer;
  IncStart      : integer;
  RsvIndex      : integer;
  CRTLine       : integer;
  AnotherFile   : boolean;
  SXOpen        : boolean;
  LineToPrint   : boolean;
  PrintingLines : boolean;
  FormatOnLine  : boolean;
  OldLineDone   : boolean;
  IncOn         : boolean;
  PageBegun     : boolean;
  RsvLoaded     : boolean;
  CodeWork      : String [2];
  CodeNumber    : integer;
  CodeNum       : CodeIndexType;
  CodeIndex     : CodeIndexType;
  Code          : array [CodeIndexType] of String2;
  CodeType      : array [CodeIndexType] of char;
  CodeDesc      : array [CodeIndexType] of String23;
  CodeMaxLng    : array [CodeIndexType] of integer;
  CodeInt       : array [CodeIndexType] of integer;
  CodeStr       : array [1..4]          of String128;
  CodeBool      : array [CodeIndexType] of boolean;
  RsvPtr        : array [1..26]         of integer;
  ReservedWord  : array [RsvWordIndexType] of String10;

{$I A:Center.Fnc   }

{$I A:CPM.Prc      }

{$I A:CRT.Prc      }

{$I A:DiskFile.Fnc }

{$I A:HexToChr.Fnc }

{$I A:LCRJust.Fnc  }

{$I A:LST.Prc      }

{$I A:ManyChar.Fnc }

{$I A:Replace.Fnc  }

{$I A:Squeeze.Fnc  }

{$I A:SysInit.Prc  }

{$I A:SayBool.Fnc  }

{$I A:Trim.Fnc     }

{$I A:Wait.Prc     }

{$I A:GetPic.Fnc   }

{$I A:SayPic.Fnc   }

procedure WriteMsg;          (* Writes message at bottom of screen *)
  begin
    gotoxy (1, CRTRows);
    clreol;
    if ErrorMsg <> '' then
     begin
      CRTBeep;
      write (Center (ErrorMsg, CRTColumns));
     end;
  end;

procedure Clean;             (* Clears screen and positions cursor *)
  begin
    clrscr;
    writeln ('SLIST    Turbo Pascal Source Lister   ', InName);
    WriteMsg;
    gotoxy (1, 3);
  end;

procedure WriteSeqCt;
  begin
    gotoxy (3, CRTLine);
    write (NextSeqCt:5);
    SeqCtWritten := NextSeqCt;
  end;

procedure WriteFileLine (FileName: String14);
  begin
    if CRTLine > 5 then
      WriteSeqCt;
    if (CRTLine < (CRTRows - 2)) then
      CRTLine := CRTLine + 1
    else
     begin
      gotoxy (1, 5);
      delline;
     end;
    WriteSeqCt;
    write ('  ', FileName);
  end;

{$I B:SLIST1.INC   }

{$I B:SLIST2.INC   }

{$I B:SLIST3.INC   }


procedure SXRef;
  type
    DataItemType = record
      Seq  : integer;
      Word : string [64];
      end;
  var
    DataItem  : DataItemType;
    SortResult: integer;
    ItemSize  : integer;
    SortInCt  : integer;
    SortOutCt : integer;
    LastSortCt: integer;
    ValCode   : integer;
    WordLength: integer;

   {$I B:Sort.Box     }

  procedure Inp;
    begin
      reset (SXFile);
      SortInCt := 0;
      LastSortCt := 0;
      gotoxy (1, 8);
      write ('      Records released to Sort');
      while not eof (SXFile) do
       begin
        readln (SXFile, SXString);
        val (squeeze (copy (SXString, 1, 5), Blank),
          DataItem.Seq, ValCode);
        if ValCode > 0 then
          DataItem.Seq := 0;
        WordLength := length (SXString) - 6;
        if WordLength > 64 then
          WordLength := 64;
        DataItem.Word := copy (SXString, 7, WordLength);
        SortRelease (DataItem);
        SortInCt := succ (SortInCt);
        if SortInCt > (LastSortCt + 9) then
         begin
          gotoxy (1, 8);
          write (SortInCt: 5);
          LastSortCt := SortInCt;
         end;
       end;
      gotoxy (1, 8);
      write (SortInCt:5);
      close (SXFile);
      gotoxy (1, 10);
      writeln ('Sorting file now...');
    end;

  function Less;
    var
      Rec1 : DataItemType absolute X;
      Rec2 : DataItemType absolute Y;
    begin
      Less := ((Rec1.Word < Rec2.Word)
        or ((Rec1.Word = Rec2.Word)
          and (Rec1.Seq < Rec2.Seq)));
    end;

  procedure OutP;
    var
      SaveCodeBoolCMi : boolean;
      SaveCodeBoolBEi : boolean;
      SaveCodeBoolSQi : boolean;
      LastWord        : string [64];
      SeqStr          : string [6];
    procedure PutSXLine;
      begin
        if length (OutLine) > 0 then
         begin
          OutLine := ManyChar (blank, CodeInt [POi])
            + OutLine;
          PutLine;
         end;
      end;
    begin
      EndPage;
      SaveCodeBoolCMi := CodeBool [CMi];
      SaveCodeBoolBEi := CodeBool [BEi];
      SaveCodeBoolSQi := CodeBool [SQi];
      CodeBool [CMi]  := false;
      CodeBool [BEi]  := false;
      CodeBool [SQi]  := false;
      Compute;
      LineCt := 99;
      LastWord := '';
      OutLine := '';
      SortOutCt := 0;
      LastSortCt := 0;
      gotoxy (1, 12);
      write ('      Records returned from Sort');
      while not SortEOS do
       begin
        SortReturn (DataItem);
        if DataItem.Word <> LastWord then
         begin
          PutSXLine;
          OutLine := DataItem.Word;
          while ((length (OutLine) < 32)
            or (((length (OutLine) - 32) mod 6) > 0)) do
            OutLine := OutLine + '.';
          LastWord := DataItem.Word;
         end;
        if length (OutLine) = 0 then
          OutLine := ManyChar (Blank, 32);
        str (DataItem.Seq:6, SeqStr);
        OutLine := OutLine + SeqStr;
        if (length (OutLine) + 6) > DataLng then
         begin
          PutSXLine;
          OutLine := '';
         end;
        SortOutCt := succ (SortOutCt);
        if SortOutCt > (LastSortCt + 9) then
         begin
          gotoxy (1, 12);
          write (SortOutCt:5);
          LastSortCt := SortOutCt;
         end;
       end;
      gotoxy (1, 12);
      write (SortOutCt:5);
      PutSXLine;
      CodeBool [CMi] := SaveCodeBoolCMi;
      CodeBool [BEi] := SaveCodeBoolBEi;
      CodeBool [SQi] := SaveCodeBoolSQi;
    end;

  begin
    Clean;
    writeln ('Insert a sort work disk in the SLIST drive,');
    writeln ('if extra sort work space is needed.');
    writeln;
    Wait;
    writeln;
    NewDisks;
    ItemSize := SizeOf (DataItem);
    SortResult := TurboSort (ItemSize);
    writeln;
    writeln;
    if SortResult = 0 then
      erase (SXFile)
    else
     begin
      writeln ('*** Unsuccessful Sort: ', SortResult, ' ***');
      Wait;
      writeln;
     end;
    writeln ('Remove sort work disk now, and replace SLIST disk,');
    writeln ('if sort work disk inserted earlier.');
    writeln;
    Wait;
    NewDisks;
  end;

begin
  SysInit;
  LoadCodes;
  RsvLoaded := false;
  repeat
    GetInFile;
    if AnotherFile then
     begin
      GetOptions;
      Compute;
      assign (ListFile, 'LST:');
      reset (ListFile);
      assign (SXFile, SXName);
      SXOpen := false;
      LineCt := 99;
      PageCt := 0;
      SeqCt  := 0;
      NextSeqCt := 0;
      KCount := 0;
      BCount := 0;
      PrintingLines := true;
      LineToPrint := false;
      PageBegun := false;
      Clean;
      writeln ('Make Sure Printer Is Ready.');
      Wait;
      CsrUp (2);
      clreol;
      writeln;
      clreol;
      gotoxy (1, 3);
      writeln ('Printing...');
      write (ListFile, HexToChr (CodeStr [PIi]));
      LSTLngth (CodeInt [LLi]);
      if SXOption <> 'R' then
       begin
        assign (InFile, InName);
        if SXOption in ['A', 'U'] then
         begin
          rewrite (SXFile);
          SXOpen := true;
          if ((SXOption = 'U') and (not RsvLoaded)) then
           begin
            assign (RsvFile, 'A:SLISTRSV.DAT');
            reset (RsvFile);
            for RsvIndex := 1 to ReservedWords do
             begin
              readln (RsvFile, ReservedWord [RsvIndex]);
              if ((RsvIndex = 1)
                or (ReservedWord [RsvIndex] [1]
                  <> ReservedWord [RsvIndex - 1] [1])) then
                RsvPtr [ord (ReservedWord [RsvIndex] [1]) - 64]
                  := RsvIndex;
             end;
            close (RsvFile);
            RsvLoaded := true;
           end;
         end;
        reset (InFile);
        IncOn := false;
        CRTLine := 4;
        WriteFileLine (InName);
        CurrChar := Blank;
        NextChar := Blank;
        OldLineDone := true;
        GetChar;
        GetChar;
        while CurrChar <> EndFile do
          ProcWord;
        PrintLine;
        WriteSeqCt;
       end;
      if SXOpen then
       begin
        close (SXFile);
        SXOpen := false;
       end;
      if SXOption in ['A', 'R', 'U'] then
        SXRef;
      EndPage;
      write (ListFile, HexToChr (CodeStr [PTi]));
     end; (* if AnotherFile *)
  until not AnotherFile;
  clrscr;
  writeln ('Thanks for using Singular Software!');
end.
