home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / compcomp / tpyacc / src / lex.pas next >
Encoding:
Pascal/Delphi Source File  |  1991-05-01  |  18.8 KB  |  686 lines
  1.  
  2. program Lex;
  3.  
  4. uses LexBase, LexTables, LexPos, LexDFA, LexOpt, LexList, LexRules, LexMsgs;
  5.  
  6. (* Copyright (c) 1990,91 by Albert Graef, Schillerstr. 18,
  7.    6509 Schornsheim/Germany
  8.    All rights reserved *)
  9.  
  10. (* TP Lex - A lexical analyzer generator for MS-DOS/Turbo Pascal
  11.  
  12.    Version 3.0 as of April 91
  13.  
  14.    Author
  15.  
  16.    Albert Graef
  17.    Schillerstr. 18
  18.    6509 Schornsheim/Germany
  19.  
  20.    Graef@DMZRZU71.bitnet
  21.  
  22.    Synopsis   LEX [options] lex-file[.L] [output-file[.PAS]]
  23.  
  24.    Options
  25.  
  26.    /v  "Verbose:" Lex generates a readable description of the generated
  27.        lexical analyzer, written to lex-file with new extension .LST.
  28.  
  29.    /o  "Optimize:" Lex optimizes DFA tables to produce a minimal DFA
  30.  
  31.    Description
  32.  
  33.    This is a reimplementation of the popular UNIX lexical analyzer generator
  34.    Lex for MS-DOS and Turbo Pascal.
  35.  
  36.    Differences from UNIX Lex:
  37.  
  38.    - Produces output code for Turbo Pascal, rather than for C.
  39.  
  40.    - Character tables (%T) are not supported; neither are any directives
  41.      to determine internal table sizes (%p, %n, etc.).
  42.  
  43. *)
  44.  
  45. procedure get_line;
  46.   (* obtain line from source file *)
  47.   begin
  48.     readln(yyin, line);
  49.     inc(lno);
  50.   end(*get_line*);
  51.  
  52. procedure next_section;
  53.   (* find next section mark (%%) in code template *)
  54.   var line : String;
  55.   begin
  56.     while not eof(yycod) do
  57.       begin
  58.         readln(yycod, line);
  59.         if line='%%' then exit;
  60.         writeln(yyout, line);
  61.       end;
  62.   end(*next_section*);
  63.  
  64. (* Semantic routines: *)
  65.  
  66. var n_rules : Integer; (* current number of rules *)
  67.  
  68. procedure define_start_state ( symbol : String; pos : Integer );
  69.   (* process start state definition *)
  70.   begin
  71.     with sym_table^[key(symbol, max_keys, lookup, entry)] do
  72.       if sym_type=none then
  73.         begin
  74.           inc(n_start_states);
  75.           if n_start_states>max_start_states then
  76.             fatal(state_table_overflow);
  77.           sym_type    := start_state_sym;
  78.           start_state := n_start_states;
  79.           writeln(yyout, 'const ', symbol, ' = ', 2*start_state, ';');
  80.           first_pos_table^[2*start_state] := newIntSet;
  81.           first_pos_table^[2*start_state+1] := newIntSet;
  82.         end
  83.       else
  84.         error(symbol_already_defined, pos)
  85.   end(*define_start_state*);
  86.  
  87. procedure define_macro ( symbol, replacement : String );
  88.   (* process macro definition *)
  89.   begin
  90.     with sym_table^[key('{'+symbol+'}', max_keys, lookup, entry)] do
  91.       if sym_type=none then
  92.         begin
  93.           sym_type := macro_sym;
  94.           subst    := newStr(replacement);
  95.         end
  96.       else
  97.         error(symbol_already_defined, 1)
  98.   end(*define_macro*);
  99.  
  100. procedure add_rule;
  101.   (* process rule *)
  102.   var i : Integer;
  103.       FIRST : IntSet;
  104.   begin
  105.     addExpr(r, FIRST);
  106.     if n_st=0 then
  107.       if cf then
  108.         setunion(first_pos_table^[1]^, FIRST)
  109.       else
  110.         begin
  111.           setunion(first_pos_table^[0]^, FIRST);
  112.           setunion(first_pos_table^[1]^, FIRST);
  113.         end
  114.     else
  115.       if cf then
  116.         for i := 1 to n_st do
  117.           setunion(first_pos_table^[2*st[i]+1]^, FIRST)
  118.       else
  119.         for i := 1 to n_st do
  120.           begin
  121.             setunion(first_pos_table^[2*st[i]]^, FIRST);
  122.             setunion(first_pos_table^[2*st[i]+1]^, FIRST);
  123.           end
  124.   end(*add_rule*);
  125.  
  126. procedure generate_table;
  127.  
  128.   (* write the DFA table to the output file
  129.  
  130.      Tables are represented as a collection of typed array constants:
  131.  
  132.      type YYTRec = record
  133.                      cc : set of Char; { characters }
  134.                      s  : Integer;     { next state }
  135.                    end;
  136.  
  137.      const
  138.  
  139.      { table sizes: }
  140.  
  141.      yynmarks   = ...;
  142.      yynmatches = ...;
  143.      yyntrans   = ...;
  144.      yynstates  = ...;
  145.  
  146.      { rules of mark positions for each state: }
  147.  
  148.      yyk : array [1..yynmarks] of Integer = ...;
  149.  
  150.      { rules of matches for each state: }
  151.  
  152.      yym : array [1..yynmatches] of Integer = ...;
  153.  
  154.      { transition table: }
  155.  
  156.      yyt : array [1..yyntrans] of YYTRec = ...;
  157.  
  158.      { offsets into the marks, matches and transition tables: }
  159.  
  160.      yykl, yykh,
  161.      yyml, yymh,
  162.      yytl, yyth : array [0..yynstates-1] of Integer = ...;
  163.  
  164.   *)
  165.  
  166.   var yynmarks, yynmatches, yyntrans, yynstates : Integer;
  167.       yykl, yykh,
  168.       yyml, yymh,
  169.       yytl, yyth : array [0..max_states-1] of Integer;
  170.  
  171.   procedure counters;
  172.     (* compute counters and offsets *)
  173.     var s, i : Integer;
  174.     begin
  175.       yynstates := n_states; yyntrans   := n_trans;
  176.       yynmarks  := 0;        yynmatches := 0;
  177.       for s := 0 to n_states-1 do with state_table^[s] do
  178.         begin
  179.           yytl[s] := trans_lo;   yyth[s] := trans_hi;
  180.           yykl[s] := yynmarks+1; yyml[s] := yynmatches+1;
  181.           for i := 1 to size(state_pos^) do
  182.             with pos_table^[state_pos^[i]] do
  183.               if pos_type=mark_pos then
  184.                 if pos=0 then
  185.                   inc(yynmatches)
  186.                 else if pos=1 then
  187.                   inc(yynmarks);
  188.           yykh[s] := yynmarks; yymh[s] := yynmatches;
  189.         end;
  190.     end(*counters*);
  191.  
  192.   procedure writecc(var f : Text; cc : CClass);
  193.     (* print the given character class *)
  194.     function charStr(c : Char) : String;
  195.       begin
  196.         case c of
  197.           #0..#31,     (* nonprintable characters *)
  198.           #127..#255 : charStr := '#'+intStr(ord(c));
  199.           ''''       : charStr := '''''''''';
  200.           else         charStr := ''''+c+'''';
  201.         end;
  202.       end(*charStr*);
  203.     var c1, c2 : Char;
  204.         col : Integer;
  205.         tag : String;
  206.     begin
  207.       write(f, '[ ');
  208.       col := 0;
  209.       for c1:=#0 to #255 do
  210.         if c1 in cc then
  211.           begin
  212.             if col>0 then
  213.               begin
  214.                 write(f, ',');
  215.                 inc(col);
  216.               end;
  217.             if col>40 then
  218.               (* insert line break *)
  219.               begin
  220.                 writeln(f);
  221.                 write(f, ' ':12);
  222.                 col := 0;
  223.               end;
  224.             c2 := c1;
  225.             while (c2<#255) and (succ(c2) in cc) do
  226.               inc(c2);
  227.             if c1=c2 then
  228.               tag := charStr(c1)
  229.             else if c2=succ(c1) then
  230.               tag := charStr(c1)+','+charStr(c2)
  231.             else
  232.               tag := charStr(c1)+'..'+charStr(c2);
  233.             write(f, tag);
  234.             inc(col, length(tag));
  235.             c1 := c2
  236.           end;
  237.       write(f, ' ]');
  238.     end(*writecc*);
  239.  
  240.   procedure tables;
  241.     (* print tables *)
  242.     var s, i, count : Integer;
  243.     begin
  244.       writeln(yyout);
  245.       writeln(yyout, 'type YYTRec = record');
  246.       writeln(yyout, '                cc : set of Char;');
  247.       writeln(yyout, '                s  : Integer;');
  248.       writeln(yyout, '              end;');
  249.       writeln(yyout);
  250.       writeln(yyout, 'const');
  251.       (* table sizes: *)
  252.       writeln(yyout);
  253.       writeln(yyout, 'yynmarks   = ', yynmarks, ';');
  254.       writeln(yyout, 'yynmatches = ', yynmatches, ';');
  255.       writeln(yyout, 'yyntrans   = ', yyntrans, ';');
  256.       writeln(yyout, 'yynstates  = ', yynstates, ';');
  257.       (* mark table: *)
  258.       writeln(yyout);
  259.       writeln(yyout, 'yyk : array [1..yynmarks] of Integer = (');
  260.       count := 0;
  261.       for s := 0 to n_states-1 do with state_table^[s] do
  262.         begin
  263.           writeln(yyout, '  { ', s, ': }');
  264.           for i := 1 to size(state_pos^) do
  265.             with pos_table^[state_pos^[i]] do
  266.               if (pos_type=mark_pos) and (pos=1) then
  267.                 begin
  268.                   write(yyout, '  ', rule); inc(count);
  269.                   if count<yynmarks then write(yyout, ',');
  270.                   writeln(yyout);
  271.                 end;
  272.         end;
  273.       writeln(yyout, ');');
  274.       (* match table: *)
  275.       writeln(yyout);
  276.       writeln(yyout, 'yym : array [1..yynmatches] of Integer = (');
  277.       count := 0;
  278.       for s := 0 to n_states-1 do with state_table^[s] do
  279.         begin
  280.           writeln(yyout, '{ ', s, ': }');
  281.           for i := 1 to size(state_pos^) do
  282.             with pos_table^[state_pos^[i]] do
  283.               if (pos_type=mark_pos) and (pos=0) then
  284.                 begin
  285.                   write(yyout, '  ', rule); inc(count);
  286.                   if count<yynmatches then write(yyout, ',');
  287.                   writeln(yyout);
  288.                 end;
  289.         end;
  290.       writeln(yyout, ');');
  291.       (* transition table: *)
  292.       writeln(yyout);
  293.       writeln(yyout, 'yyt : array [1..yyntrans] of YYTrec = (');
  294.       count := 0;
  295.       for s := 0 to n_states-1 do with state_table^[s] do
  296.         begin
  297.           writeln(yyout, '{ ', s, ': }');
  298.           for i := trans_lo to trans_hi do
  299.             with trans_table^[i] do
  300.               begin
  301.                 write(yyout, '  ( cc: ');
  302.                 writecc(yyout, cc^);
  303.                 write(yyout, '; s: ');
  304.                 write(yyout, next_state, ')');
  305.                 inc(count);
  306.                 if count<yyntrans then write(yyout, ',');
  307.                 writeln(yyout);
  308.               end;
  309.         end;
  310.       writeln(yyout, ');');
  311.       (* offset tables: *)
  312.       writeln(yyout);
  313.       writeln(yyout, 'yykl : array [0..yynstates-1] of Integer = (');
  314.       for s := 0 to n_states-1 do
  315.         begin
  316.           write(yyout, '{ ', s, ': } ', yykl[s]);
  317.           if s<n_states-1 then write(yyout, ',');
  318.           writeln(yyout);
  319.         end;
  320.       writeln(yyout, ');');
  321.       writeln(yyout);
  322.       writeln(yyout, 'yykh : array [0..yynstates-1] of Integer = (');
  323.       for s := 0 to n_states-1 do
  324.         begin
  325.           write(yyout, '{ ', s, ': } ', yykh[s]);
  326.           if s<n_states-1 then write(yyout, ',');
  327.           writeln(yyout);
  328.         end;
  329.       writeln(yyout, ');');
  330.       writeln(yyout);
  331.       writeln(yyout, 'yyml : array [0..yynstates-1] of Integer = (');
  332.       for s := 0 to n_states-1 do
  333.         begin
  334.           write(yyout, '{ ', s, ': } ', yyml[s]);
  335.           if s<n_states-1 then write(yyout, ',');
  336.           writeln(yyout);
  337.         end;
  338.       writeln(yyout, ');');
  339.       writeln(yyout);
  340.       writeln(yyout, 'yymh : array [0..yynstates-1] of Integer = (');
  341.       for s := 0 to n_states-1 do
  342.         begin
  343.           write(yyout, '{ ', s, ': } ', yymh[s]);
  344.           if s<n_states-1 then write(yyout, ',');
  345.           writeln(yyout);
  346.         end;
  347.       writeln(yyout, ');');
  348.       writeln(yyout);
  349.       writeln(yyout, 'yytl : array [0..yynstates-1] of Integer = (');
  350.       for s := 0 to n_states-1 do
  351.         begin
  352.           write(yyout, '{ ', s, ': } ', yytl[s]);
  353.           if s<n_states-1 then write(yyout, ',');
  354.           writeln(yyout);
  355.         end;
  356.       writeln(yyout, ');');
  357.       writeln(yyout);
  358.       writeln(yyout, 'yyth : array [0..yynstates-1] of Integer = (');
  359.       for s := 0 to n_states-1 do
  360.         begin
  361.           write(yyout, '{ ', s, ': } ', yyth[s]);
  362.           if s<n_states-1 then write(yyout, ',');
  363.           writeln(yyout);
  364.         end;
  365.       writeln(yyout, ');');
  366.       writeln(yyout);
  367.     end(*tables*);
  368.  
  369.   begin
  370.     counters; tables;
  371.   end(*generate_table*);
  372.  
  373. (* Parser: *)
  374.  
  375. const
  376.  
  377. max_items = 255;
  378.  
  379. var
  380.  
  381. itemstr : String;
  382. itemc   : Integer;
  383. itempos,
  384. itemlen : array [1..max_items] of Integer;
  385.  
  386. procedure split ( str : String; count : Integer );
  387.   (* split str into at most count whitespace-delimited items
  388.      (result in itemstr, itemc, itempos, itemlen) *)
  389.   procedure scan(var act_pos : Integer);
  390.     (* scan one item *)
  391.     var l : Integer;
  392.     begin
  393.       while (act_pos<=length(itemstr)) and
  394.             ((itemstr[act_pos]=' ') or (itemstr[act_pos]=tab)) do
  395.         inc(act_pos);
  396.       l := 0;
  397.       while (act_pos+l<=length(itemstr)) and
  398.             (itemstr[act_pos+l]<>' ') and (itemstr[act_pos+l]<>tab) do
  399.         inc(l);
  400.       inc(itemc);
  401.       itempos[itemc] := act_pos;
  402.       itemlen[itemc] := l;
  403.       inc(act_pos, l+1);
  404.       while (act_pos<=length(itemstr)) and
  405.             ((itemstr[act_pos]=' ') or (itemstr[act_pos]=tab)) do
  406.         inc(act_pos);
  407.     end(*scan*);
  408.   var i, act_pos : Integer;
  409.   begin
  410.     itemstr := str; act_pos := 1;
  411.     itemc := 0;
  412.     while (itemc<count-1) and (act_pos<=length(itemstr)) do scan(act_pos);
  413.     if act_pos<=length(itemstr) then
  414.       begin
  415.         inc(itemc);
  416.         itempos[itemc] := act_pos;
  417.         itemlen[itemc] := length(itemstr)-act_pos+1;
  418.       end;
  419.   end(*split*);
  420.  
  421. function itemv ( i : Integer ) : String;
  422.   (* return ith item in splitted string (whole string for i=0) *)
  423.   begin
  424.     if i=0 then
  425.       itemv := itemstr
  426.     else if (i<0) or (i>itemc) then
  427.       itemv := ''
  428.     else
  429.       itemv := copy(itemstr, itempos[i], itemlen[i])
  430.   end(*itemv*);
  431.  
  432. procedure code;
  433.   begin
  434.     while not eof(yyin) do
  435.       begin
  436.         get_line;
  437.         if line='%}' then
  438.           exit
  439.         else
  440.           writeln(yyout, line);
  441.       end;
  442.     error(unmatched_lbrace, length(line)+1);
  443.   end(*code*);
  444.  
  445. procedure definitions;
  446.   procedure definition;
  447.     function check_id ( symbol : String ) : Boolean;
  448.       var i : Integer;
  449.       begin
  450.         if (symbol='') or not (symbol[1] in letters) then
  451.           check_id := false
  452.         else
  453.           begin
  454.             for i := 2 to length(symbol) do
  455.               if not (symbol[i] in alphanums) then
  456.                 begin
  457.                   check_id := false;
  458.                   exit;
  459.                 end;
  460.             check_id := true
  461.           end
  462.       end(*check_id*);
  463.     var i : Integer;
  464.     com : String;
  465.     begin
  466.       split(line, 2);
  467.       com := upper(itemv(1));
  468.       if (com='%S') or (com='%START') then
  469.         begin
  470.           split(line, max_items);
  471.           for i := 2 to itemc do
  472.             if check_id(itemv(i)) then
  473.               define_start_state(itemv(i), itempos[i])
  474.             else
  475.               error(syntax_error, itempos[i]);
  476.         end
  477.       else if check_id(itemv(1)) then
  478.         define_macro(itemv(1), itemv(2))
  479.       else
  480.         error(syntax_error, 1);
  481.     end(*definition*);
  482.   begin
  483.     while not eof(yyin) do
  484.       begin
  485.         get_line;
  486.         if line='' then
  487.           writeln(yyout)
  488.         else if line='%%' then
  489.           exit
  490.         else if line='%{' then
  491.           code
  492.         else if (line[1]='%') or (line[1] in letters) then
  493.           definition
  494.         else
  495.           writeln(yyout, line)
  496.       end;
  497.   end(*definitions*);
  498.  
  499. procedure rules;
  500.   begin
  501.     next_section;
  502.     if line='%%' then
  503.       while not eof(yyin) do
  504.         begin
  505.           get_line;
  506.           if line='' then
  507.             writeln(yyout)
  508.           else if line='%%' then
  509.             begin
  510.               next_section;
  511.               exit;
  512.             end
  513.           else if line='%{' then
  514.             code
  515.           else if (line[1]<>' ') and (line[1]<>tab) then
  516.             begin
  517.               if n_rules=0 then next_section;
  518.               inc(n_rules);
  519.               parse_rule(n_rules);
  520.               if errors=0 then
  521.                 begin
  522.                   add_rule;
  523.                   write(yyout, '  ', n_rules);
  524.                   if strip(stmt)='|' then
  525.                     writeln(yyout, ',')
  526.                   else
  527.                     begin
  528.                       writeln(yyout, ':');
  529.                       writeln(yyout, blankStr(expr), stmt);
  530.                     end;
  531.                 end
  532.             end
  533.           else
  534.             writeln(yyout, line)
  535.         end
  536.     else
  537.       error(unexpected_eof, length(line)+1);
  538.     next_section;
  539.   end(*rules*);
  540.  
  541. procedure auxiliary_procs;
  542.   begin
  543.     if line='%%' then
  544.       begin
  545.         writeln(yyout);
  546.         while not eof(yyin) do
  547.           begin
  548.             get_line;
  549.             writeln(yyout, line);
  550.           end;
  551.       end;
  552.   end(*auxiliary_procs*);
  553.  
  554. (* Main program: *)
  555.  
  556. var i : Integer;
  557.  
  558. begin
  559.  
  560.   (* sign-on: *)
  561.  
  562.   writeln(sign_on);
  563.  
  564.   (* parse command line: *)
  565.  
  566.   if paramCount=0 then
  567.     begin
  568.       writeln(usage);
  569.       writeln(options);
  570.       halt(0);
  571.     end;
  572.  
  573.   lfilename := '';
  574.   pasfilename := '';
  575.  
  576.   for i := 1 to paramCount do
  577.     if copy(paramStr(i), 1, 1)='/' then
  578.       if upper(paramStr(i))='/V' then
  579.         verbose := true
  580.       else if upper(paramStr(i))='/O' then
  581.         optimize := true
  582.       else
  583.         begin
  584.           writeln(invalid_option, paramStr(i));
  585.           halt(1);
  586.         end
  587.     else if lfilename='' then
  588.       lfilename := addExt(upper(paramStr(i)), 'L')
  589.     else if pasfilename='' then
  590.       pasfilename := addExt(upper(paramStr(i)), 'PAS')
  591.     else
  592.       begin
  593.         writeln(illegal_no_args);
  594.         halt(1);
  595.       end;
  596.  
  597.   if lfilename='' then
  598.     begin
  599.       writeln(illegal_no_args);
  600.       halt(1);
  601.     end;
  602.  
  603.   if pasfilename='' then pasfilename := root(lfilename)+'.PAS';
  604.   lstfilename := root(lfilename)+'.LST';
  605.  
  606.   (* open files: *)
  607.  
  608.   assign(yyin, lfilename);
  609.   assign(yyout, pasfilename);
  610.   assign(yylst, lstfilename);
  611.  
  612.   reset(yyin);    if ioresult<>0 then fatal(cannot_open_file+lfilename);
  613.   rewrite(yyout); if ioresult<>0 then fatal(cannot_open_file+pasfilename);
  614.   rewrite(yylst); if ioresult<>0 then fatal(cannot_open_file+lstfilename);
  615.  
  616.   (* search code template in current directory, then on path where Lex
  617.      was executed from: *)
  618.   codfilename := 'YYLEX.COD';
  619.   assign(yycod, codfilename);
  620.   reset(yycod);
  621.   if ioresult<>0 then
  622.     begin
  623.       codfilename := upper(path(paramStr(0)))+'YYLEX.COD';
  624.       assign(yycod, codfilename);
  625.       reset(yycod);
  626.       if ioresult<>0 then fatal(cannot_open_file+codfilename);
  627.     end;
  628.  
  629.   (* parse source grammar: *)
  630.  
  631.   write('parse ... ');
  632.   lno := 0; n_rules := 0; next_section;
  633.   first_pos_table^[0] := newIntSet;
  634.   first_pos_table^[1] := newIntSet;
  635.   definitions;
  636.   rules;
  637.   if n_rules=0 then error(empty_grammar, length(line)+1);
  638.   if errors=0 then
  639.     begin
  640.       (* generate DFA table and listings and write output code: *)
  641.       write('DFA construction ... ');
  642.       makeDFATable;
  643.       if optimize then
  644.         begin
  645.           write('DFA optimization ... ');
  646.           optimizeDFATable;
  647.         end;
  648.       write('code generation ... ');
  649.       if verbose then listDFATable;
  650.       generate_table; next_section;
  651.     end;
  652.   auxiliary_procs;
  653.   if errors=0 then writeln('DONE');
  654.  
  655.   (* close files: *)
  656.  
  657.   close(yyin); close(yyout); close(yylst); close(yycod);
  658.  
  659.   (* print statistics: *)
  660.  
  661.   if errors>0 then
  662.     writeln( lno, ' lines, ',
  663.              errors, ' errors found.' )
  664.   else
  665.     writeln( lno, ' lines, ',
  666.              n_rules, ' rules, ',
  667.              n_pos, '/', max_pos, ' p, ',
  668.              n_states, '/', max_states, ' s, ',
  669.              n_trans, '/', max_trans, ' t.');
  670.  
  671.   if warnings>0 then writeln(warnings, ' warnings.');
  672.  
  673.   writeln( n_bytes, '/', max_bytes, ' bytes of memory used.');
  674.  
  675.   (* terminate: *)
  676.  
  677.   if errors>0 then erase(yyout);
  678.   if file_size(lstfilename)=0 then
  679.     erase(yylst)
  680.   else
  681.     writeln('(see ', lstfilename, ' for more information)');
  682.  
  683.   halt(errors);
  684.  
  685. end(*Lex*).
  686.