home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / sonderh1 / scrlist.pas < prev    next >
Pascal/Delphi Source File  |  1986-11-25  |  15KB  |  423 lines
  1. (******************************************************************************)
  2. (*              Source Code Reference Lister  Vers. 1.00                      *)
  3. (******************************************************************************)
  4.  
  5. program SCR_Lister (input,output);
  6.  
  7. (*$A-*)         (* Erlaubt bei Turbo-Pascal die Erzeugung von rekursivem Code *)
  8.  
  9. const zeilenlg   = 80;                                  (* Laenge einer Zeile *)
  10.       wortlg     = 15;                            (* max. Laenge eines Wortes *)
  11.       zeilenan   = 67;                          (* Anzahl der Zeilen je Seite *)
  12.       namenlg    = 15;                              (* Laenge des Dateinamens *)
  13.       zeilennrlg = 6;                              (* Laenge der Zeilennummer *)
  14.       Console    = 'con:';                     (* Geraetename fuer Bildschirm *)
  15.       Printer    = 'lst:';                        (* Geraetename fuer Drucker *)
  16.       uebersch   = 'Source Code Reference Lister  Vers. 1.00';
  17.  
  18. type  wortzeiger   = ^wortli;
  19.       zeilenzeiger = ^zeilenli;
  20.  
  21.       (* Liste mit den Zeilennummern eines Wortes: *)
  22.       zeilenli     = record
  23.                        lzeile   : integer;
  24.                        lzeilezg : zeilenzeiger;
  25.                      end;
  26.  
  27.       (* Liste mit den Woertern der Quell-Datei: *)
  28.       wortli       = record
  29.                        lwortel   : string[wortlg];
  30.                        lwortzg   : wortzeiger;
  31.                        lzbasiszg : zeilenzeiger;
  32.                      end;
  33.  
  34.       namenstring  = string [namenlg];
  35.  
  36. var   hwort       : string[wortlg];
  37.       zeile       : string[zeilenlg];
  38.       quellname,
  39.       zielname    : namenstring;
  40.       quelle,
  41.       ziel        : text;
  42.       zeilennr,
  43.       seitennr,
  44.       hilfsz      : integer;
  45.       lwort       : wortli;
  46.       lbasis      : wortzeiger;
  47.       quelldruck,
  48.       zkflg,
  49.       komflg,
  50.       lesen       : boolean;
  51.       zeichen,
  52.       alteszeichen: char;
  53. (*----------------------------------------------------------------------------*)
  54. (*                  Code an Drucker anpassen !!!                              *)
  55.  
  56. procedure neue_seite;
  57.  
  58. begin
  59.   writeln(ziel, chr(12));
  60. end;
  61.  
  62. (*----------------------------------------------------------------------------*)
  63. (*     Ordnet den Woertern die Zeilennummern zu, in denen sie vorkommen       *)
  64.  
  65. procedure zeilenverkettung (var hzeiger : zeilenzeiger);
  66.  
  67. begin
  68.   if hzeiger <> nil then                    (* sucht die letzte Zeilennummer, *)
  69.     zeilenverkettung(hzeiger^.lzeilezg)           (* in denen das Wort vorkam *)
  70.   else
  71.   begin
  72.     new(hzeiger);                                   (* fuegt die Zeilennummer *)
  73.     hzeiger^.lzeile   := zeilennr;                         (* an die Liste an *)
  74.     hzeiger^.lzeilezg := nil;
  75.   end
  76. end;
  77.  
  78. (*----------------------------------------------------------------------------*)
  79. (*                  Fuegt ein neues Wort in die Liste ein                     *)
  80.  
  81. procedure wortverkettung (var hzeiger : wortzeiger);
  82.  
  83. var lozeiger : wortzeiger;
  84.  
  85. begin
  86.   if hzeiger = nil then                  (* neues Wort in Wortliste aufnehmen *)
  87.     begin
  88.       new(hzeiger);
  89.       hzeiger^.lwortel   := hwort;
  90.       hzeiger^.lwortzg   := nil;
  91.       hzeiger^.lzbasiszg := nil;
  92.       zeilenverkettung(hzeiger^.lzbasiszg);    (* und Zuordnung der Zeilennr. *)
  93.     end
  94.   else
  95.     if hwort < hzeiger^.lwortel then         (* Das zu analysierende Wort ist *)
  96.       begin                                 (* kleiner als das Vergleichswort *)
  97.         new(lozeiger);                         (* aus der Liste, deshalb muss *)
  98.         lozeiger^          := hzeiger^;     (* es vor dem Vergleichswort ein- *)
  99.         hzeiger^.lwortel   := hwort;                       (* gefuegt wertden *)
  100.         hzeiger^.lzbasiszg := nil;
  101.         hzeiger^.lwortzg   := lozeiger;
  102.         zeilenverkettung(hzeiger^.lzbasiszg);   (* Zuordnung der Zeilennummer *)
  103.       end                                         (* zu dem analysierten Wort *)
  104.     else
  105.       if hwort = hzeiger^.lwortel then       (* zu analys. Wort = Vergleichs- *)
  106.         zeilenverkettung(hzeiger^.lzbasiszg)     (* wort, deshalb nur Zeilen- *)
  107.       else                                                (* nummer speichern *)
  108.         wortverkettung(hzeiger^.lwortzg);  (* rekursiver Aufruf mit dem Nach- *)
  109. end;                               (* folger des behandelten Vergleichswortes *)
  110.  
  111. (*----------------------------------------------------------------------------*)
  112. (*                          Analysiert den Quelltext                          *)
  113.  
  114. procedure analyse;
  115.  
  116.   (*--------------------------------------------------------------------------*)
  117.   (*      Kommentare und Zeichenketten nicht analysieren lassen !             *)
  118.  
  119.   procedure ueberlesen;
  120.  
  121.   const gka = '{';        gkz = '}';        ka  = '(';
  122.         kz  = ')';        ast = '*';        apo = '''';
  123.  
  124.   begin
  125.     if lesen then
  126.       begin
  127.         if (zeichen = gka) and not(zkflg) then
  128.           begin
  129.             lesen := false; komflg := true;
  130.           end
  131.         else if zeichen = ast then
  132.           begin
  133.             if (alteszeichen = ka) and not(zkflg) then
  134.               begin
  135.                 lesen := false; komflg := true;
  136.               end;
  137.           end
  138.         else if (zeichen = apo) and not(komflg) then
  139.           begin
  140.             lesen := false; zkflg := true;
  141.           end;
  142.       end
  143.     else
  144.       begin
  145.         if (zeichen = gkz) and not(zkflg) then
  146.           begin
  147.             lesen := true; komflg := false;
  148.           end
  149.         else if zeichen = kz then
  150.           begin
  151.             if (alteszeichen = ast) and not(zkflg) then
  152.               begin
  153.                 lesen := true; komflg := false;
  154.               end;
  155.           end
  156.         else if (zeichen = apo) and not(komflg) then
  157.         begin
  158.           lesen := true; zkflg := false;
  159.         end;
  160.       end;
  161.   end; (* ueberlesen *)
  162.  
  163. begin
  164.   hwort := '';
  165.   while not eoln(quelle) do                (* Liest eine Zeile der Quelldatei *)
  166.   begin                                           (* Zeichen fuer Zeichen ein *)
  167.     read (quelle,zeichen);
  168.     zeile := zeile + zeichen;
  169.     ueberlesen;
  170.     if lesen then
  171.     begin
  172.       if zeichen in ['A'..'Z','a'..'z','^'] then    (* Zeichen, mit denen ein *)
  173.         hwort := hwort + zeichen                        (* Wort beginnen darf *)
  174.       else
  175.         if zeichen in ['0'..'9','^','_','.'] then      (* Zeichen, die ab der *)
  176.           begin                                  (* zweiten Position in einem *)
  177.             if not (hwort = '') then                (* Wort vorkommen duerfen *)
  178.               hwort := hwort + zeichen;
  179.           end
  180.         else                         (* Alle anderen Zeichen dienen als Wort- *)
  181.           if not (hwort = '') then     (* begrenzer; wurde ein Wort gefunden, *)
  182.           begin                       (* wird es in die Liste mit aufgenommen *)
  183.             wortverkettung(lbasis);
  184.             hwort := '';
  185.           end;
  186.     end;
  187.     alteszeichen := zeichen;
  188.   end;
  189.   if not (hwort = '') then                      (* Damit auch das letzte Wort *)
  190.     wortverkettung(lbasis);                     (* der Zeile ausgewertet wird *)
  191. end;
  192.  
  193. (*---------------------------------------------------------------------------*)
  194. (*               Druckt eine Ueberschrift auf jede Seite                     *)
  195.  
  196. procedure kopfdruck;
  197.  
  198. begin
  199.   seitennr := succ(seitennr);
  200.   write (ziel,uebersch,'   Quell-Datei: ',quellname);
  201.   if zielname = Printer then
  202.     writeln (ziel,'   Seite: ',seitennr)
  203.   else
  204.     writeln (ziel);
  205.   writeln (ziel);
  206. end;
  207.  
  208. (*----------------------------------------------------------------------------*)
  209. (*     Druckt die Zeilennummern zu den Woertern, in denen sie vorkommen       *)
  210.  
  211. procedure azeilendruck (var hzeiger : zeilenzeiger);
  212.  
  213. var zaehler : integer;
  214.  
  215. begin
  216.   if hzeiger <> nil then
  217.     begin
  218.       hilfsz := succ(hilfsz);   (* Zaehlt Anzahl der Zeilennummern des Wortes *)
  219.       if hilfsz * zeilennrlg + wortlg > zeilenlg then
  220.       begin                                      (* eine Druckzeile ist voll! *)
  221.         zeilennr := succ(zeilennr);
  222.         writeln (ziel);
  223.         write (ziel,' ':wortlg);
  224.         hilfsz := 1;
  225.       end;
  226.       if zeilennr > seitennr * zeilenan then
  227.         if zielname = Printer then                (* eine Druckseite ist voll *)
  228.         begin
  229.           hilfsz   := 1;
  230.           zeilennr := succ (zeilennr);
  231.           neue_seite;
  232.           kopfdruck;
  233.           write (ziel,hwort);
  234.           write (ziel,' ':wortlg -length (hwort));
  235.         end;
  236.       zaehler := hzeiger^.lzeile;
  237.       write (ziel,zaehler:zeilennrlg);           (* Schreibt die Zeilennummer *)
  238.       azeilendruck (hzeiger^.lzeilezg);   (* Rekursiver Aufruf mit der naech- *)
  239.     end                                 (* sten Zeile, in der das Wort vorkam *)
  240.   else
  241.     writeln(ziel);
  242. end;
  243.  
  244. (*----------------------------------------------------------------------------*)
  245. (*        Druckt die vorkommenden Worte in alfabetischer Reihenfolge          *)
  246.  
  247. procedure awortdruck (var hzeiger : wortzeiger);
  248.  
  249. var zaehler : integer;
  250.  
  251. begin
  252.   if hzeiger <> nil then
  253.   begin
  254.     hilfsz := 0;
  255.     zeilennr := succ(zeilennr);
  256.     if zeilennr > seitennr * zeilenan then                      (* neue Seite *)
  257.       if zielname = Printer then
  258.         if seitennr > 1 then
  259.           begin
  260.             neue_seite;
  261.             kopfdruck;
  262.           end
  263.         else
  264.           kopfdruck;
  265.     hwort := hzeiger^.lwortel;
  266.     write (ziel,hwort);                                  (* Schreibt ein Wort *)
  267.     if length (hwort) < wortlg then
  268.       write (ziel,' ':wortlg - length(hwort));
  269.     azeilendruck (hzeiger^.lzbasiszg);    (* Schreibt  Zeilennummern zum Wort *)
  270.     awortdruck (hzeiger^.lwortzg);         (* Rekursiver Aufruf mit dem Nach- *)
  271.   end;                                     (* folger des geschriebenen Wortes *)
  272. end;
  273.  
  274. (*----------------------------------------------------------------------------*)
  275. (*                Prueft, ob die angegebene Datei existiert                   *)
  276.  
  277. function dateivorhanden (var datei : text; dateiname : namenstring): boolean;
  278.  
  279. begin
  280.   assign (datei,dateiname);
  281.   {$I-}
  282.     reset (datei);
  283.   {$I+}
  284.   if IOresult = 0 then
  285.     dateivorhanden := true
  286.   else
  287.     dateivorhanden := false;
  288. end;
  289.  
  290. (*----------------------------------------------------------------------------*)
  291. (*               Liest den Namen der Ziel-Datei ein                           *)
  292.  
  293. procedure zieldiskdat;
  294.  
  295. var antwort : char;
  296.  
  297. begin
  298.   antwort := 'N';
  299.   repeat
  300.     write ('Name der Ziel-Datei: ');
  301.     readln (zielname);
  302.     assign (ziel,zielname);
  303.     if not dateivorhanden (ziel,zielname) then
  304.       begin
  305.         rewrite (ziel);                          (* Neue Datei wird eroeffnet *)
  306.         antwort := 'J';
  307.       end
  308.     else
  309.     begin
  310.       writeln ('Datei mit diesem Namen ist schon vorhanden!');
  311.       write ('Soll sie ueberschrieben werden? (J/N) ');
  312.       readln (antwort);
  313.       if antwort in ['j','J'] then
  314.         rewrite (ziel);               (* Bestehende Datei wird ueberschrieben *)
  315.     end;
  316.   until antwort in ['J','j'];
  317. end;
  318.  
  319. (*----------------------------------------------------------------------------*)
  320. (* Waehlt Ein- und Ausgabemedium und teilt dem Hauptprogramm den Erfolg mit   *)
  321.  
  322. function medienwahl : boolean;
  323.  
  324. var antwort : char;
  325.  
  326. begin
  327.   antwort := 'J';
  328.   medienwahl := false;
  329.   repeat
  330.     write ('Name der Quell-Datei: ');
  331.     readln (quellname);
  332.     if dateivorhanden (quelle,quellname) then     (* Existierende Quell-Datei *)
  333.       begin                                              (* wurde ausgewaehlt *)
  334.         medienwahl := true;
  335.         reset(quelle);
  336.         write ('Soll zur Cross-Referenz auch der ');
  337.         write ('Quelltext ausgegeben werden? (J/N) ');
  338.         readln (antwort);
  339.         if antwort in ['J','j'] then               (* Zur Cross-Referenz wird *)
  340.           quelldruck := true                     (* zusaetzlich ein Programm- *)
  341.         else                                           (* listing ausgedruckt *)
  342.           quelldruck := false;
  343.       end
  344.     else                            (* Angegebene Quell-Datei existiert nicht *)
  345.     begin
  346.       writeln ('Datei mit diesem Namen ist nicht vorhanden!');
  347.       write   ('Neuer Versuch? (J/N) ');
  348.       readln (antwort);
  349.     end;
  350.   until dateivorhanden (quelle,quellname) or (antwort in ['N','n']);
  351.   if dateivorhanden (quelle,quellname) then     (* Auswahl des Ausgabemediums *)
  352.   begin
  353.     writeln ('Auf welchem Medium soll die Ausgabe erfolgen?');
  354.     writeln;
  355.     writeln ('         1 : Ausgabe auf Bildschirm');
  356.     writeln ('         2 : Ausgabe auf Drucker');
  357.     writeln ('         3 : Ausgabe in Datei');
  358.     writeln;
  359.     repeat
  360.       write ('Medium: ');
  361.       readln (antwort);
  362.     until antwort in ['1'..'3'];
  363.     case antwort of
  364.       '1' : zielname := Console;
  365.       '2' : zielname := Printer;
  366.       '3' : zieldiskdat;
  367.     end;
  368.     if antwort in ['1','2'] then
  369.       assign (ziel,zielname);
  370.   end;
  371. end;
  372.  
  373. (*----------------------------------------------------------------------------*)
  374. (*                               Hauptprogramm                                *)
  375.  
  376. begin
  377.   clrscr;                          (* Loescht bei Turbo-Pascal den Bildschirm *)
  378.   lesen := true;
  379.   komflg := false;
  380.   zkflg := false;
  381.   alteszeichen := ' ';
  382.   zeilennr := 0;
  383.   seitennr := 0;
  384.   lbasis   := nil;
  385.   writeln (uebersch); writeln;
  386.   if  medienwahl then
  387.   begin
  388.     writeln ('In Arbeit: ');
  389.     if zielname <> Printer then
  390.       kopfdruck;
  391.     while not eof (quelle) do
  392.     begin
  393.       zeile := '';
  394.       zeilennr := succ(zeilennr);
  395.       analyse; readln (quelle);       (* Einlesen einer Zeile des Quelltextes *)
  396.       if quelldruck then                      (* Ausgabe des Programmlistings *)
  397.       begin
  398.         if zeilennr > seitennr * zeilenan then
  399.           if zielname = Printer then                  (* Formularvorschub bei *)
  400.           begin                                        (* Ausgabe auf Drucker *)
  401.             if (zeilennr <> 1) then
  402.               neue_seite;
  403.             kopfdruck;
  404.           end;
  405.         writeln (ziel,zeilennr:zeilennrlg,'  ',zeile);       (* Ausgabe einer *)
  406.       end                                           (* Zeile mit Zeilennummer *)
  407.     end;
  408.     zeilennr := seitennr * zeilenan;
  409.     if zielname <> Printer then
  410.     begin
  411.       kopfdruck;
  412.       writeln (ziel);
  413.     end;
  414.     awortdruck (lbasis);                     (* Druck der Cross-Referenzliste *)
  415.     if zielname = Printer then
  416.       neue_seite
  417.     else
  418.     if zielname <> Console then              (* Schliessen der Diskettendatei *)
  419.       close (ziel);
  420.   end;
  421.   close (quelle);
  422. end.
  423.