home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / PRETTY2.PQS / PRETTY2.PAS
Pascal/Delphi Source File  |  2000-06-30  |  14KB  |  412 lines
  1. PROGRAM PrettyPrinter;
  2.  
  3. (*
  4. **  Filename:       PRETTY.PAS
  5. **  Language:       Turbo Pascal
  6. **  Target machine: Tested on H89 & CP/M 2.2, but should work on any
  7. **                      computer or operating system which runs Turbo.
  8. **  By:             Don McCrady (June 27, 1985)
  9. **  Updated:        July 14, 1985
  10. **
  11. **  This program is a "Pascal Program Spiffyizer".  It takes an
  12. **  ordinary Pascal program and produces a copy of it with all
  13. **  reserved words in upper case.  (If the source file is written
  14. **  entirely in upper case, then this program will have no effect
  15. **  at all on it.)
  16. **
  17. **  The output from PRETTY can be written to the terminal, the printer,
  18. **  a disk file, or all three at once.
  19. **
  20. **  The user can turn off the marking of reserved words, and the page
  21. **  formatting if printer output is selected.  If disk file output is
  22. **  requested, the user can also tell the program to erase the original
  23. **  file when finished.
  24. **
  25. **  There is one bug:  If the source file contains a word which is longer
  26. **  than 16 characters, the pretty printer will drop characters.  A word
  27. **  with 16 characters is pretty long, so the bug shouldn't present much
  28. **  of a problem with most Pascal programs.
  29. *)
  30.  
  31. CONST   NumReserved = 41;          { Number of reserved words in Turbo. }
  32.         StrLength = 16;      { Maximum word length.  This program won't }
  33.         bell = ^G;            { work properly if there are any words in }
  34.         cr = ^M;             { the source file which are larger than 16 }
  35.         lf = ^J;                                          { characters. }
  36.         esc = ^[;
  37.         tab = ^I;
  38.         ff = ^L;
  39.         space = ' ';
  40.         blank16 = '                ';                      { 16 spaces. }
  41.  
  42. TYPE    str = PACKED ARRAY [1..StrLength] OF char;
  43.         string15 = STRING[15];
  44.         string80 = STRING[80];
  45.         CharSet = SET OF char;
  46.  
  47. CONST   AlphaNum : CharSet = ['A'..'Z','a'..'z','0'..'9'];
  48.         (* WARNING:     To modify the following list, change the        *)
  49.         (*      NumReserved constant to the new number of reserved      *)
  50.         (*      words.  Then insert/delete reserved words in the        *)
  51.         (*      following declaration -- but MAKE SURE THAT THE         *)
  52.         (*      NEW LIST REMAINS IN ALPHABETICAL ORDER!!!               *)
  53.         KeyWord : ARRAY [1..NumReserved] OF str =
  54.           ('ABSOLUTE        ',  'AND             ',   'ARRAY           ',
  55.            'BEGIN           ',  'CASE            ',   'CONST           ',
  56.            'DIV             ',  'DO              ',   'DOWNTO          ',
  57.            'ELSE            ',  'END             ',   'EXTERNAL        ',
  58.            'FILE            ',  'FOR             ',   'FORWARD         ',
  59.            'FUNCTION        ',  'GOTO            ',   'IF              ',
  60.            'IN              ',  'LABEL           ',   'MOD             ',
  61.            'NIL             ',  'NOT             ',   'OF              ',
  62.            'OR              ',  'PACKED          ',   'PROCEDURE       ',
  63.            'PROGRAM         ',  'RECORD          ',   'REPEAT          ',
  64.            'SET             ',  'SHL             ',   'SHR             ',
  65.            'STRING          ',  'THEN            ',   'TO              ',
  66.            'TYPE            ',  'UNTIL           ',   'VAR             ',
  67.            'WHILE           ',  'WITH            ');
  68.  
  69. VAR infile,outfile : text;
  70.     InfileName,OutfileName,OldInfileName : string15;
  71.     NextCh : char;
  72.     FormatPage,               { Boolean flags... control output format. }
  73.     MarkReserved,
  74.     EraseOld,
  75.     ConOut,
  76.     FileOut,
  77.     ListOut : Boolean;
  78.     LineNum,
  79.     PageNum : byte;
  80.  
  81. { Read the next character from the source file.  Store the look-ahead   }
  82. {  character into the global variable NextCh.                           }
  83. PROCEDURE ReadChar(VAR ch : char);
  84. BEGIN
  85.     ch := NextCh;
  86.     read(infile,NextCh)
  87. END;
  88.  
  89. { Convert a PACKED ARRAY string to uppercase.                           }
  90. PROCEDURE ToUpper(VAR s : str);
  91. VAR wptr : byte;
  92. BEGIN
  93.     FOR wptr := 1 TO StrLength DO
  94.         s[wptr] := upcase(s[wptr])
  95. END;
  96.  
  97. { Write a character (ch) to the output device(s).                       }
  98. PROCEDURE out(ch : char);
  99. CONST   MaxLine = 60;
  100. BEGIN
  101.     IF ConOut THEN
  102.         write(con,ch);
  103.     IF ListOut THEN
  104.         BEGIN
  105.         IF FormatPage THEN
  106.             BEGIN
  107.             IF ch = ^M THEN
  108.                 LineNum := succ(LineNum);
  109.             IF LineNum = MaxLine THEN
  110.                 BEGIN
  111.                 LineNum := 1;
  112.                 PageNum := succ(PageNum);
  113.                 write(lst,cr,ff,InfileName,cr,InfileName);
  114.                 write(lst,tab,tab,tab,tab,tab,tab,tab,tab,'Page ',PageNum);
  115.                 writeln(lst,lf,lf)
  116.                 END
  117.             END;
  118.         write(lst,ch)
  119.         END;
  120.     IF FileOut THEN
  121.         write(outfile,ch)
  122. END;
  123.  
  124. { Sound terminal bell.                                                  }
  125. PROCEDURE beep;
  126. BEGIN
  127.     write(bell)
  128. END;
  129.  
  130. { Display error message (msg), sound terminal bell, and exit.           }
  131. PROCEDURE error(msg : string80);
  132. BEGIN
  133.     beep;
  134.     writeln(msg);
  135.     halt
  136. END;
  137.  
  138. { Read a single character from keyboard.  The only acceptable chara-    }
  139. {  acters are SPACE, CR, ESCAPE, Y, and N.  If the parameter "default"  }
  140. {  is "false", then SPACE, CR, or ESCAPE will produce the same result   }
  141. {  as typing N.  If "default" is "true", then SPACE, CR, or ESCAPE will }
  142. {  be the same as typing Y.                                             }
  143. { If the user enters Y, the function will write "Yes" to the terminal   }
  144. {  and return a value of true; otherwise it will write "No" and return  }
  145. {  a value of false.  If an unacceptable key is entered, the terminal   }
  146. {  bell is sounded, and the function will await a legal response.       }
  147. FUNCTION yes(default : Boolean) : Boolean;
  148. VAR ch : char;
  149. BEGIN
  150.     REPEAT
  151.         read(kbd,ch);
  152.         IF ch IN [cr,space,esc] THEN
  153.             IF default = false THEN
  154.                 ch := 'N'
  155.             ELSE
  156.                 ch := 'Y';
  157.         ch := upcase(ch);
  158.         CASE ch OF
  159.             'Y':    BEGIN
  160.                         yes := true;
  161.                         writeln('Yes')
  162.                     END;
  163.             'N':    BEGIN
  164.                         yes := false;
  165.                         writeln('No')
  166.                     END
  167.             ELSE    beep
  168.         END{case}
  169.     UNTIL ch IN ['Y','N']
  170. END;
  171.  
  172. { If the parameter string "fname" does not have an extension, then the  }
  173. {  default extension '.PAS' is appended to it.                          }
  174. PROCEDURE MakeFileName(VAR fname : string15);
  175. VAR ExtPos : byte;
  176. BEGIN
  177.     ExtPos := pos('.',fname);
  178.     IF ExtPos = 0 THEN
  179.         fname := fname + '.PAS'
  180. END;
  181.  
  182. { Opens a text file for input or output, depending on the parameter     }
  183. {  "mode".  MODE is either "I" for input or "O" for output.             }
  184. PROCEDURE open(mode : char; VAR f : text; name : string15);
  185. BEGIN
  186.     {$I-}
  187.     assign(f,name);
  188.     CASE upcase(mode) OF
  189.         'I':    BEGIN
  190.                     reset(f);
  191.                     IF IOresult <> 0 THEN
  192.                         error('Can''t open '+name)
  193.                 END;
  194.         'O':    BEGIN
  195.                     reset(f);
  196.                     IF IOresult = 0 THEN
  197.                         BEGIN
  198.                         beep;
  199.                         write('File ',name,' exists.  Overwrite? ');
  200.                         IF NOT yes(false) THEN
  201.                             error('Aborting')
  202.                         END
  203.                     ELSE
  204.                         rewrite(f)
  205.                 END
  206.         ELSE    error('Bad file mode')
  207.     END{case}
  208.     {$I+}
  209. END;  { open }
  210.  
  211. PROCEDURE MakeBackup(VAR InfileName : string15);
  212. VAR i : byte;
  213. BEGIN
  214.     OldInfileName := InfileName;
  215.     assign(infile,InfileName);
  216.     i := pos('.',InfileName);
  217.     IF i <> 0 THEN
  218.         InfileName := copy(InfileName,1,i) + 'BAK'
  219.     ELSE
  220.         InfileName := InfileName + '.BAK';
  221.     rename(infile,InfileName)
  222. END;
  223.  
  224. { Set Boolean flags.                                                    }
  225. PROCEDURE SetParams;
  226. BEGIN
  227.     FormatPage := true;
  228.     MarkReserved := true;
  229.     ConOut := true;
  230.     ListOut := false;
  231.     FileOut := false;
  232.     EraseOld := false;
  233.     writeln;
  234.     write('Source file name? ');
  235.     readln(InfileName);
  236.     MakeFileName(InfileName);
  237.     MakeBackup(InfileName);
  238.     open('i',infile,InfileName);
  239.     writeln;
  240.     write('Suppress marking of reserved words? ');
  241.     IF yes(NOT MarkReserved) THEN
  242.         MarkReserved := NOT MarkReserved;
  243.     write('Disk file output? ');
  244.     IF yes(FileOut) THEN
  245.         FileOut := NOT FileOut;
  246.     IF FileOut THEN
  247.         BEGIN
  248.         write(tab,'Output file name? ');
  249.         readln(OutfileName);
  250.         MakeFileName(OutfileName);
  251.         open('o',outfile,OutfileName);
  252.         write(tab,'Erase original file? ');
  253.         IF yes(false) THEN
  254.             EraseOld := true
  255.         END;
  256.     write('Console output? ');
  257.     IF NOT yes(ConOut) THEN
  258.         ConOut := NOT ConOut;
  259.     write('Printer output? ');
  260.     IF yes(ListOut) THEN
  261.         ListOut := NOT ListOut;
  262.     IF ListOut THEN
  263.         BEGIN
  264.         write('Suppress page formatting? ');
  265.         IF yes(NOT FormatPage) THEN
  266.             FormatPage := NOT FormatPage
  267.         END
  268. END;  { SetParams }
  269.  
  270. { Main procedure.  Maps any reserved words to upper case.               }
  271. PROCEDURE PrettyPrint;
  272. VAR ch : char;
  273.     state : (InWord,InStr,InComment,copying);
  274.     word,TestWord : str;
  275.     wptr : byte;
  276.  
  277.     { Display a PACKED ARRAY string to the output device(s) with all    }
  278.     {  trailing blanks removed.                                         }
  279.     PROCEDURE PrintWord(word : str);
  280.     VAR i : byte;
  281.     BEGIN
  282.         i := 1;
  283.         WHILE (word[i] <> ' ') AND (i <= StrLength) DO
  284.             BEGIN
  285.             out(word[i]);
  286.             i := succ(i)
  287.             END
  288.     END;
  289.  
  290.     { Binary searches the KEYWORD list (global) to see if the parameter }
  291.     {  "word" is a reserved word.                                       }
  292.     FUNCTION IsReserved(word : str) : Boolean;
  293.     VAR top,bottom,mid : byte;
  294.     BEGIN
  295.         top := NumReserved;
  296.         bottom := 1;
  297.         WHILE top > bottom DO
  298.             BEGIN
  299.             mid := (top + bottom) SHR 1;  { Same as (top+bottom) DIV 2. }
  300.             IF word > KeyWord[mid] THEN
  301.                 bottom := succ(mid)
  302.             ELSE
  303.                 top := mid
  304.             END;{while}
  305.         IF word = KeyWord[top] THEN
  306.             IsReserved := true
  307.         ELSE
  308.             IsReserved := false
  309.     END;  { IsReserved }
  310.  
  311. BEGIN { PrettyPrint }
  312.     state := copying;
  313.     word := blank16;
  314.     read(infile,NextCh);                { Initialize the global NextCh. }
  315.     WHILE NOT eof(infile) DO
  316.         BEGIN
  317.         ReadChar(ch);
  318.         CASE state OF
  319.             copying:    BEGIN
  320.                             IF ((ch='(') AND (NextCh='*')) OR (ch='{') THEN
  321.                                 BEGIN
  322.                                 state := InComment;
  323.                                 out(ch)
  324.                                 END{if}
  325.                             ELSE IF ch = '''' THEN
  326.                                 BEGIN
  327.                                 state := InStr;
  328.                                 out(ch)
  329.                                 END{if}
  330.                             ELSE IF ch IN AlphaNum THEN
  331.                                 BEGIN
  332.                                 word := blank16;
  333.                                 state := InWord;
  334.                                 wptr := 1;
  335.                                 word[wptr] := ch
  336.                                 END{if}
  337.                             ELSE
  338.                                 out(ch)
  339.                         END;{case copying}
  340.             InComment:  BEGIN
  341.                             IF ((ch='*') AND (NextCh=')')) OR (ch = '}') THEN
  342.                                 state := copying;
  343.                             out(ch)
  344.                         END;{case InComment}
  345.             InStr:      BEGIN
  346.                             IF ch = '''' THEN
  347.                                 state := copying;
  348.                             out(ch)
  349.                         END;{case InStr}
  350.             InWord:     BEGIN
  351.                             WHILE (ch IN AlphaNum) AND (wptr <= StrLength) DO
  352.                                 BEGIN
  353.                                 wptr := succ(wptr);
  354.                                 word[wptr] := ch;
  355.                                 ReadChar(ch)
  356.                                 END;{while}
  357.                             IF MarkReserved THEN
  358.                                 BEGIN
  359.                                 TestWord := word;
  360.                                 ToUpper(TestWord);
  361.                                 IF IsReserved(TestWord) THEN
  362.                                     PrintWord(TestWord)
  363.                                 ELSE
  364.                                     PrintWord(word)
  365.                                 END{if}
  366.                             ELSE
  367.                                 PrintWord(word);
  368.                             word := blank16;
  369.                             out(ch);
  370.                             IF ((ch='(') AND (NextCh='*')) OR (ch = '{') THEN
  371.                                 state := InComment
  372.                             ELSE
  373.                                 state := copying
  374.                         END{case InWord}
  375.             END{case}
  376.         END{while}
  377. END;  { PrettyPrint }
  378.  
  379. BEGIN   (* Main Program *)
  380.     SetParams;
  381.     IF FormatPage AND ListOut THEN
  382.         BEGIN
  383.         PageNum := 1;
  384.         LineNum := 1;
  385.         write(lst,InfileName,cr,InfileName);
  386.         write(lst,tab,tab,tab,tab,tab,tab,tab,tab,'Page ',PageNum);
  387.         writeln(lst,lf,lf)
  388.         END;
  389.     IF ConOut THEN
  390.         ClrScr;
  391.     PrettyPrint;
  392.     IF FileOut THEN
  393.         BEGIN
  394.         close(outfile);
  395.         IF EraseOld THEN
  396.             erase(infile)
  397.         END
  398.     ELSE
  399.         rename(infile,OldInfileName)
  400. END.
  401. 
  402.  
  403.  
  404.  
  405.  
  406.  
  407.  
  408.  
  409.  
  410.  
  411.  
  412. ┘╪yß"Sz!≤ 9∙δφ