Turbo Toolbox/Turbo_Toolbox.iso/1988/04/decl.pas

Pascal/Delphi Source File | 1988-01-18 | 12.8 KB | 377 lines

(* ----------------------------------------------------- *)
(*                        DECL.PAS                       *)
(* Auflisten der Prozedur- und Funktionsdeklarationen    *)
(* von Pascal-Programmen unter Berücksichtigung der In-  *)
(* einanderschachtelung dieser Strukturen.               *)
(*      (C) 1988  Markus Satte, MC & PASCAL INT.         *)
(* ----------------------------------------------------- *)
{$P1024}                 (* für Turbo Pascal, ermöglicht *)
                         (* die Ausgabe-Umleitung        *)

PROGRAM Decl (Source, Output);

CONST LineWidth = 70;

TYPE  MyString    = STRING[255];
      CharSet     = SET OF CHAR;

VAR   Source                       : TEXT;
      allChars, Delimiters,
      Numbers, Letters             : CharSet;
      FileName,
      word, Line, OutLine, Blanks  : MyString;
      LinePos, LineCount, inProc,
      FuncCount, ProcCount,
      BeginEnd, RecordEnd, TabPos  : INTEGER;
      DeclEnd, ready               : BOOLEAN;
(* ----------------------------------------------------- *)
(* Umwandeln eines Strings in Großbuchstaben unter Ver-  *)
(* wendung der Turbo-Standard-Funktion upcase(), die nur *)
(* für einzelne Zeichen definiert ist. Für nicht Turbo-  *)
(* isten und dem ASCII-Zeichensatz:                      *)
(* FUNCTION UpCase (ch: CHAR): CHAR;                     *)
(* BEGIN                                                 *)
(*   UpCase := ch;                                       *)
(*   IF ch IN ['a'..'z'] THEN UpCase := Chr(Ord(ch)-32); *)
(* END;                                                  *)
PROCEDURE UpString (VAR source, dest : MyString);

VAR i : INTEGER;

BEGIN
  dest := source;
  FOR i := 1 TO Length(dest) DO dest[i] := UpCase(dest[i]);
END;
(* ----------------------------------------------------- *)
(* ermittelt Position des ersten Nicht-Leerzeichens in   *)
(* einer Zeichenkette ab der Start-Position. Wird keines *)
(* mehr gefunden, wird eine größere Pos. als die Länge   *)
(* der Zeichenkette zurückgegeben.                       *)
FUNCTION PosNonBlank (VAR Line: MyString;
                           Pos: INTEGER): INTEGER;
BEGIN
  WHILE (Line[Pos] = ' ') AND (Pos < Length(Line)) DO
    Pos := Succ(Pos);
  IF Line[Pos] = ' ' THEN Pos := Succ(Pos);
  PosNonBlank := Pos;
END;
(* ----------------------------------------------------- *)
(*  Wandelt eine Integer-Zahl in eine Zeichenkette um:   *)
PROCEDURE NumToStr (number: INTEGER; VAR txt: MyString);

VAR  ch : CHAR;

BEGIN
  txt := '';
  REPEAT
    ch := Chr(number MOD 10 + Ord('0'));
    txt := Concat(ch,txt);
    number := number DIV 10;
  UNTIL number = 0;
END;
(* ----------------------------------------------------- *)
(* sucht in der Zeile den Anfang eines Wortes ab der an- *)
(* gegebenen Position. "BeginChar" ist die Menge der     *)
(* Zeichen, mit denen ein Wort anfangen darf:            *)
FUNCTION BeginOfWord (VAR Line: MyString;
                           Pos: INTEGER;
                     BeginChar: CharSet): INTEGER;
BEGIN
  WHILE (Pos <= Length(Line))
  AND (NOT(Line[Pos] IN BeginChar)) DO Pos := Succ(Pos);
  BeginOfWord := Pos;
END;
(* ----------------------------------------------------- *)
(* sucht in der Zeile das Ende eines Wortes ab der ange- *)
(* gebenen Position. "EndChar" ist die Menge der Zei-    *)
(* chen, die ein Wort abschließen dürfen. Bei Compilern, *)
(* die beide UNTIL-Bedingungen testen, muß hier die Be-  *)
(* reichsprüfung kurz ausgeschaltet werden !             *)
FUNCTION EndOfWord (VAR Line: MyString;
                         Pos: INTEGER;
                     EndChar: CharSet): INTEGER;
BEGIN
  REPEAT
    Pos := Succ(Pos);
  UNTIL (Pos > Length(Line)) OR (Line[Pos] IN EndChar);
  EndOfWord := Pos;
END;
(* ----------------------------------------------------- *)
(* eine nicht leere Zeile aus der Quelldatei lesen und   *)
(* Zeilenzähler erhöhen:                                 *)
PROCEDURE NextLine;

BEGIN
  REPEAT
    ReadLn(Source,Line);  LineCount := Succ(LineCount);
  UNTIL Eof(Source) OR (Line <> '');
END;
(* ----------------------------------------------------- *)
(*  überließt Zeichenketten-Konstanten und Kommentare.   *)
(* Ist "Line[LinePos]" ein Leerzeichen, wird der Anfang  *)
(* des nächsten Textes gesucht. Beginnt ein Kommentar    *)
(* oder String, wird dieser überlesen und "Line[LinePos]"*)
(* auf des den Kommentar folgende nicht-Leerzeichen ge-  *)
(* stellt:                                               *)
PROCEDURE StringComment;

  PROCEDURE FindEnd (EndChar: CHAR);          (* klar ?! *)
  BEGIN
    REPEAT
      LinePos := Succ(LinePos);
      IF LinePos <= Length(Line) THEN BEGIN
        IF Line[LinePos] = EndChar THEN BEGIN
          IF EndChar = '*' THEN BEGIN
            IF (LinePos < Length(Line))
            AND (Line[Succ(LinePos)] = ')') THEN BEGIN
              EndChar := ' ';  LinePos := Succ(LinePos);
            END;
          END
          ELSE
            EndChar := ' ';
        END;
      END
      ELSE IF Eof(Source) THEN  EndChar := ' '
      ELSE BEGIN
        NextLine;  LinePos := 0;
      END;
    UNTIL EndChar = ' ';
    LinePos := PosNonBlank(Line,Succ(LinePos));
    StringComment;  (* falls gleich wieder einer folgt ! *)
  END;

BEGIN
  LinePos := PosNonBlank(Line,LinePos);
  WHILE (LinePos > Length(Line)) AND NOT Eof(Source) DO
  BEGIN
    NextLine;  LinePos := PosNonBlank(Line,1);
  END;
  IF LinePos <= Length(Line) THEN
    CASE Line[LinePos] OF
      '''' : FindEnd('''');
       '{' : FindEnd('}');
       '(' : IF LinePos < Length(Line) THEN
               IF Line[Succ(LinePos)] = '*' THEN BEGIN
                 LinePos := Succ(LinePos);  FindEnd('*');
               END;
    END;
END;
(* ----------------------------------------------------- *)
(*                Das nächste Wort liefern.              *)
(* "BegChars" ist die Menge der Zeichen, mit denen das   *)
(* Wort anfangen darf, "EndChars" enthält die Menge, die *)
(* nicht zu einem Wort gehören:                          *)
PROCEDURE GetNextWord (VAR word: MyString;
                           BegChars, EndChars: CharSet);

VAR  Pos : INTEGER;

BEGIN
  word := '';
  WHILE (word = '') AND NOT Eof(Source) DO BEGIN
    StringComment;
    IF LinePos <= Length(Line) THEN
      IF Line[LinePos] IN BegChars THEN BEGIN
        Pos := BeginOfWord(Line,LinePos,BegChars);
        LinePos := EndOfWord(Line,Pos,EndChars);
        word := Copy(Line,Pos,LinePos-Pos);
      END
      ELSE LinePos := Succ(LinePos);
  END;
END;
(* ----------------------------------------------------- *)
(*                     Text-Ausgabe.                     *)
(* Die Ausgabe wird solange zwischengespeichert, bis     *)
(* durch eine neue Ausgabe "LineWidth" überschritten     *)
(* wird oder eine leere Zeichenkette übergeben wird.     *)
(* Nach der Ausgabe wird die nächste Ausgabe ab der      *)
(* Position "TabPos" getätigt. Bei der Überschreitung    *)
(* von "LineWidth" wird der auszugebende Text in die     *)
(* nächste Zeile übernommen:                             *)
PROCEDURE Out (txt: MyString);

BEGIN
  IF txt = '' THEN BEGIN
    WriteLn(OutLine);  OutLine := '';  TabPos := 0;
  END
  ELSE IF Length(txt) + Length(OutLine) > LineWidth THEN
  BEGIN
    WriteLn(OutLine);  OutLine := Copy(Blanks,1,TabPos);
  END;
  OutLine := Concat(OutLine,txt);
END;
(* ----------------------------------------------------- *)
(* Zeilennummer der Prozedur/Funktion ausgeben und ent-  *)
(* sprechend der Schachtelung eine Einrückung erzeugen:  *)
PROCEDURE LineNum (num: INTEGER);

VAR  i : INTEGER;  temp: MyString;

BEGIN
  Out('');
  IF num > 0 THEN BEGIN
    NumToStr(num,temp);
    WHILE Length(temp) < 5 DO temp := Concat('0',temp);
    Out(Concat(temp,': '));
  END
  ELSE Out('       ');
  IF inProc > 1 THEN BEGIN
    FOR i := 2 TO inProc DO Out('.');
    Out(' ');
  END;
END;
(* ----------------------------------------------------- *)
(*         Prozedur/Funktions-Deklaration ausgeben:      *)
PROCEDURE FuncProcOut;

VAR temp : MyString;

  (* --------------------------------------------------- *)
  (* Parameterliste der Deklaration ausgeben. Dabei wer- *)
  (* den zu lange Zeilen umgebrochen und neu formatiert: *)
  PROCEDURE ParamsOut;

  VAR  tempword : MyString;

  BEGIN
    Out(temp);  TabPos := Length(OutLine)+2;  temp := ' (';
    REPEAT
      GetNextWord(word,Letters,Delimiters);
      UpString(word,tempword);
      IF tempword = 'VAR' THEN
        temp := Concat(temp,tempword,' ')
      ELSE BEGIN
        temp := Concat(temp,word);
        GetNextWord(word,[',',';',':','(',')'],allChars);
        temp := Concat(temp,word);
        IF word <> ')' THEN temp := Concat(temp,' ');
        IF word = ';' THEN BEGIN
          Out(temp);  temp := ''
        END;
      END;
    UNTIL word = ')';
    GetNextWord(word,[':',';'],allChars);
  END;

BEGIN
  LineNum(LineCount);  TabPos := 0;
    (* Deklarations-Anfang "PROC/FUNC Name ..." aufbauen *)
  temp := Concat(word,' ');
  GetNextWord(word,Letters,Delimiters);          (* Name *)
  temp := Concat(temp,word);
  GetNextWord(word,['(',':',';'],allChars);
  IF word = '(' THEN ParamsOut;      (* Parameterliste ? *)
  IF word = ':' THEN BEGIN             (* Funktionstyp ? *)
    GetNextWord(word,Letters,Delimiters);
    temp := Concat(temp,': ',word);
    GetNextWord(word,[';'],allChars);
  END;
  IF word = ';' THEN temp := Concat(temp,';');
  Out(temp);
END;
(* ----------------------------------------------------- *)
(*       Test, ob angegebene Datei vorhanden ist:        *)
FUNCTION FileExist (name : MyString) : BOOLEAN;

VAR f : TEXT;

BEGIN
  Assign(f,name);
  {$I-}   (* I/O-Überwachung durch Laufzeitsystem aus... *)
  ReSet(f);
  {$I+}                           (* ... und wieder an ! *)
  FileExist := IOResult = 0;
  Close(f);
END;
(* ----------------------------------------------------- *)
(*         prüfen, ob Parameterzeile ok ist:             *)
FUNCTION ParamOk: BOOLEAN;

BEGIN
  ParamOk := FALSE;
  IF ParamCount = 0 THEN
    WriteLn('*** Fehler: ungültige Parameter angegeben !')
  ELSE BEGIN
    FileName := ParamStr(1);
    IF Pos('.',FileName) = 0 THEN
      FileName := Concat(FileName,'.PAS');
    UpString(FileName,FileName);
    IF NOT FileExist(FileName) THEN
      WriteLn('*** Fehler: Datei "',FileName,
              '" nicht gefunden !')
    ELSE
      ParamOk := TRUE;
  END;
END;
(* ----------------------------------------------------- *)
BEGIN (* Decl *)
  WriteLn;
  WriteLn('DECL v1.0     ',
          '(C) 1988   Markus Satte, M.Ceol & PASCAL INT.');
  WriteLn;
  WriteLn('Auflisten der Prozedur- und Funktionsdeklara',
          'tionen in Pascal-Programmen');
  IF ParamOk THEN BEGIN
    WriteLn('Datei: ',FileName);  WriteLn;
    allchars := [' '..'}'];
    Numbers  := ['0'..'9'];
    Letters  := ['A'..'Z','a'..'z'];
    Delimiters := allchars - Numbers - Letters - ['_'];
    Line := '';  OutLine := '';  Blanks := '';
    FOR LinePos := 1 TO 100 DO Blanks := Concat(Blanks,' ');
    LineCount := 0;      inProc    := 0;
    BeginEnd  := 0;      RecordEnd := 0;
    FuncCount := 0;      ProcCount := 0;
    LinePos   := 1;      ready := FALSE;
    Assign(Source,FileName);
    ReSet(Source);
    WHILE NOT Eof(Source) AND NOT ready DO BEGIN
      GetNextWord(word,Letters,Delimiters);
      UpString(word,word);
      IF word = 'BEGIN' THEN BEGIN
        IF inProc = 0 THEN BEGIN
          ready := TRUE; LineNum(LineCount); Out('MAIN');
        END
        ELSE BeginEnd := Succ(BeginEnd);
      END
      ELSE IF word = 'CASE' THEN BEGIN
        IF RecordEnd = 0 THEN BeginEnd := Succ(BeginEnd);
      END
      ELSE IF word = 'RECORD' THEN
        RecordEnd := Succ(RecordEnd)
      ELSE IF (word = 'EXTERNAL') OR (word = 'FORWARD')
      THEN BEGIN
        LineNum(0);  Out(word);  inProc := Pred(inProc);
      END
      ELSE IF word = 'END' THEN
        IF RecordEnd > 0 THEN
          RecordEnd := Pred(RecordEnd)
        ELSE BEGIN
          BeginEnd := Pred(BeginEnd);
          IF (inProc > 0) AND (BeginEnd = 0) THEN
            inProc := Pred(inProc)
        END
      ELSE IF (word = 'PROCEDURE') OR (word = 'FUNCTION')
      THEN BEGIN
        inProc := Succ(inProc);
        IF word = 'PROCEDURE' THEN
          ProcCount := Succ(ProcCount)
        ELSE
          FuncCount := Succ(FuncCount);
        FuncProcOut;
      END;
    END; (* WHILE *)
    Out('');
    Close(Source);
    WriteLn;
    WriteLn('Gefunden wurden insgesamt: ',
             FuncCount+ProcCount:3,' Unterprogramme,');
    WriteLn('                    davon: ',
             FuncCount:3,' Funktionen');
    WriteLn('                      und: ',
             ProcCount:3,' Prozeduren.');
    WriteLn;
  END;
  WriteLn;
END.