Turbo Toolbox/Turbo_Toolbox.iso/1987/01/scrlist.pas

Pascal/Delphi Source File | 1986-11-25 | 14.7 KB | 423 lines

(******************************************************************************)
(*              Source Code Reference Lister  Vers. 1.00                      *)
(******************************************************************************)

program SCR_Lister (input,output);

(*$A-*)         (* Erlaubt bei Turbo-Pascal die Erzeugung von rekursivem Code *)

const zeilenlg   = 80;                                  (* Laenge einer Zeile *)
      wortlg     = 15;                            (* max. Laenge eines Wortes *)
      zeilenan   = 67;                          (* Anzahl der Zeilen je Seite *)
      namenlg    = 15;                              (* Laenge des Dateinamens *)
      zeilennrlg = 6;                              (* Laenge der Zeilennummer *)
      Console    = 'con:';                     (* Geraetename fuer Bildschirm *)
      Printer    = 'lst:';                        (* Geraetename fuer Drucker *)
      uebersch   = 'Source Code Reference Lister  Vers. 1.00';

type  wortzeiger   = ^wortli;
      zeilenzeiger = ^zeilenli;

      (* Liste mit den Zeilennummern eines Wortes: *)
      zeilenli     = record
                       lzeile   : integer;
                       lzeilezg : zeilenzeiger;
                     end;

      (* Liste mit den Woertern der Quell-Datei: *)
      wortli       = record
                       lwortel   : string[wortlg];
                       lwortzg   : wortzeiger;
                       lzbasiszg : zeilenzeiger;
                     end;

      namenstring  = string [namenlg];

var   hwort       : string[wortlg];
      zeile       : string[zeilenlg];
      quellname,
      zielname    : namenstring;
      quelle,
      ziel        : text;
      zeilennr,
      seitennr,
      hilfsz      : integer;
      lwort       : wortli;
      lbasis      : wortzeiger;
      quelldruck,
      zkflg,
      komflg,
      lesen       : boolean;
      zeichen,
      alteszeichen: char;
(*----------------------------------------------------------------------------*)
(*                  Code an Drucker anpassen !!!                              *)

procedure neue_seite;

begin
  writeln(ziel, chr(12));
end;

(*----------------------------------------------------------------------------*)
(*     Ordnet den Woertern die Zeilennummern zu, in denen sie vorkommen       *)

procedure zeilenverkettung (var hzeiger : zeilenzeiger);

begin
  if hzeiger <> nil then                    (* sucht die letzte Zeilennummer, *)
    zeilenverkettung(hzeiger^.lzeilezg)           (* in denen das Wort vorkam *)
  else
  begin
    new(hzeiger);                                   (* fuegt die Zeilennummer *)
    hzeiger^.lzeile   := zeilennr;                         (* an die Liste an *)
    hzeiger^.lzeilezg := nil;
  end
end;

(*----------------------------------------------------------------------------*)
(*                  Fuegt ein neues Wort in die Liste ein                     *)

procedure wortverkettung (var hzeiger : wortzeiger);

var lozeiger : wortzeiger;

begin
  if hzeiger = nil then                  (* neues Wort in Wortliste aufnehmen *)
    begin
      new(hzeiger);
      hzeiger^.lwortel   := hwort;
      hzeiger^.lwortzg   := nil;
      hzeiger^.lzbasiszg := nil;
      zeilenverkettung(hzeiger^.lzbasiszg);    (* und Zuordnung der Zeilennr. *)
    end
  else
    if hwort < hzeiger^.lwortel then         (* Das zu analysierende Wort ist *)
      begin                                 (* kleiner als das Vergleichswort *)
        new(lozeiger);                         (* aus der Liste, deshalb muss *)
        lozeiger^          := hzeiger^;     (* es vor dem Vergleichswort ein- *)
        hzeiger^.lwortel   := hwort;                       (* gefuegt wertden *)
        hzeiger^.lzbasiszg := nil;
        hzeiger^.lwortzg   := lozeiger;
        zeilenverkettung(hzeiger^.lzbasiszg);   (* Zuordnung der Zeilennummer *)
      end                                         (* zu dem analysierten Wort *)
    else
      if hwort = hzeiger^.lwortel then       (* zu analys. Wort = Vergleichs- *)
        zeilenverkettung(hzeiger^.lzbasiszg)     (* wort, deshalb nur Zeilen- *)
      else                                                (* nummer speichern *)
        wortverkettung(hzeiger^.lwortzg);  (* rekursiver Aufruf mit dem Nach- *)
end;                               (* folger des behandelten Vergleichswortes *)

(*----------------------------------------------------------------------------*)
(*                          Analysiert den Quelltext                          *)

procedure analyse;

  (*--------------------------------------------------------------------------*)
  (*      Kommentare und Zeichenketten nicht analysieren lassen !             *)

  procedure ueberlesen;

  const gka = '{';        gkz = '}';        ka  = '(';
        kz  = ')';        ast = '*';        apo = '''';

  begin
    if lesen then
      begin
        if (zeichen = gka) and not(zkflg) then
          begin
            lesen := false; komflg := true;
          end
        else if zeichen = ast then
          begin
            if (alteszeichen = ka) and not(zkflg) then
              begin
                lesen := false; komflg := true;
              end;
          end
        else if (zeichen = apo) and not(komflg) then
          begin
            lesen := false; zkflg := true;
          end;
      end
    else
      begin
        if (zeichen = gkz) and not(zkflg) then
          begin
            lesen := true; komflg := false;
          end
        else if zeichen = kz then
          begin
            if (alteszeichen = ast) and not(zkflg) then
              begin
                lesen := true; komflg := false;
              end;
          end
        else if (zeichen = apo) and not(komflg) then
        begin
          lesen := true; zkflg := false;
        end;
      end;
  end; (* ueberlesen *)

begin
  hwort := '';
  while not eoln(quelle) do                (* Liest eine Zeile der Quelldatei *)
  begin                                           (* Zeichen fuer Zeichen ein *)
    read (quelle,zeichen);
    zeile := zeile + zeichen;
    ueberlesen;
    if lesen then
    begin
      if zeichen in ['A'..'Z','a'..'z','^'] then    (* Zeichen, mit denen ein *)
        hwort := hwort + zeichen                        (* Wort beginnen darf *)
      else
        if zeichen in ['0'..'9','^','_','.'] then      (* Zeichen, die ab der *)
          begin                                  (* zweiten Position in einem *)
            if not (hwort = '') then                (* Wort vorkommen duerfen *)
              hwort := hwort + zeichen;
          end
        else                         (* Alle anderen Zeichen dienen als Wort- *)
          if not (hwort = '') then     (* begrenzer; wurde ein Wort gefunden, *)
          begin                       (* wird es in die Liste mit aufgenommen *)
            wortverkettung(lbasis);
            hwort := '';
          end;
    end;
    alteszeichen := zeichen;
  end;
  if not (hwort = '') then                      (* Damit auch das letzte Wort *)
    wortverkettung(lbasis);                     (* der Zeile ausgewertet wird *)
end;

(*---------------------------------------------------------------------------*)
(*               Druckt eine Ueberschrift auf jede Seite                     *)

procedure kopfdruck;

begin
  seitennr := succ(seitennr);
  write (ziel,uebersch,'   Quell-Datei: ',quellname);
  if zielname = Printer then
    writeln (ziel,'   Seite: ',seitennr)
  else
    writeln (ziel);
  writeln (ziel);
end;

(*----------------------------------------------------------------------------*)
(*     Druckt die Zeilennummern zu den Woertern, in denen sie vorkommen       *)

procedure azeilendruck (var hzeiger : zeilenzeiger);

var zaehler : integer;

begin
  if hzeiger <> nil then
    begin
      hilfsz := succ(hilfsz);   (* Zaehlt Anzahl der Zeilennummern des Wortes *)
      if hilfsz * zeilennrlg + wortlg > zeilenlg then
      begin                                      (* eine Druckzeile ist voll! *)
        zeilennr := succ(zeilennr);
        writeln (ziel);
        write (ziel,' ':wortlg);
        hilfsz := 1;
      end;
      if zeilennr > seitennr * zeilenan then
        if zielname = Printer then                (* eine Druckseite ist voll *)
        begin
          hilfsz   := 1;
          zeilennr := succ (zeilennr);
          neue_seite;
          kopfdruck;
          write (ziel,hwort);
          write (ziel,' ':wortlg -length (hwort));
        end;
      zaehler := hzeiger^.lzeile;
      write (ziel,zaehler:zeilennrlg);           (* Schreibt die Zeilennummer *)
      azeilendruck (hzeiger^.lzeilezg);   (* Rekursiver Aufruf mit der naech- *)
    end                                 (* sten Zeile, in der das Wort vorkam *)
  else
    writeln(ziel);
end;

(*----------------------------------------------------------------------------*)
(*        Druckt die vorkommenden Worte in alfabetischer Reihenfolge          *)

procedure awortdruck (var hzeiger : wortzeiger);

var zaehler : integer;

begin
  if hzeiger <> nil then
  begin
    hilfsz := 0;
    zeilennr := succ(zeilennr);
    if zeilennr > seitennr * zeilenan then                      (* neue Seite *)
      if zielname = Printer then
        if seitennr > 1 then
          begin
            neue_seite;
            kopfdruck;
          end
        else
          kopfdruck;
    hwort := hzeiger^.lwortel;
    write (ziel,hwort);                                  (* Schreibt ein Wort *)
    if length (hwort) < wortlg then
      write (ziel,' ':wortlg - length(hwort));
    azeilendruck (hzeiger^.lzbasiszg);    (* Schreibt  Zeilennummern zum Wort *)
    awortdruck (hzeiger^.lwortzg);         (* Rekursiver Aufruf mit dem Nach- *)
  end;                                     (* folger des geschriebenen Wortes *)
end;

(*----------------------------------------------------------------------------*)
(*                Prueft, ob die angegebene Datei existiert                   *)

function dateivorhanden (var datei : text; dateiname : namenstring): boolean;

begin
  assign (datei,dateiname);
  {$I-}
    reset (datei);
  {$I+}
  if IOresult = 0 then
    dateivorhanden := true
  else
    dateivorhanden := false;
end;

(*----------------------------------------------------------------------------*)
(*               Liest den Namen der Ziel-Datei ein                           *)

procedure zieldiskdat;

var antwort : char;

begin
  antwort := 'N';
  repeat
    write ('Name der Ziel-Datei: ');
    readln (zielname);
    assign (ziel,zielname);
    if not dateivorhanden (ziel,zielname) then
      begin
        rewrite (ziel);                          (* Neue Datei wird eroeffnet *)
        antwort := 'J';
      end
    else
    begin
      writeln ('Datei mit diesem Namen ist schon vorhanden!');
      write ('Soll sie ueberschrieben werden? (J/N) ');
      readln (antwort);
      if antwort in ['j','J'] then
        rewrite (ziel);               (* Bestehende Datei wird ueberschrieben *)
    end;
  until antwort in ['J','j'];
end;

(*----------------------------------------------------------------------------*)
(* Waehlt Ein- und Ausgabemedium und teilt dem Hauptprogramm den Erfolg mit   *)

function medienwahl : boolean;

var antwort : char;

begin
  antwort := 'J';
  medienwahl := false;
  repeat
    write ('Name der Quell-Datei: ');
    readln (quellname);
    if dateivorhanden (quelle,quellname) then     (* Existierende Quell-Datei *)
      begin                                              (* wurde ausgewaehlt *)
        medienwahl := true;
        reset(quelle);
        write ('Soll zur Cross-Referenz auch der ');
        write ('Quelltext ausgegeben werden? (J/N) ');
        readln (antwort);
        if antwort in ['J','j'] then               (* Zur Cross-Referenz wird *)
          quelldruck := true                     (* zusaetzlich ein Programm- *)
        else                                           (* listing ausgedruckt *)
          quelldruck := false;
      end
    else                            (* Angegebene Quell-Datei existiert nicht *)
    begin
      writeln ('Datei mit diesem Namen ist nicht vorhanden!');
      write   ('Neuer Versuch? (J/N) ');
      readln (antwort);
    end;
  until dateivorhanden (quelle,quellname) or (antwort in ['N','n']);
  if dateivorhanden (quelle,quellname) then     (* Auswahl des Ausgabemediums *)
  begin
    writeln ('Auf welchem Medium soll die Ausgabe erfolgen?');
    writeln;
    writeln ('         1 : Ausgabe auf Bildschirm');
    writeln ('         2 : Ausgabe auf Drucker');
    writeln ('         3 : Ausgabe in Datei');
    writeln;
    repeat
      write ('Medium: ');
      readln (antwort);
    until antwort in ['1'..'3'];
    case antwort of
      '1' : zielname := Console;
      '2' : zielname := Printer;
      '3' : zieldiskdat;
    end;
    if antwort in ['1','2'] then
      assign (ziel,zielname);
  end;
end;

(*----------------------------------------------------------------------------*)
(*                               Hauptprogramm                                *)

begin
  clrscr;                          (* Loescht bei Turbo-Pascal den Bildschirm *)
  lesen := true;
  komflg := false;
  zkflg := false;
  alteszeichen := ' ';
  zeilennr := 0;
  seitennr := 0;
  lbasis   := nil;
  writeln (uebersch); writeln;
  if  medienwahl then
  begin
    writeln ('In Arbeit: ');
    if zielname <> Printer then
      kopfdruck;
    while not eof (quelle) do
    begin
      zeile := '';
      zeilennr := succ(zeilennr);
      analyse; readln (quelle);       (* Einlesen einer Zeile des Quelltextes *)
      if quelldruck then                      (* Ausgabe des Programmlistings *)
      begin
        if zeilennr > seitennr * zeilenan then
          if zielname = Printer then                  (* Formularvorschub bei *)
          begin                                        (* Ausgabe auf Drucker *)
            if (zeilennr <> 1) then
              neue_seite;
            kopfdruck;
          end;
        writeln (ziel,zeilennr:zeilennrlg,'  ',zeile);       (* Ausgabe einer *)
      end                                           (* Zeile mit Zeilennummer *)
    end;
    zeilennr := seitennr * zeilenan;
    if zielname <> Printer then
    begin
      kopfdruck;
      writeln (ziel);
    end;
    awortdruck (lbasis);                     (* Druck der Cross-Referenzliste *)
    if zielname = Printer then
      neue_seite
    else
    if zielname <> Console then              (* Schliessen der Diskettendatei *)
      close (ziel);
  end;
  close (quelle);
end.