home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 05 / pascal / strukto1.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-30  |  14.9 KB  |  440 lines
  1. (*----------------------------------------------------------------------*)
  2. (*                       STRUKTO1.PAS                                   *)
  3. (*    Datei- u. Fehlerbehandlung, Menues, Ein-/Ausgabe, Initialisierung *)
  4.  
  5. procedure Menue;
  6. begin
  7.   gotoxy (23,2);    write ('***********************************');
  8.   gotoxy (23,3);    write ('*                                 *');
  9.   gotoxy (23,4);    write ('*          Strukto Plus           *');
  10.   gotoxy (23,5);    write ('*  (C) Thomas Kriegel & TOOLBOX   *');
  11.   gotoxy (23,6);    write ('*                                 *');
  12.   gotoxy (23,7);    write ('***********************************');
  13.   gotoxy (28,9);    write ('Struktur-Datei    :     ', Struktur_Name);
  14.   gotoxy (28,11);   write ('<D>rucke Struktogramm');
  15.   gotoxy (28,12);   write ('<S>ource-Datei bearbeiten');
  16.   gotoxy (28,13);   write ('<G>eneriere Prorammorganisationsplan');
  17.   gotoxy (28,14);   write ('<L>ade Struktogramm');
  18.   gotoxy (28,15);   write ('<P>arameter - Menue');
  19.   gotoxy (28,16);   write ('<C>atalog');
  20.   gotoxy (28,17);   write ('<Q>uit');
  21.   gotoxy (29,19);   write ('Wahl :');
  22. end;    (* Menue *)
  23.  
  24. procedure Meldung_Ausgeben (Bemerkung : Text14; Fehler_Nr : integer);
  25. var k     : char;
  26. begin
  27.   gotoxy (5, 24);
  28.   clreol;
  29.   case Fehler_Nr of
  30.    101 : writeln (Fehlerdatei, Bemerkung:4,
  31.                                   '  Schluesselbegriff ist nicht bekannt');
  32.    102 : writeln (Fehlerdatei, Bemerkung:4,
  33.                                        '  ''#'' ist hier nicht zulaessig');
  34.    103 : writeln (Fehlerdatei, Bemerkung:4, '  SchleifenEnde fehlt');
  35.    104 : writeln (Fehlerdatei, Bemerkung:4, '  Zuviele SchleifenEnden');
  36.    105 : writeln (Fehlerdatei, Bemerkung:4,
  37.                             '  Symbol hier nicht erlaubt oder fehlerhaft');
  38.    106 : writeln (Fehlerdatei, Bemerkung:4,
  39.                                      '  Text ist laenger als Ausgabefeld');
  40.    107 : writeln (Fehlerdatei, Bemerkung:4, '  Texteintrag erwartet');
  41.    108 : writeln (Fehlerdatei, Bemerkung:4, '  Symbolrand ist zu breit');
  42.    205 : write ('Zum Weiterarbeiten ...');
  43.    206 : write ('Bitte Drucker ONLINE schalten');
  44.    207 : write ('Keine Daten zu speichern');
  45.    208 : write ('Dateiname ist nicht erlaubt');
  46.    209 : write ('Eingabe ist nicht erlaubt');
  47.    210 : write ('Textfile ist zu lang');
  48.    211 : write ('Datei ', Bemerkung, ' wurde erzeugt');
  49.    212 : write ('Erzeugtes Struktogramm ist fehlerhaft');
  50.    else   write ('Fehler Nr. ', Fehler_Nr, ' ist aufgetreten');
  51.   end;
  52.   if Fehler_Nr in [101..200]
  53.     then Fehler := true
  54.     else begin
  55.            write ('    <ESC> druecken !');
  56.            repeat
  57.              read (kbd, k);
  58.            until k = ESC;
  59.            gotoxy (5, 24);
  60.            clreol;
  61.          end;
  62. end;    (* Meldung_ausgeben *)
  63.  
  64. procedure Fehler_Meldung (Zeile, Nr : integer);
  65. var Dummy : string [6];
  66. begin
  67.   str (Zeile, Dummy);
  68.   Meldung_ausgeben (Dummy, Nr);
  69. end;    (* Fehler_Meldung *)
  70.  
  71. procedure Datei_Status (Name : Text14);
  72. var Resultat : integer;
  73. begin
  74.   Resultat := ioresult;
  75.   if Resultat = 0
  76.     then Datei_ok := true
  77.     else begin
  78.            if length (Name) > 1
  79.              then  Meldung_ausgeben (Name, Resultat);
  80.            Datei_ok := false;
  81.          end;
  82. end;    (* Datei_Status *)
  83.  
  84. function Schluessel_Wort (Wort : Text13) : char;
  85. begin
  86.   if Wort = 'ANWEISUNG'
  87.   then Schluessel_Wort := 'A'
  88.   else if Wort = 'UNTERPROGRAMM'
  89.        then Schluessel_Wort := 'U'
  90.        else if Wort = 'IF'
  91.             then Schluessel_Wort := 'I'
  92.             else if Wort = 'THEN'
  93.                  then Schluessel_Wort := 'T'
  94.                  else if Wort = 'ELSE'
  95.                       then Schluessel_Wort := 'E'
  96.                       else if Wort = 'CASE'
  97.                            then Schluessel_Wort := 'C'
  98.                            else if Wort = 'OF'
  99.                                 then Schluessel_Wort := 'O'
  100.                                 else if Wort = 'WHILE'
  101.                                      then Schluessel_Wort := 'W'
  102.                                      else if Wort = 'REPEAT'
  103.                                           then Schluessel_Wort := 'R'
  104.                                           else if Wort = 'PROGRAMM'
  105.                                                then Schluessel_Wort := 'P'
  106.                                                else Schluessel_Wort := ' ';
  107. end;    (* Schluessel_Wort *)
  108.  
  109. function Uppercase (Normal : Text13) : Text13;
  110. var i : integer;
  111. begin
  112.   for i := 1 to length (Normal) do
  113.     Normal [i] := upcase (Normal [i]);
  114.   Uppercase := Normal;
  115. end;   (* Uppercase *)
  116.  
  117. procedure Datei_Name (var Name : Text14; Extension : boolean;
  118.                                          Meldung : Text14; YPos : integer);
  119. var i, Abstand : integer;
  120. begin
  121.   Abstand := 43 + length (Meldung);
  122.   gotoxy (40, YPos);
  123.   write (Meldung, ' :');
  124.   gotoxy (Abstand, YPos);
  125.   clreol;
  126.   readln (Name);
  127.   while (pos ('.', Name) > 0) and not (Extension) do
  128.   begin
  129.     Meldung_ausgeben (' ', 208);
  130.     buflen := 10;
  131.     gotoxy (Abstand, YPos);
  132.     clreol;
  133.     readln (Name);
  134.   end;
  135.   gotoxy (40, YPos);
  136.   clreol;
  137.   if Extension and (pos ('.', Name) = 0)
  138.     then Name := Name + '.';
  139.   for i := 1 to length (Name) do
  140.     Name [i] := upcase (Name [i]);
  141. end;    (* Datei_Name *)
  142.  
  143. procedure Lesen (var Zeile_Akt : integer; Neu_Anlegen : boolean);
  144. var Laenge, p : integer;
  145.     Einlesen  : Text110;
  146.     Zeichen   : Text20;
  147.     Dummy     : string [6];
  148.     Zwischen  : Satzpointer;
  149. begin
  150.   if Neu_Anlegen
  151.     then Release (Basis_Struktur);
  152.   Struktur  := Anfangs_Pointer;
  153.   Zwischen  := nil;
  154.   Zeile_Akt := 1;
  155.   while not (eof (STG_Datei)) and (Zeile_Akt <> Max_Zeile) do
  156.   begin
  157.     readln (STG_Datei, Einlesen);
  158.     p        := 1;
  159.     while Einlesen [p] = ' ' do
  160.       p := succ (p);
  161.     Einlesen := copy (Einlesen, p, 255) + ' ';
  162.     Laenge   := pos (' ', Einlesen) - 1;
  163.     if Laenge >= 1
  164.       then begin
  165.              Zeichen  := copy (Einlesen, 1, Laenge);
  166.              with Struktur^ do
  167.              begin
  168.                if Einlesen [1] = '#'
  169.                  then if Laenge > 2
  170.                         then begin
  171.                               Zeichen := uppercase (copy (Zeichen,2,255));
  172.                               Symbol  := '#' + Schluessel_Wort (Zeichen);
  173.                              end
  174.                         else Symbol := '#' + upcase (Zeichen [2])
  175.                   else if Einlesen [1] = '+'
  176.                          then if Laenge > 2
  177.                                 then begin
  178.                                        Zeichen := uppercase (copy (Zeichen,
  179.                                                            2, 255));
  180.                                        Symbol  := '+' + Schluessel_Wort
  181.                                                                   (Zeichen);
  182.                                      end
  183.                                 else Symbol := '+' + upcase (Zeichen [2])
  184.                          else if Laenge > 1
  185.                                 then begin
  186.                                        Zeichen := uppercase (Zeichen);
  187.                                        Symbol  := Schluessel_Wort (Zeichen);
  188.                                      end
  189.                                 else Symbol := upcase (Zeichen);
  190.                Bezeichnung := copy (Einlesen, Laenge + 2, 255);
  191.                p           := 1;
  192.                while Bezeichnung [p] = ' ' do
  193.                  p := succ (p);
  194.                Bezeichnung := copy (Bezeichnung, p, 255);
  195.                Zwischen    := Struktur;
  196.                if Neu_Anlegen
  197.                  then begin
  198.                         new (Struktur);
  199.                         Zwischen^.Next := Struktur;
  200.                       end
  201.                  else Struktur := Struktur^.Next;
  202.                Zeile_Akt      := succ (Zeile_Akt);
  203.              end;
  204.            end;
  205.   end;
  206.   Ende_Pointer       := Zwischen;
  207.   Hilfs_Ptr          := Ende_Pointer^.Next;
  208.   Ende_Pointer^.Next := nil;
  209.   Zeile_Akt          := Max_Zeile + Zeile - 1;
  210. end;    (* Lesen *)
  211.  
  212. procedure Datei_Lesen;
  213. begin
  214.   Zeile   := 1;
  215.   repeat
  216.     Datei_Name (Struktur_Name, false, 'STG-Datei', 19);
  217.     assign (STG_Datei, Struktur_Name + '.STG');
  218.     {$I-} reset (STG_Datei);  {$I+}
  219.     Datei_Status (Struktur_Name);
  220.   until Datei_ok or (length (Struktur_Name) < 2);
  221.   if length (Struktur_Name) > 1
  222.     then begin
  223.            gotoxy (52, 9);
  224.            write (Struktur_Name);
  225.            clreol;
  226.            Lesen (Zeile_Akt, true);
  227.            Zu_Lang := not (eof (STG_Datei));
  228.          end;
  229. end;    (* Datei_Lesen *)
  230.  
  231. procedure Drucker_Steuerung (Art : Init_Art);
  232. begin                 (* diese Prozedur wird nur für Apple IIe im vollen
  233.                          Funktionsumfang benoetigt. Hier ist dieser
  234.                          Teil geloescht *)
  235.   if (Druck_Ziel = Screen) or (Druck_Ziel = ohne)
  236.     then clrscr;
  237. end;    (* Drucker_Steuerung *)
  238.  
  239. procedure Init_Phase;
  240. var  Name   :  Text14;
  241. begin
  242.   Akt_Laenge  := Breite;
  243.   Fehler      := false;
  244.   TEO_Status  := passiv;
  245.   TEO_Erste   := false;
  246.   While_offen := false;
  247.   Textrand    := '';
  248.   Strichrand  := copy (Strich, 1, Akt_Laenge + 2);
  249.   Rest        := '';
  250.   mark (Basis_Schleife);
  251.   if STG_schreiben
  252.     then Name := Struktur_Name + '.ERR'
  253.     else Name := copy (Source_Name, 1, pos ('.', Source_Name) - 1) + '.ERR';
  254.   assign (Fehlerdatei, Name);
  255.   {$I-}  rewrite (Fehlerdatei);  {$I+}
  256.   Datei_Status (Name);
  257.   case Druck_Ziel of
  258.        Drucker  :  Dest_Name := 'LST:';
  259.        Screen   :  Dest_Name := 'CON:';
  260.   end;
  261.   assign (Destination, Dest_Name);
  262.   {$I-} rewrite (Destination);   {$I+}
  263.   Datei_Status (Dest_Name);
  264.   if Datei_ok
  265.     then begin
  266.            Drucker_Steuerung (Voreinstellung);
  267.            Struktur       := Anfangs_Pointer;
  268.            new (Schleife);
  269.            Schleife^.Last := nil;
  270.          end;
  271. end;    (* Init_Phase *)
  272.  
  273. procedure Strich_bauen;
  274. var  i : integer;
  275. begin
  276.   Strich      := Waagerecht;
  277.   for i := 1 to 7 do
  278.     Strich := Strich + Strich;
  279.   Strich_Blank := Senkrecht + ' ';
  280. end;    (* Strich_Bauen *)
  281.  
  282. procedure Init_Graphik;
  283. begin
  284.   Kreuz       := chr (197);  Kreuzunten  := chr (193);
  285.   Kreuzoben   := chr (194);  Kreuzrechts := chr (180);
  286.   Kreuzlinks  := chr (195);  Waagerecht  := chr (196);
  287.   Senkrecht   := chr (179);  Obenlinks   := chr (218);
  288.   Obenrechts  := chr (191);  Untenlinks  := chr (192);
  289.   Untenrechts := chr (217);
  290.   Strich_Bauen;
  291. end;    (* Init_Graphik *)
  292.  
  293. procedure Init_Text;
  294. begin
  295.   Kreuz       := '+';       Kreuzunten   := '+';
  296.   Kreuzoben   := '+';       Kreuzrechts := '+';
  297.   Kreuzlinks  := '+';       Waagerecht  := '-';
  298.   Senkrecht   := 'I';       Obenlinks   := '+';
  299.   Obenrechts  := '+';       Untenlinks  := '+';
  300.   Untenrechts := '+';
  301.   Strich_Bauen;
  302. end;    (* Init_Text *)
  303.  
  304. procedure Nachlauf;
  305. begin
  306.   {$I-}  close (STG_Datei);  {$I+}
  307.   Datei_Status (Dest_Name);
  308.   case Druck_Ziel of
  309.        Datei  :  Meldung_ausgeben (Dest_Name, 211);
  310.        Screen :  Meldung_ausgeben (' ', 205);
  311.   end;
  312.   if Schleife^.Last <> nil
  313.     then Fehler_Meldung (Zeile, 103);
  314.   close (Fehlerdatei);
  315.   Drucker_Steuerung (Normal);
  316.   close (Destination);
  317.   if not (Fehler)
  318.     then erase (Fehlerdatei)
  319.     else Meldung_ausgeben (' ', 212);
  320.   release (Basis_Schleife);
  321.   new (Schleife);
  322.   Schleife^.Last := nil;
  323.   LabelStart     := nil;
  324.   Menue;
  325. end;    (* Nachlauf *)
  326.  
  327. procedure Parameter_Aendern;
  328. var  Befehl : char;
  329.      Ende   : boolean;
  330.  
  331.   function Wert (Klein, Gross : integer; Ausgabe : Text30) : integer;
  332.   var Eingabe          : Text3;
  333.       Zahl, Dummy, Ort : integer;
  334.       Ende             : boolean;
  335.   begin
  336.     Ort := 32 + length (Ausgabe);
  337.     gotoxy (29, 17);
  338.     write (Ausgabe, ' :');
  339.     repeat
  340.       gotoxy (Ort, 17);
  341.       clreol;
  342.       buflen  := 3;
  343.       readln (Eingabe);
  344.       val (Eingabe, Zahl, Dummy);
  345.       Ende := (Dummy = 0) and (Eingabe <> '') and
  346.                                 (Zahl >= Klein) and (Zahl <= Gross);
  347.       if not (Ende)
  348.         then  Meldung_ausgeben (' ', 209);
  349.     until Ende;
  350.     Wert := Zahl;
  351.   end;    (* Wert *)
  352.  
  353.   procedure Anzeige;
  354.   const X_Pos = 45;
  355.   begin
  356.     gotoxy (X_Pos, 7);
  357.     write (Links : 6);
  358.     gotoxy (X_Pos, 8);
  359.     write (Breite : 6);
  360.     gotoxy (X_Pos, 9);
  361.     write (Feldlaenge : 6);
  362.     gotoxy (X_Pos, 10);
  363.     write (Max_Zeile : 6);
  364.     gotoxy (X_Pos - 1, 11);
  365.     case Druck_Ziel of
  366.          Screen  : write (' Schirm');
  367.          Drucker : write ('Drucker');
  368.          Datei   : write (Dest_Name);
  369.          ohne    : write ('keine Ausgabe');
  370.     end;
  371.     clreol;
  372.     gotoxy (X_Pos + 2, 12);
  373.     if STG_schreiben
  374.       then write ('  Ja')
  375.       else write ('Nein');
  376.     gotoxy (X_Pos - 1, 13);
  377.     if Zeichensatz = Graphik
  378.       then write ('Graphik')
  379.       else write ('   Text');
  380.     gotoxy (25, 17);
  381.     clreol;
  382.   end;    (* Anzeige *)
  383.  
  384. begin    (* Parameter_Aendern *)
  385.   clrscr;
  386.   gotoxy (12,5);   write ('Parameter - Menue');
  387.   gotoxy (17,7);   write ('<L>inker Rand            :');
  388.   gotoxy (17,8);   write ('<Z>eilenlaenge           :');
  389.   gotoxy (17,9);   write ('<F>eldlaenge bei POP     :');
  390.   gotoxy (17,10);  write ('<M>aximale Zeilenzahl    :');
  391.   gotoxy (17,11);  write ('<S, P, D, O>  Druckziel  :');
  392.   gotoxy (17,12);  write ('<E>rstelle STG-Datei     :');
  393.   gotoxy (17,13);  write ('<G, T>   Zeichensatz     :');
  394.   gotoxy (17,14);  write ('<Q>uit');
  395.   gotoxy (17,17);  write ('Wahl :');
  396.   Ende := false;
  397.   repeat
  398.     Anzeige;
  399.     repeat
  400.       read (kbd, Befehl);
  401.       Befehl := upcase (Befehl);
  402.     until Befehl in ['L','Z','F','M','S','D','P','O','E','G','T','Q'];
  403.     case Befehl of
  404.          'L'  : Links      := Wert (1, 50, 'Linker Rand');
  405.          'Z'  : Breite     := Wert (11, 92, 'Zeilenlaenge');
  406.          'F'  : Feldlaenge := Wert (2, 25, 'Feldlaenge');
  407.          'M'  : Max_Zeile  := Wert (1, 600, 'max. Zeilen im Speicher');
  408.          'S'  : Druck_Ziel := Screen;
  409.          'D'  : begin
  410.                   Datei_Name (Dest_Name, false, 'PRN-Datei',17);
  411.                   if Dest_Name <> ''
  412.                     then begin
  413.                            Dest_Name := Dest_Name + '.PRN';
  414.                            Druck_Ziel := Datei;
  415.                          end;
  416.                 end;
  417.          'P'  : Druck_Ziel := Drucker;
  418.          'O'  : Druck_Ziel := ohne;
  419.          'E'  : begin
  420.                    STG_schreiben := not (STG_schreiben);
  421.                    if not (STG_Schreiben)
  422.                      then  Struktur_Name := '';
  423.                 end;
  424.          'G'  : begin
  425.                   Zeichensatz := Graphik;
  426.                   Init_Graphik;
  427.                 end;
  428.          'T'  : begin
  429.                   Zeichensatz := Textzeichen;
  430.                   Init_Text;
  431.                 end;
  432.          'Q'  : Ende       := true;
  433.     end;
  434.   until Ende;
  435.   clrscr;
  436.   Menue;
  437. end;    (* Parameter_Aendern *)
  438. (*----------------------------------------------------------------------*)
  439. (*                    Ende von STRUKTO1.PAS                             *)
  440.