home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug117.arc / PASLIST.LBR / PASLIST.PQS / PASLIST.PAS
Pascal/Delphi Source File  |  1979-12-31  |  8KB  |  225 lines
  1. program PascalLister (Input, Output, Infile, Lst);
  2. {
  3. Program by Marco Colli
  4.            16 Tudor Avenue,
  5.            Cherrybrook NSW 2120,
  6.            Australia.
  7.  
  8.     To use this program type
  9.            PASLIST <progname>
  10.     If <progname> has no extension a default of '.PAS' is added.
  11.  
  12. Version 1.1, 1 January 1986.
  13.     Corrected handling of reserved words in comments and within quotes.
  14.     Program could not list itself otherwise!!
  15.  
  16. Version 1.0, 31 December 1985.
  17.     The purpose of this program is to produce a listing of a Pascal program,
  18.     in this case TURBO PASCAL, underlining the reserved words as occur. No
  19.     account is taken of page boundaries, i.e. listing is continuous.
  20.     Words longer than MaxWordLen are truncated.
  21.     NOTE: The program must be accepted by the compiler before it is listed
  22.     using PASLIST.  No error checking is carried out.
  23. }
  24.  
  25. const
  26.     Version = '1.1';         { version number }
  27.     MaxWordLen = 20;         { longest allowable word  }
  28.     Blank = ' ';
  29.     oQuote = '''';
  30.     cQuote = '''';
  31.     oBrace = '{';
  32.     cBrace = '}';
  33.  
  34. type
  35.     CharIndex = 1 .. MaxWordLen;       { counter subrange }
  36.     WordType = string[MaxWordLen];     { a word }
  37.  
  38. const
  39.     { This list of RESERVED WORDS is taken from the TURBO PASCAL 3.0 manual.
  40.       It must be maintained in alphabetical order, and ResWordsNum must be
  41.       the count of reserved words }
  42.     ResWordsNum = 44;
  43.     ResWords : array [1..ResWordsNum] of WordType =
  44.              ('ABSOLUTE','AND','ARRAY','BEGIN','CASE','CONST','DIV','DO',
  45.               'DOWNTO','ELSE','END','EXTERNAL','FILE','FOR','FORWARD',
  46.               'FUNCTION','GOTO','IF','IN','INLINE','LABEL','MOD','NIL',
  47.               'NOT','OF','OR','OVERLAY','PACKED','PROCEDURE','PROGRAM',
  48.               'RECORD','REPEAT','SET','SHL','SHR','STRING','THEN','TO',
  49.               'TYPE','UNTIL','VAR','WHILE','WITH','XOR');
  50. var
  51.     NextWord : WordType;               { temporary word buffer }
  52.     Chbuffer : char;                   { character buffer }
  53.     Infile   : text;                   { input file }
  54.     Exceptions,                        { set of exception characters }
  55.     Letters  : set of char;            { set of valid characters }
  56.  
  57.  
  58. procedure Initialise;
  59. { Initialise variables and open files required }
  60. var
  61.     temp : integer;          { temporary variable }
  62.  
  63. begin
  64.     Chbuffer := chr(0);
  65.     Letters := ['A'..'Z','a'..'z'];
  66.     Exceptions := [oQuote,oBrace];
  67.  
  68.     if (ParamCount = 0) or (ParamCount > 1) then begin
  69.         Writeln('usage: PASLIST textfile');
  70.         Halt;
  71.     end;  { if }
  72.  
  73.     NextWord := ParamStr(1);
  74.     temp := Pos('.',NextWord);         { see if there is an extension }
  75.     if (temp = 0) then
  76.         NextWord := Concat(NextWord,'.PAS');
  77.     Assign(Infile,NextWord);
  78.     {$I-}
  79.     Reset(Infile);
  80.     {$I+}
  81.     if (IOResult <> 0) then begin
  82.         Writeln('PASLIST: cannot open file ',NextWord);
  83.         Halt;
  84.     end;  { if }
  85. end;  { Initialise }
  86.  
  87.  
  88. procedure UnGetch (ch : char);
  89. { Gone too far - put last char back in char buffer }
  90. begin
  91.     Chbuffer := ch;
  92. end;  { UnGetch }
  93.  
  94.  
  95. function Getch : char;
  96. { Read a character from the input file.  If the buffer contains a
  97.   character take it. }
  98. var
  99.     ch : char;               { temporary }
  100.  
  101. begin
  102.     if (Chbuffer <> chr(0)) then begin { character in the buffer }
  103.         ch := Chbuffer;
  104.         Chbuffer := chr(0);            { no character left }
  105.     end else                           { read in from file }
  106.         if not Eof(Infile) then
  107.             Read(Infile,ch)
  108.         else
  109.             ch := Blank;               { stop any loops }
  110.     Getch := ch;
  111. end;  { Getch }
  112.  
  113.  
  114. procedure SkipQuote (var ch : char);
  115. { Read and echo the input until the close quote is reached }
  116. begin
  117.     repeat
  118.         Write(Lst,ch);
  119.         ch := Getch;
  120.     until (ch = cQuote) or Eof(Infile);
  121. end;  { SkipQuote }
  122.  
  123.  
  124. {$A-  This is a recursive procedure}
  125.  
  126. procedure SkipComments (var ch : char);
  127. { Handle comments in a recursive way, thus allowing nesting.
  128.   NOTE: The only recognised comments indicators are } {, the compound
  129.         '(*' and '*)' characters are not. }
  130. begin
  131.     Write(Lst,ch);                     { left over from calling procedure }
  132.     repeat
  133.         ch := Getch;
  134.         if (ch = oBrace) then
  135.                 SkipComments(ch);      { nested comments }
  136.         if (ch = oQuote) then
  137.                 SkipQuote(ch);         { zoom to close quote }
  138.         Write(Lst,ch);
  139.     until (ch = cBrace) or Eof(Infile);
  140.     ch := Getch;                       { set up for calling procedure }
  141. end;  { SkipComments }
  142.  
  143. {$A+ End of recursive procedure }
  144.  
  145.  
  146. procedure ReadWord (var Word : WordType);
  147. { Read the next word from input file }
  148. var
  149.     CharCount : CharIndex;   { counter }
  150.     ch : char;
  151.  
  152. begin
  153.     Word := '';                        { none there yet }
  154.     if not Eof(Infile) then
  155.         repeat                         { skip all leading rubbish }
  156.             ch := Getch;
  157.             if (ch in Exceptions) then
  158.                 case ch of
  159.                     oQuote : SkipQuote(ch);      { zoom to close quote }
  160.                     oBrace : SkipComments(ch);   { finish off comment }
  161.                 end;  { case }
  162.             Write(Lst,ch);             { echo it back }
  163.         until Eof(Infile) or (ch in Letters);
  164.     if not Eof(Infile) then begin
  165.         CharCount := 0;                { no letters yet }
  166.         while (ch in Letters) do begin
  167.             if (CharCount < MaxWordLen) then begin  { build up word }
  168.                 CharCount := CharCount + 1;
  169.                 Word := Concat(Word,ch);
  170.             end;  { if }
  171.             ch := Getch;
  172.             if (ch in Letters) then    { avoid writing last character }
  173.                 Write(Lst,ch);
  174.         end;  { while }
  175.         UnGetch(ch);                   { gone too far, save it }
  176.     end;  { if }
  177. end;  { ReadWord }
  178.  
  179.  
  180. procedure Underline (Len : integer);
  181. { Underline a reserved word.  Printer must be able to backspace }
  182. const
  183.     BS = ^H;                 { backspace }
  184.     UL = '_';                { underline }
  185. var
  186.     i : integer;             { temporary }
  187.  
  188. begin
  189.     for i := 1 to Len do
  190.         Write(Lst,BS);                 { move back to start of word }
  191.     for i := 1 to Len do
  192.         Write(Lst,UL);                 { underline the word }
  193. end;  { Underline }
  194.  
  195.  
  196. function ReservedWord (Word : WordType) : boolean;
  197. { Check the next word with the list of reserved words and return
  198.   true if it is there }
  199. var
  200.     i : integer;             { loop counter }
  201.     t : boolean;             { temporary }
  202.  
  203. begin
  204.     for i := 1 to Length(Word) do
  205.         Word[i] := UpCase(Word[i]);    { table entries are in uc }
  206.     i := 1;
  207.     t := false;
  208.     while (i <= ResWordsNum) and (ResWords[i] <= Word) and (not t) do begin
  209.         t := (ResWords[i] = Word);
  210.         i := i + 1;
  211.     end;  { for }
  212.     ReservedWord := t;
  213. end;  { ReservedWord }
  214.  
  215.  
  216. begin  { PascalLister }
  217.     Writeln('PASLIST Version ',Version,'  by Marco Colli');
  218.     Initialise;                                   { set up files & variables }
  219.     while not Eof(Infile) do begin                { process file }
  220.         ReadWord(NextWord);                       { get a word }
  221.         if ReservedWord(NextWord) then            { is it in reserved list? }
  222.             Underline(Length(NextWord));          { yes, underline the word }
  223.     end;  { while }
  224. end.  { PascalLister }
  225.