Program TP_Doc;

{***************************************************************************}



uses

  Croft,

  Crt;



const

  Bracket1 = char(#123);

  Bracket2 = char(#125);



var

  InFile,

  OutFile,

  TempFile,

  WeaveFile: string;

  F1,

  F2,

  TF,

  WF: text;

  InStr: string;

  TypeStr: string[9];

  TextArray: CroftUnitStringArrayType;

  CleanArray: CroftUnitStringArrayType;

  TypeStrArray: array[1..CroftUnitConstant] of string[9];

  Reported: array[1..CroftUnitConstant] of boolean;

  NumSub: integer;

  alpha,

  bravo,

  delta: integer;

  EndName: integer;

  NumBegins,

  NumEnds: integer;

  Started: boolean;

  Position: integer;

  SearchStr: string;

  GlobMode,

  GlobDef: string;

  Done: boolean;

  NewMode: boolean;

  Ext: string;

  IsUnit: boolean;

  UnitMatch: boolean;

  NumScans: integer;

  Lead8: string;



procedure SkimRem;

{***************************************************************************}

begin

  Position := 0;

  repeat

    PosChars(Bracket1, InStr, Position, DumChar);

    if Position <= length(InStr) then

      repeat

        PosChars(Bracket2, InStr, Position, DumChar);

        if Position > length(InStr) then

          begin

            readln(F1, InStr);

            Position := 1;

          end;

      until Position <= length(InStr);

  until Position > length(InStr);

end;



Procedure GetLocalDefinitions;

{***************************************************************************}

begin

  ;

  GlobMode := '';

  repeat

    readln(F1, InStr);

    SkimRem;

    GlobDef := UpCaseStr(InStr);

    DropLeadBlanks(GlobDef);

    NewMode := true;

    Done := false;

    if GlobDef = 'VAR' then

      GlobMode := '  local variable '

    else

      if GlobDef = 'TYPE' then

        GlobMode := '  local type     '

      else

        if GlobDef = 'CONST' then

          GlobMode := '  local constant '

        else

          NewMode := false;

    if not(NewMode) then

      begin

        DropLeadBlanks(InStr);

        SearchStr := UpCaseStr(InStr);

        if pos('BEGIN', SearchStr) <> 0 then

          Done := true

        else

          if (GlobMode <> '') and (InStr <> '') then

            WrLn2T(F2, Bracket1 + '* ' + GlobMode + InStr);

      end;

  until Done;

end;



Procedure ModifyWeaveFile;

{***************************************************************************}

var

  NumSubs: array[1..CroftUnitConstant] of integer;

  NumProgs: integer;

  ProgLine: array[1..CroftUnitConstant] of integer;

  LineNum: integer;

  alpha,

  bravo: integer;

begin

  Reset(TF);

  NumProgs := 0;

  LineNum := 0;

  repeat

    readln(TF, InStr);

    Inc(LineNum);

    if InStr[1] <> ' ' then

      begin

        Inc(NumProgs);

        ProgLine[NumProgs] := LineNum;

        NumSubs[NumProgs] := 0;

      end

    else

      Inc(NumSubs[NumProgs]);

  until EOF(TF);

  Close(TF);

  for alpha := NumProgs downto 1 do

    begin

      Reset(TF);

      for bravo := 1 to ProgLine[alpha] - 1 do

        readln(TF);

      readln(TF, InStr);

      writeln(WF, InStr);

      writeln(WF, '  ', NumSubs[alpha]);

      for bravo := 1 to NumSubs[alpha] do

        begin

          readln(TF, InStr);

          writeln(WF, InStr);

        end;

      close(TF);

    end;

  Close(WF);

  FileDel(TempFile, DumInt);

end;



Procedure DetailSubProgram;

{***************************************************************************}

begin

  WrLn2T(F2, Bracket1 + MultiChar('*',75) + Bracket2);

  WrLn2T(F2, Bracket1 +

    '* SUB-PROGRAMS with LOCAL DEFINITIONS and other SUB-PROGRAMS CALLED');

  WrLn2T(F2, Bracket1 + '*');

  CleanArray[NumSub + 1] := 'MAIN';

  if IsUnit then

    TypeStrArray[NumSub + 1] := 'UNIT'

  else

    TypeStrArray[NumSub + 1] := 'PROGRAM';

  for alpha := 1 to NumSub + 1 do

    begin

      if alpha <> NumSub + 1 then

        begin

          Close(F1);

          Reset(F1);

        end;

      WrLn2T(F2, Bracket1+'* '+ TypeStrArray [alpha]+' '+CleanArray[alpha]);

      WriteLn(TF, CleanArray[alpha]);

      if IsUnit then

        NumScans := 2

      else

        NumScans := 1;

      for delta := 1 to NumScans do

        if alpha <> NumSub + 1 then

          repeat

            readln(F1, InStr);

            SkimRem;

            Position := 0;

            PosString(TextArray[alpha], InStr, Position);

          until Position < length(InStr);

      if alpha <> NumSub + 1 then

        GetLocalDefinitions;

      NumBegins := 0;

      NumEnds := 0;

      Started := false;

      for delta := 1 to NumSub do

        Reported[delta] := false;

      repeat

        if EOF(F1) then

          begin

            close(F1);

            reset(F1);

          end;

        InStr := UpCaseStr(InStr);

        DropLeadBlanks(InStr);

        if (copy(InStr, 1, 5) = 'BEGIN') or (copy(InStr, 1, 4) = 'CASE') then

          begin

            Inc(NumBegins);

            Started := true;

          end

        else

          if copy(InStr, 1, 3) = 'END' then

            Inc(NumEnds);

        for bravo := 1 to NumSub do

          if alpha <> bravo then

            begin

              SearchStr := UpCaseStr(TextArray[bravo]);

              Position := 1;

              repeat

                PosString(SearchStr, InStr, Position);

                if (Position <= length(InStr)) then

                  begin

                    if Reported[bravo] then

                      Position := Position + 1

                    else

                      begin

                        WrLn2T(F2, Bracket1 + '*   calls '

                          + TypeStrArray[bravo] + ' ' + CleanArray[bravo]);

                        WriteLn(TF, '  ' + CleanArray[bravo]);

                        Position := Position + 1;

                        Reported[bravo] := true;

                      end;

                  end;

              until Position > length(InStr);

            end;

        readln(F1, InStr);

      until (NumBegins = NumEnds) and (NumBegins <> 0) and Started;

    end;

  Close(TF);

end;



Procedure GetGlobalDefinitions;

{***************************************************************************}

begin

  WrLn2T(F2, Bracket1 + MultiChar('*',75) + Bracket2);

  WrLn2T(F2, Bracket1 + '*');

  WrLn2T(F2, Bracket1 + '* GLOBAL DEFINITIONS');

  Reset(F1);

  GlobMode := '';

  repeat

    readln(F1, InStr);

    SkimRem;

    GlobDef := UpCaseStr(InStr);

    DropLeadBlanks(GlobDef);

    NewMode := true;

    Done := false;

    if GlobDef = 'VAR' then

      GlobMode := 'GLOBAL VARIABLE '

    else

      if GlobDef = 'TYPE' then

        GlobMode := 'GLOBAL TYPE '

      else

        if GlobDef = 'CONST' then

          GlobMode := 'GLOBAL CONSTANT '

        else

          if GlobDef = 'USES' then

            GlobMode := 'USES UNIT '

          else

            NewMode := false;

    if not(NewMode) then

      begin

        DropLeadBlanks(InStr);

        SearchStr := UpCaseStr(InStr);

        if (pos('BEGIN', SearchStr) <> 0) or (pos('PROCEDURE', SearchStr) <> 0)

          or (pos('FUNCTION',SearchStr) <> 0) then

            Done := true

        else

          if (GlobMode <> '') and (InStr <> '') then

            WrLn2T(F2, Bracket1 + '* ' + GlobMode + InStr);

      end

    else

      WrLn2T(F2, Bracket1 + '*');

  until Done;

  WrLn2T(F2, Bracket1 + '*');

end;



Procedure SetUpFiles;

{***************************************************************************}

begin

  writeln('Max # of sub-programs:  ',CroftUnitConstant);

  GetFileName(InFile, Ext);

  BackUpLine;

  OutFile := InFile + '.DOC';

  InFile := InFile + '.' + Ext;

  SplitFileName(outfile, Lead8, DumStr);

  weavefile := Lead8 + '.' + 'WEV';

  writeln('InFile   :  ',InFile);

  writeln('OutFile  :  ',OutFile);

  writeln('WeaveFile:  ',WeaveFile);

  Wait;

  Assign(WF, weavefile);

  Rewrite(WF);

  TempFile := 'WEAVE.TMP';

  Assign(TF, tempfile);

  Rewrite(TF);

  Assign(F1, InFile);

  Assign(F2, OutFile);

  Reset(F1);

  Rewrite(F2);

end;



Procedure IntroScreen;

{***************************************************************************}

begin

  Clr;

  Say('TP-DOC by 2Lt David Croft, 31st TES.');

  writeln;

  Say('This program documents your Turbo Pascal source code.');

  Say('The output will be a file named "*.DOC".');

  Say('Additionally, a file named "*.WEV" will be created which can be');

  Say('used by the WEAVE program to create a visual representation');

  Say('of the sub-program calls interdependencies.');

  Say('This program may not detect functions without input variables yet.');

  writeln;

end;



{***************************************************************************}

{***************************************************************************}

{***************************************************************************}

begin

  NumSub := 0;

  ;

  IntroScreen;

  SetUpFiles;

  WrLn2T(F2, Bracket1 + MultiChar('*',75) + Bracket2);

  WrLn2T(F2, Bracket1 + '* SUB-PROGRAMS IN ORDER OF APPEARANCE');

  WrLn2T(F2, Bracket1 + '*');

  IsUnit := false;

  UnitMatch := false;

  repeat

    readln(F1, InStr);

    DropLeadBlanks(InStr);

    TypeStr := UpCaseStr(copy(InStr, 1, 9));

    if copy(TypeStr,1, 4) = 'UNIT' then

      IsUnit := true;

    if (TypeStr = 'PROCEDURE') or (TypeStr = 'FUNCTION ') then

      begin

        EndName := 1;

        PosChars('(;',InStr, EndName, DumChar);

        InStr := copy(InStr, 10, EndName - 9);

        DropLeadBlanks(InStr);

        if IsUnit and (NumSub > 1) and (InStr = TextArray[1]) then

          UnitMatch := true

        else

          begin

            Inc(NumSub);

            TextArray[NumSub] := InStr;

            CleanArray[NumSub] := copy(InStr, 1, length(InStr) - 1);

            TypeStrArray[NumSub] := TypeStr;

            WrLn2T(F2, Bracket1 + '* ' + TypeStrArray[NumSub] + ' '

              + CleanArray[NumSub]);

          end;

      end;

  until EOF(F1) or UnitMatch;

  ;

  GetGlobalDefinitions;

  DetailSubProgram;

  ModifyWeaveFile;

  ;

  WrLn2T(F2, Bracket1 + MultiChar('*',75) + Bracket2);

  WrLn2T(F2, Bracket1 + '* SUB-PROGRAMS IN ALPHABETICAL ORDER');

  WrLn2T(F2, Bracket1 + '*');

  SortSIT(CleanArray, NumSub, 1, 255);

  for alpha := 1 to NumSub do

    WrLn2T(F2, Bracket1 + '* ' + TypeStrArray[alpha] + ' '

      + CleanArray[alpha]);

  WrLn2T(F2, Bracket1 + MultiChar('*',75) + Bracket2);

  Close(F1);

  close(F2);

end.