home *** CD-ROM | disk | FTP | other *** search
/ cs.rhul.ac.uk / www.cs.rhul.ac.uk.zip / www.cs.rhul.ac.uk / pub / rdp / rdp_cs3460.tar / test.pas < prev    next >
Pascal/Delphi Source File  |  1998-05-07  |  9KB  |  284 lines
  1. (*******************************************************************************
  2. *
  3. * RDP release 1.50 by Adrian Johnstone (A.Johnstone@rhbnc.ac.uk) 20 December 1997
  4. *
  5. * test.pas - a piece of Pascal source to test the Pascal parser
  6. *
  7. * This file may be freely distributed. Please mail improvements to the author.
  8. *
  9. *******************************************************************************)
  10.  
  11. PROGRAM string2101(i,o,output);
  12.  
  13. CONST maxcode=127;
  14.  maxreal = 1.3;
  15.  
  16. TYPE etype=(e_nof, e_eof, e_badchar, e_badstring, e_controlstring,
  17.             e_2linestring, e_badescape, e_badoct, e_badhex,
  18.             e_inline, e_dochar, e_dostring, e_donest);
  19.  
  20. VAR
  21.  f,i,o: text;
  22.  null,ch: char;
  23.  id: PACKED ARRAY[1..32] OF char;
  24.  temp1,temp2,commentlevel,temp,param,stringsize,bsize,lineno,idl: integer;
  25.  echo,stringdone,verbose,changed: boolean;
  26.  outfile,filename: string;
  27.  codetable: ARRAY[0..maxcode] OF integer;
  28.  
  29. PROCEDURE error(e: etype);
  30.  BEGIN
  31.    IF e = e_nof THEN BEGIN writeln('No source file specified'); halt(1) END;
  32.    write('string21: ',filename,', line ',lineno,': ');
  33.    CASE e OF
  34.     e_inline: writeln('Inline initialisation');
  35.     e_dochar: writeln('Character constant');
  36.     e_dostring: writeln('String constant');
  37.     e_donest: writeln('Nested comment');
  38.     e_eof: BEGIN
  39.             write('unexpected end of file');
  40.             IF commentlevel>0 THEN write(' whilst skipping comment');
  41.             writeln;
  42.             halt(1);
  43.            END;
  44.     e_badchar: writeln('bad character constant terminator');
  45.     e_badstring: writeln('bad string constant terminator');
  46.     e_controlstring: writeln('control code found in string or character constant');
  47.     e_2linestring: writeln('string or character constant not terminated before end of line');
  48.     e_badescape: writeln('illegal character escape sequence \',ch);
  49.     e_badoct: writeln('bad octal digit "',ch,'"in character escape sequence');
  50.     e_badhex: writeln('bad hex digit "',ch,'"in character escape sequence');
  51.    END
  52.  END;
  53.  
  54. PROCEDURE inch;
  55.  BEGIN IF eof(i) THEN error(e_eof) ELSE read(i,ch) END;
  56.  
  57. PROCEDURE getch; {main scanning routine:
  58.                   echo last character read, get another and skip comments}
  59.  VAR messageissued: boolean;
  60.  BEGIN
  61.   messageissued:=false;
  62.   REPEAT
  63.    IF commentlevel=0 THEN messageissued:=false;
  64.    IF echo AND (ch IN [' ' .. '~']) THEN write(o,ch);
  65.    IF eoln(i) THEN BEGIN lineno:=lineno+1; IF echo THEN writeln(o); END;
  66.    IF eof(i) THEN error(e_eof) ELSE read(i,ch);
  67.    IF ch='{' THEN BEGIN IF (commentlevel<>0) AND NOT messageissued
  68.                         THEN BEGIN error(e_donest); messageissued:=true END;
  69.                         commentlevel:=commentlevel+1;
  70.                   END;
  71.    IF ch='}' THEN BEGIN commentlevel:=commentlevel-1;
  72.                         IF commentlevel<>0 THEN BEGIN changed:=true; ch:=' ' END;
  73.                   END;
  74.   UNTIL commentlevel=0;
  75.  END;
  76.  
  77. PROCEDURE chargetch; {secondary scanner for character strings:
  78.                       no echo, expand escapes, don't recognise comments
  79.                       special returns:
  80.                       control codes converted to space, eoln " ' set stringdone flag
  81.                       errors:
  82.                       eoln->e_2linestring, control->e_controlstring,
  83.                       illegal escape->e_badescape}
  84.  VAR count,temp: integer;
  85.  BEGIN
  86.    IF eoln(i) THEN BEGIN error(e_2linestring); stringdone:=true END
  87.    ELSE
  88.    inch;
  89.    IF NOT (ch IN [' ' .. '~']) THEN BEGIN error(e_controlstring); ch:=' ' END ELSE
  90.    IF ch IN ['''','"'] THEN stringdone:=true ELSE
  91.    IF ch='\' {escape character}
  92.    THEN
  93.     BEGIN
  94.      inch;
  95.      CASE ch OF
  96.       'n': ch:=chr(10);
  97.       't': ch:=chr(9);
  98.       'v': ch:=chr(11);
  99.       'b': ch:=chr(8);
  100.       'r': ch:=chr(13);
  101.       'f': ch:=chr(12);
  102.       'a': ch:=chr(7);
  103.       '\':;
  104.       '?':;
  105.       '''':;
  106.       '"':;
  107.       '0' .. '7': BEGIN
  108.                  temp:=0;
  109.                  FOR count:=1 TO 3 DO
  110.                   BEGIN
  111.                    temp:=temp*8+ord(ch)-ord('0');
  112.                    IF count<3 THEN
  113.             BEGIN inch; IF NOT (ch IN ['0' .. '7']) THEN error(e_badoct) END;
  114.                   END;
  115.                  ch:=chr(temp);
  116.                 END;
  117.       'x': BEGIN
  118.             temp:=0; FOR count:=1 TO 2 DO
  119.              BEGIN
  120.               inch; temp:=temp*16;
  121.               CASE ch OF
  122.            '0' .. '9': temp:=temp+ord(ch)-ord('0');
  123.            'a' .. 'z': temp:=temp+ord(ch)-ord('a')+10;
  124.            'A' .. 'Z': temp:=temp+ord(ch)-ord('A')+10;
  125.                ELSE error(e_badhex);
  126.               END;
  127.              END;
  128.             ch:=chr(temp)
  129.            END;
  130.       ELSE error(e_badescape)
  131.      END
  132.     END
  133.  END;
  134.  
  135. PROCEDURE getid;
  136.  BEGIN
  137.   IF ch IN ['a' .. 'z','A' .. 'Z','_'] THEN
  138.   BEGIN
  139.    idl:=1; id[idl]:=ch; getch;
  140.    WHILE ch IN ['a' .. 'z','A' .. 'Z','_','0' .. '9'] DO
  141.     BEGIN idl:=idl+1; id[idl]:=ch; getch END;
  142.   END
  143.  END;
  144.  
  145. PROCEDURE docharconstant;
  146.  BEGIN
  147.   changed:=true;
  148.   IF verbose THEN error(e_dochar);
  149.   chargetch;
  150.   IF echo THEN write(o,codetable[ord(ch)]:1)
  151.           ELSE write(f,codetable[ord(ch)]:1);
  152.   chargetch;
  153.   IF ch<>'''' THEN error(e_badchar); ch:=null; getch;
  154.  END;
  155.  
  156.  
  157. PROCEDURE dostringconstant;
  158.  BEGIN
  159.   changed:=true;
  160.   IF verbose THEN error(e_dostring);
  161.   stringdone:=false; stringsize:=1; {null at end of string}
  162.   WHILE NOT stringdone DO
  163.    BEGIN
  164.     chargetch;
  165.     IF NOT stringdone THEN {fudge for closing "}
  166.     IF echo THEN write(o,codetable[ord(ch)]:1,',')
  167.             ELSE write(f,codetable[ord(ch)]:1,',');
  168.     stringsize:=stringsize+1
  169.    END;
  170.   IF echo THEN write(o,'0') ELSE write(f,'0');
  171.   IF NOT (ch='"') THEN error(e_badstring); ch:=null; getch
  172.  END;
  173.  
  174. PROCEDURE docommand;
  175. VAR count: integer; fch: char;
  176.  BEGIN
  177.   getch; getid;
  178.   IF idl=3 THEN
  179.    IF ((id[1]='v') OR (id[1]='V')) AND
  180.       ((id[2]='a') OR (id[2]='A')) AND
  181.       ((id[3]='r') OR (id[3]='R')) THEN
  182.     BEGIN
  183.      WHILE ch<>';' DO {scan to end of statement}
  184.       BEGIN
  185.        IF ch IN ['A' .. 'Z','a' .. 'z','_'] THEN getid {always remember last id}
  186.        ELSE
  187.         IF ch=':' THEN {copy out initialisation code}
  188.          BEGIN
  189.           changed:=true; IF verbose THEN error(e_inline);
  190.           echo:=false; bsize:=1; {quieten output file}
  191.           rewrite(f); write(f,'.init ');
  192.           FOR count:=1 TO idl DO write(f,id[count]);
  193.           write(f,': ');
  194.           WHILE ch<>';' DO {scan to end of statement}
  195.            BEGIN
  196.             getch; IF NOT(ch IN ['"','''']) THEN write(f,ch);
  197.             IF ch=',' THEN bsize:=bsize+1
  198.             ELSE IF ch='"' THEN BEGIN dostringconstant; bsize:=bsize-1+stringsize END
  199.              ELSE IF ch='''' THEN docharconstant;
  200.            END;
  201.           write(o,'[',bsize:1,'];' ); {finish off the .VAR statment}
  202.           close(f); reset(f);
  203.           WHILE NOT eof(f) DO BEGIN read(f,fch); IF fch<>';' THEN write(o,fch) END;
  204.           echo:=true;
  205.          END
  206.         ELSE getch;
  207.       END;
  208.     END
  209.  END;
  210.  
  211. PROCEDURE openi(s: string);
  212.  BEGIN
  213.   assign(i,s); {$I-} reset(i); {$I+}
  214.   IF ioresult<>0 THEN BEGIN writeln('Can''t find ',s); halt(1) END;
  215.  END;
  216.  
  217. BEGIN
  218.  changed:=false; commentlevel:=0; verbose:=false; filename:='';
  219.  FOR temp:=0 TO maxcode DO codetable[temp]:=temp;
  220.  IF paramcount<1 THEN
  221.   BEGIN
  222.    writeln('string21 - a string preprocessor for asm21');
  223.    writeln('Adrian Johnstone 1990: this software may be freely distributed');
  224.    writeln(' -r load ASCII code table with reverse ASCII');
  225.    writeln(' -t <codefile> load ASCII code table from file <codefile>');
  226.    writeln(' -v verbose commentary');
  227.    writeln(' -c display ASCII code table');
  228.    halt(1)
  229.   END;
  230.  param:=1;
  231.  WHILE param<=paramcount DO
  232.   BEGIN
  233.    IF paramstr(param)='-v' THEN verbose:=true ELSE
  234.    IF paramstr(param)='-r' THEN
  235.     FOR temp:=0 TO maxcode DO codetable[temp]:=maxcode-temp
  236.    ELSE
  237.     IF paramstr(param)='-t' THEN
  238.      BEGIN
  239.       param:=param+1;
  240.       openi(paramstr(param));
  241.       FOR temp:=0 TO maxcode DO
  242.        IF not eof(i) THEN readln(i,codetable[temp]);
  243.       close(i);
  244.      END
  245.     ELSE
  246.      IF paramstr(param)='-c' THEN
  247.       BEGIN
  248.        writeln('Code table (decimal)');
  249.        temp:=0;
  250.        FOR temp1:=1 TO 16 DO
  251.         BEGIN
  252.          FOR temp2:=1 TO 8 DO
  253.           BEGIN
  254.        ch:=chr(temp); IF ch IN [' ' .. '~'] THEN write(ch) ELSE write(' ');
  255.            write(':',temp:3,'    '); temp:=temp+1;
  256.           END;
  257.          writeln;
  258.         END
  259.       END ELSE
  260.      filename:=paramstr(param);
  261.    param:=param+1;
  262.   END;
  263.  IF filename='' THEN error(e_nof);
  264.  IF verbose THEN writeln('Source file:   ',filename); openi(filename);
  265.  outfile:=filename;
  266.  delete(outfile,pos('.',outfile),100); outfile:=concat(outfile,'.dsp');
  267.  IF verbose THEN writeln('Expanded file: ',outfile);  assign(o,outfile);
  268.  rewrite(o);
  269.  assign(f,'asmppp.tmp');
  270.  null:=chr(0); lineno:=1;
  271.  IF NOT eof(i) THEN read(i,ch); echo:=true;
  272.  WHILE NOT eof(i) DO
  273.   BEGIN
  274.    IF ch='''' THEN docharconstant ELSE
  275.     IF ch='"' THEN dostringconstant ELSE
  276.      IF ch='.' THEN docommand
  277.        ELSE getch {skip any other characters}
  278.   END;
  279.  close(i); close(o);
  280.  IF verbose AND NOT changed THEN writeln('No changes made');
  281. END.
  282.  
  283. { End of test.pas }
  284.