home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 01 / listpasc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-10-30  |  10.5 KB  |  244 lines
  1. (* ----------------------------------------------------------------------- *)
  2. (*                             LISTPASC.PAS                                *)
  3. (*       Hilfsprogramm zum Ausdruck von Pascaltexten fuer ATARI ST         *)
  4. (*       Als Accessorie unter GEM aufrufbar, Compiler Pascal ST +          *)
  5.  
  6. (*$O,D-*)               (* Option nur setzen, wenn Accessorie gewuenscht!! *)
  7. PROGRAM PrintFile;
  8. CONST
  9.   maxWords = 61;                          (* Anzahl der markierbaren Worte *)
  10.   (*$I gemconst.pas *)
  11. TYPE
  12.   Datei    = TEXT;
  13.   PackChar = PACKED ARRAY[1..255] OF CHAR;
  14.   str128   = STRING[128];
  15.   str13    = STRING[13];
  16.   (*$I gemtype.pas *)
  17. VAR
  18.   fname             : path_name;                   (* in gemtype definiert *)
  19.   eindat            : Datei;
  20.   RW                : ARRAY[1..maxWords] OF str13;
  21.   fett, unter, unterfett,
  22.   Epson, Itoh, Atari,                 (* nur noetig, wenn versch. Drucker  *)
  23.   Kommentar,imText  : BOOLEAN;
  24.   menu_id,Appl_Id,i : INTEGER;
  25.   alstr, mein_Menu  : str255;
  26.  
  27. (*$I gemsubs.pas *)
  28. (* ----------------------------------------------------------------------- *)
  29. PROCEDURE WordInit;
  30. BEGIN           (*Turbo kann das mit den typisierten Konstanten besser !!! *)
  31.   RW[ 1]:='AND';       RW[ 2]:='ARRAY';    RW[ 3]:='BEGIN'; RW[ 4]:='CASE';
  32.   RW[ 5]:='CONST';     RW[ 6]:='DIV'  ;    RW[ 7]:='DO';    RW[ 8]:='DOWNTO';
  33.   RW[ 9]:='ELSE';      RW[10]:='END';      RW[11]:='END.';
  34.   RW[12]:='EXTERNAL';  RW[13]:='FILE';     RW[14]:='FOR';   RW[15]:='GOTO';
  35.   RW[16]:='FORWARD';   RW[17]:='FUNCTION'; RW[18]:='IF';    RW[19]:='IN';
  36.   RW[20]:='PROCEDURE'; RW[21]:='LABEL';    RW[22]:='MOD';
  37.   RW[23]:='NIL';       RW[24]:='PROGRAM';
  38.   RW[25]:='RECORD';    RW[26]:='OF';       RW[27]:='OR';    RW[28]:='PACKED';
  39.   RW[29]:='REPEAT';    RW[30]:='SET';      RW[31]:='SHL';   RW[32]:='STRING';
  40.   RW[33]:='SHR';       RW[34]:='THEN';     RW[35]:='TO';    RW[36]:='TYPE';
  41.   RW[37]:='UNTIL';     RW[38]:='VAR';      RW[39]:='WHILE'; RW[40]:='WITH';
  42.   RW[41]:='XOR';       RW[42]:='GEMDOS';   RW[43]:='BIOS';  RW[44]:='XBIOS';
  43.   RW[45]:='EXIT';      RW[46]:='LOOP';     RW[47]:='ALFA';
  44.   RW[48]:='OTHERWISE'; RW[49]:='BYTE';     RW[50]:='BOOLEAN';
  45.   RW[51]:='CHAR';      RW[52]:='INTEGER';  RW[53]:='REAL';
  46.   RW[54]:='TEXT';      RW[55]:='FALSE';    RW[56]:='LONG_INTEGER';
  47.   RW[57]:='TRUE';      RW[58]:='NOT';      RW[59]:='MAXINT';
  48.   RW[60]:='CHR';       RW[61]:='ORD';
  49. END;
  50. (* ----------------------------------------------------------------------- *)
  51. FUNCTION HolFile (VAR FileName : path_name) : BOOLEAN;
  52. VAR Pfad : path_name;
  53. BEGIN
  54.   Pfad := 'A:\*.PAS';
  55.   IF Get_in_File(Pfad,FileName) THEN  HolFile :=TRUE ELSE HolFile := FALSE;
  56. END;
  57. (* ----------------------------------------------------------------------- *)
  58. (*                  wandelt Kleintexte in Grosstexte                       *)
  59. PROCEDURE mach_gross (VAR Wort : str128);
  60. VAR i : INTEGER;
  61. BEGIN
  62.   FOR i := 1 TO Length(Wort) DO
  63.     IF Wort[i] IN ['a'..'z'] THEN Wort[i] := Chr(Ord(Wort[i])-32);
  64. END;
  65. (* ----------------------------------------------------------------------- *)
  66. (*       Uebergebene Zeile wird auf zu markierende Woerter abgesucht       *)
  67. PROCEDURE Zerlegen (Zeile : PackChar; len : INTEGER);
  68. VAR Wort : str128;   ZeilPos : INTEGER;
  69.   (* --------------------------------------------------------------------- *)
  70.   (*                               Stringvergleiche                        *)
  71.   FUNCTION compare (s1 : str128; s2 : str13) : BOOLEAN;
  72.   VAR i : INTEGER;  ist_gleich : BOOLEAN;
  73.   BEGIN
  74.     ist_gleich := FALSE;  i := 1;
  75.     IF Length(s1) = Length(s2) THEN BEGIN
  76.       WHILE (s1[i] = s2[i]) AND (i <= Length(s1)) DO i := Succ(i);
  77.       IF i > Length(s1) THEN ist_gleich := TRUE;
  78.     END;
  79.     compare := ist_gleich;
  80.   END;
  81.   (* --------------------------------------------------------------------- *)
  82.   (*       absuchen und wandeln, falls nicht in Kommentarklammern          *)
  83.   (*       und nicht in Texten innerhalb von Textkonstanten                *)
  84.   FUNCTION Wort_Reserviert (VAR Wort : str128) : BOOLEAN;
  85.   VAR i : INTEGER;  HilfsWort : str128;  gefunden : BOOLEAN;
  86.   BEGIN
  87.     HilfsWort := Wort;  gefunden := FALSE;  i := 1;  mach_gross(HilfsWort);
  88.     IF NOT (Kommentar) AND NOT (imText) THEN
  89.       REPEAT
  90.         IF compare(HilfsWort,RW[i]) THEN gefunden := TRUE;
  91.         i := Succ(i);
  92.       UNTIL (gefunden) OR (i = maxWords +1);
  93.     Wort_Reserviert := gefunden;
  94.   END;
  95.   (* --------------------------------------------------------------------- *)
  96.   (*   Umlautschalterei beim Epson, bei Itoh geht's per Software leider    *)
  97.   (*   nicht, der Atari (IBM) braucht's nicht                              *)
  98.   PROCEDURE chckumlaut (z : CHAR);
  99.   VAR umlstr : STRING[20];  i : INTEGER;
  100.   BEGIN
  101.     IF (imText) OR (Kommentar) THEN BEGIN
  102.       umlstr := 'Ä[Ö\Ü]ä{ö|ü}ß~';
  103.       i:= -1 ;
  104.       REPEAT i := i+2;  UNTIL (i > 13) OR (z = umlstr[i]);
  105.       IF i <= 13 THEN BEGIN
  106.         IF Epson THEN
  107.           Write(Chr(27),'R',Chr(2),umlstr[i+1],Chr(27),'R',Chr(0))
  108.         ELSE IF Itoh THEN Write(umlstr[i+1]);
  109.       END
  110.       ELSE Write(z);
  111.     END
  112.     ELSE Write(z)
  113.   END;
  114.   (* --------------------------------------------------------------------- *)
  115.   (*        hervorgehoben ausdrucken je nach Druckertyp aussuchen          *)
  116.   PROCEDURE hebe_hervor (VAR Wort : str128);
  117.   BEGIN
  118.     mach_gross(Wort);
  119.     IF (Atari OR Epson) THEN BEGIN
  120.       IF fett  THEN  Write(Chr(27),'E',Wort,Chr(27),'F');
  121.       IF unter THEN  Write(Chr(27),'-',Chr(1),Wort,Chr(27),'-',Chr(0));
  122.       IF unterfett THEN BEGIN
  123.         Write(Chr(27),'E',Chr(27),'-',Chr(1),Wort);
  124.         Write(Chr(27),'-',Chr(0),Chr(27),'F');
  125.       END;
  126.     END;
  127.     IF Itoh THEN BEGIN
  128.       IF fett  THEN Write(Chr(27),'!',Wort, Chr(27),'"');
  129.       IF unter THEN Write(Chr(27),'X',Wort, Chr(27),'Y');
  130.       IF unterfett THEN
  131.         Write(Chr(27),'X',Chr(27),'!',Wort,Chr(27),'"',Chr(27),'Y');
  132.     END;
  133.   END;
  134.   (* --------------------------------------------------------------------- *)
  135. BEGIN (* Zerlegen *)
  136.   Wort := Chr(0);  ZeilPos := 1;  Zeile[len] := Chr(13);
  137.   WHILE ZeilPos <= len DO BEGIN     (* Wort muss mit Alfazeichen anfangen: *)
  138.     IF Zeile[ZeilPos] IN ['A'..'Z','a'..'z'] THEN BEGIN
  139.       Wort := Zeile[ZeilPos];  ZeilPos := Succ(ZeilPos);
  140.                           (* der Rest muss Alfa oder der Unterstrich sein: *)
  141.       WHILE (Zeile[ZeilPos] IN ['A'..'Z','a'..'z','_'])
  142.       AND (ZeilPos <= len) DO BEGIN
  143.         Wort := Concat(Wort,Zeile[ZeilPos]);  ZeilPos := Succ(ZeilPos);
  144.       END;
  145.     END
  146.     ELSE BEGIN
  147.       IF Wort <> Chr(0) THEN IF Wort_Reserviert(Wort) THEN hebe_hervor(Wort)
  148.       ELSE Write(Wort);
  149.       Wort := Chr(0);
  150.       IF (Epson) OR (Itoh) THEN chckumlaut(Zeile[ZeilPos])
  151.       ELSE Write(Zeile[ZeilPos]);
  152.       IF NOT(imText) AND ((Zeile[ZeilPos] = '{') OR ((Zeile[ZeilPos] = '(')
  153.       AND (Zeile[ZeilPos+1] = '*'))) THEN
  154.         Kommentar := TRUE;
  155.       IF NOT(imText) AND ((Zeile[ZeilPos] = '}') OR ((Zeile[ZeilPos] = '*')
  156.       AND (Zeile[ZeilPos+1] = ')'))) THEN
  157.         Kommentar := FALSE;
  158.       IF NOT(Kommentar) AND (Zeile[ZeilPos] = Chr(39)) THEN
  159.         imText := NOT(imText);
  160.       ZeilPos := Succ(ZeilPos);
  161.     END;
  162.   END;
  163.   imText := FALSE;
  164. END;
  165. (* ----------------------------------------------------------------------- *)
  166. PROCEDURE printKopf (fn : path_name; Seite : INTEGER);
  167. BEGIN
  168.   WriteLn;  WriteLn(' Ausdruck von ',fn,'Seite: ':20,Seite);  WriteLn;
  169. END;
  170.  
  171. PROCEDURE printFuss;
  172. BEGIN  WriteLn;  WriteLn;  WriteLn;  END;
  173.  
  174. PROCEDURE laden (fname : path_name);
  175. VAR Zeile, Seite, chz : INTEGER;  ch : CHAR;  ArbZeile : PackChar;
  176. BEGIN
  177.   Seite := 1;  ReSet(eindat,fname);  printKopf(fname, Seite);  Zeile := 1;
  178.   WHILE NOT Eof(eindat) DO BEGIN
  179.     IF Zeile MOD 66 = 0 THEN BEGIN
  180.       printFuss;  Seite := Succ(Seite);  printKopf(fname, Seite);
  181.     END;
  182.     WriteLn;  Write(Zeile:4,': ');  Zeile := Succ(Zeile);  chz := 1;
  183.     REPEAT                                    (* eine Arbeitszeile fuellen *)
  184.       Read(eindat,ch);  ArbZeile[chz] := ch;  chz := Succ(chz);
  185.     UNTIL Eoln(eindat);
  186.     Zerlegen(ArbZeile,chz);                       (* und Zeile untersuchen *)
  187.   END;
  188.   WriteLn;
  189. END;
  190. (* ----------------------------------------------------------------------- *)
  191. PROCEDURE druckein;
  192. BEGIN
  193.   ReWrite(Output,'PRN:');  IF Epson THEN Write(Chr(27),'R',Chr(0));
  194. END;
  195.  
  196. PROCEDURE druckaus;
  197. BEGIN  ReWrite(Output,'CON:');  END;
  198. (* ----------------------------------------------------------------------- *)
  199. (*    soll Programm nicht als Accessorie laufen, die Folgeprozedur zum     *)
  200. (*                          Hauptprogramm erklaeren !                      *)
  201. PROCEDURE ausgeben;
  202. VAR i : INTEGER;
  203. BEGIN
  204.   WordInit;
  205.   fett  := TRUE;   unter := FALSE;  unterfett := FALSE;
  206.   Epson := FALSE;  Itoh  := FALSE;  Atari     := FALSE;
  207.   Kommentar := FALSE;  imText := FALSE;                  (* GEM-Dialogbox: *)
  208.   i := do_alert('[2][   Welcher Drucker      ][Itoh  |Atari|Epson]',2);
  209.   CASE i OF
  210.     1: Itoh  := TRUE;     2: Atari := TRUE;     3: Epson := TRUE;
  211.   END;
  212.   i := do_alert('[2][     Hervorhebung        ][Unter|fett |beides]',2);
  213.   CASE i OF
  214.     1: BEGIN  unter := TRUE;  fett := FALSE;  END;
  215.     2: fett := TRUE;
  216.     3: BEGIN  unterfett := TRUE;  fett := FALSE;  END;
  217.   END;
  218.   druckein;
  219.   IF HolFile(fname) THEN laden(fname);
  220.   druckaus;
  221. END;          (* bezw. "END.", wenn kein Accessorie  und Rest weglassen !! *)
  222. (* ----------------------------------------------------------------------- *)
  223. PROCEDURE Event_Loop;
  224. VAR event, du : INTEGER;  msg : Message_Buffer;    (* in gemtype definiert *)
  225. BEGIN
  226.   WHILE TRUE DO BEGIN        (* auf eine Ereignis-Botschaft von GEM warten *)
  227.     event := Get_event(E_Message,0,0,0,0,
  228.                        FALSE,0,0,0,0,FALSE,0,0,0,0,
  229.                        msg, du,du,du,du,du,du);
  230.     IF msg[0] = AC_Open THEN         (* Botschaft = "Accessorie oeffnen" ? *)
  231.        IF msg[4] = menu_id THEN      (* Ja, aber ist PrintFile gemeint ?   *)
  232.          ausgeben;                   (* jawoll, alos los....               *)
  233.   END;
  234. END;
  235. (* ----------------------------------------------------------------------- *)
  236. BEGIN   (*********** Accessorie-Hauptprogramm *************)
  237.   Appl_Id := Init_Gem;                      (* Accessorie bei GEM anmelden *)
  238.   IF Appl_Id >= 0 THEN BEGIN                (* hat Anmeldung geklappt ?    *)
  239.     mein_Menu := '  ListPascal';            (* ja, PrintFile in Desk-Menue *)
  240.     menu_id := Menu_Register(Appl_Id,mein_Menu); (* eintragen...           *)
  241.     Event_Loop;                                  (* ... und abwarten...    *)
  242.   END;
  243. END.
  244.