Program TP_Doc; {***************************************************************************} uses Croft, Crt; const Bracket1 = char(#123); Bracket2 = char(#125); var InFile, OutFile: string; F1, F2: 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; 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; {***************************************************************************} {***************************************************************************} {***************************************************************************} begin NumSub := 0; ; writeln('Max # of sub-programs: ',CroftUnitConstant); GetFileName(InFile, Ext); OutFile := InFile + '.DOC'; InFile := InFile + '.' + Ext; writeln('InFile : ',InFile); writeln('OutFile: ',OutFile); Wait; Assign(F1, InFile); Assign(F2, OutFile); Reset(F1); Rewrite(F2); 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; ; 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 + '*'); ; 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]); 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]); 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; ; 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.