lex.pas

Yacc例子代码

{
  TP Lex - A lexical analyzer generator for Turbo Pascal


  Copyright (c) 1990-92  Albert Graef <[e-mail]>
  Copyright (C) 1996     Berend de Boer <[e-mail]>

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


$Revision: 2 $
$Modtime: 96-08-01 10:22 $

$History: LEX.PAS $
 * 
 * *****************  Version 2  *****************
 * User: Berend       Date: 96-10-10   Time: 21:16
 * Updated in $/Lex and Yacc/tply
 * Updated for protected mode, windows and Delphi 1.X and 2.X.


------------------------- Synopsis ------------------------

   Synopsis   lex [options] lex-file[.l] [output-file[.pas]]

   Options

   -v  "Verbose:" Lex generates a readable description of the generated
       lexical analyzer, written to lex-file with new extension .LST.

   -o  "Optimize:" Lex optimizes DFA tables to produce a minimal DFA

   Description

   This is a reimplementation of the popular UNIX lexical analyzer generator
   Lex for MS-DOS and Turbo Pascal.

   Differences from UNIX Lex:

   - Produces output code for Turbo Pascal, rather than for C.

   - Character tables (%T) are not supported; neither are any directives
     to determine internal table sizes (%p, %n, etc.).

------------------------- Synopsis ------------------------

}

{$IFDEF MsDos}
{$M 16384,0,655360}
{$ENDIF}
{$IFDEF DPMI}
{$M 32768}
{$ENDIF}
{$IFDEF Windows}
{$M 32768,0}
{$ENDIF}

{$I-}
program Lex;

uses
{$IFDEF Windows}
  WinCrt,
{$ENDIF}
  LexBase, LexTable, LexPos, LexDFA, LexOpt, LexList, LexRules, LexMsgs;


procedure get_line;
  (* obtain line from source file *)
  begin
    readln(yyin, line);
    inc(lno);
  end(*get_line*);

procedure next_section;
  (* find next section mark (%%) in code template *)
  var line : String;
  begin
    while not eof(yycod) do
      begin
        readln(yycod, line);
        if line='%%' then exit;
        writeln(yyout, line);
      end;
  end(*next_section*);

(* Semantic routines: *)

var n_rules : Integer; (* current number of rules *)

procedure define_start_state ( symbol : String; pos : Integer );
  (* process start state definition *)
  begin
{$ifdef fpc}
    with sym_table^[key(symbol, max_keys, @lookup, @entry)] do
{$else}
    with sym_table^[key(symbol, max_keys, lookup, entry)] do
{$endif}
      if sym_type=none then
        begin
          inc(n_start_states);
          if n_start_states>max_start_states then
            fatal(state_table_overflow);
          sym_type    := start_state_sym;
          start_state := n_start_states;
          writeln(yyout, 'const ', symbol, ' = ', 2*start_state, ';');
          first_pos_table^[2*start_state] := newIntSet;
          first_pos_table^[2*start_state+1] := newIntSet;
        end
      else
        error(symbol_already_defined, pos)
  end(*define_start_state*);

procedure define_macro ( symbol, replacement : String );
  (* process macro definition *)
  begin
{$ifdef fpc}
    with sym_table^[key('{'+symbol+'}', max_keys, @lookup, @entry)] do
{$else}
    with sym_table^[key('{'+symbol+'}', max_keys, lookup, entry)] do
{$endif}
      if sym_type=none then
        begin
          sym_type := macro_sym;
          subst    := newStr(strip(replacement));
        end
      else
        error(symbol_already_defined, 1)
  end(*define_macro*);

procedure add_rule;
  (* process rule *)
  var i : Integer;
      FIRST : IntSet;
  begin
    addExpr(r, FIRST);
    if n_st=0 then
      if cf then
        setunion(first_pos_table^[1]^, FIRST)
      else
        begin
          setunion(first_pos_table^[0]^, FIRST);
          setunion(first_pos_table^[1]^, FIRST);
        end
    else
      if cf then
        for i := 1 to n_st do
          setunion(first_pos_table^[2*st[i]+1]^, FIRST)
      else
        for i := 1 to n_st do
          begin
            setunion(first_pos_table^[2*st[i]]^, FIRST);
            setunion(first_pos_table^[2*st[i]+1]^, FIRST);
          end
  end(*add_rule*);

procedure generate_table;

  (* write the DFA table to the output file

     Tables are represented as a collection of typed array constants:

     type YYTRec = record
                     cc : set of Char; { characters }
                     s  : Integer;     { next state }
                   end;

     const

     { table sizes: }

     yynmarks   = ...;
     yynmatches = ...;
     yyntrans   = ...;
     yynstates  = ...;

     { rules of mark positions for each state: }

     yyk : array [1..yynmarks] of Integer = ...;

     { rules of matches for each state: }

     yym : array [1..yynmatches] of Integer = ...;

     { transition table: }

     yyt : array [1..yyntrans] of YYTRec = ...;

     { offsets into the marks, matches and transition tables: }

     yykl, yykh,
     yyml, yymh,
     yytl, yyth : array [0..yynstates-1] of Integer = ...;

  *)

  var yynmarks, yynmatches, yyntrans, yynstates : Integer;
      yykl, yykh,
      yyml, yymh,
      yytl, yyth : array [0..max_states-1] of Integer;

  procedure counters;
    (* compute counters and offsets *)
    var s, i : Integer;
    begin
      yynstates := n_states; yyntrans   := n_trans;
      yynmarks  := 0;        yynmatches := 0;
      for s := 0 to n_states-1 do with state_table^[s] do
        begin
          yytl[s] := trans_lo;   yyth[s] := trans_hi;
          yykl[s] := yynmarks+1; yyml[s] := yynmatches+1;
          for i := 1 to size(state_pos^) do
            with pos_table^[state_pos^[i]] do
              if pos_type=mark_pos then
                if pos=0 then
                  inc(yynmatches)
                else if pos=1 then
                  inc(yynmarks);
          yykh[s] := yynmarks; yymh[s] := yynmatches;
        end;
    end(*counters*);

  procedure writecc(var f : Text; cc : CClass);
    (* print the given character class *)
    function charStr(c : Char) : String;
      begin
        case c of
          #0..#31,     (* nonprintable characters *)
          #127..#255 : charStr := '#'+intStr(ord(c));
          ''''       : charStr := '''''''''';
          else         charStr := ''''+c+'''';
        end;
      end(*charStr*);
    const
      MaxChar = #255;
    var
      c1, c2 : Char;
      col : Integer;
      tag : String;
      Quit: Boolean;
    begin
      write(f, '[ ');
      col := 0;
      c1 := chr(0);
      Quit := False;
      while not Quit do begin
        if c1 in cc then  begin
          if col>0 then
	    begin
	      write(f, ',');
	      inc(col);
	    end;
	  if col>40 then
	    { insert line break }
	    begin
	      writeln(f);
	      write(f, ' ':12);
	      col := 0;
	    end;
	  c2 := c1;
	  while (c2<MaxChar) and (succ(c2) in cc) do
	    c2 := succ(c2);
	  if c1=c2 then
	    tag := charStr(c1)
	  else if c2=succ(c1) then
	    tag := charStr(c1)+','+charStr(c2)
	  else
	    tag := charStr(c1)+'..'+charStr(c2);
	  write(f, tag);
	  col := col + length(tag);
          c1 := c2;
	end;
        Quit := c1 = MaxChar;
        if not Quit then
          c1 := Succ(c1);
      end; { of while }
      write(f, ' ]');
    end(*writecc*);

  procedure tables;
    (* print tables *)
    var s, i, count : Integer;
    begin
      writeln(yyout);
      writeln(yyout, 'type YYTRec = record');
      writeln(yyout, '                cc : set of Char;');
      writeln(yyout, '                s  : Integer;');
      writeln(yyout, '              end;');
      writeln(yyout);
      writeln(yyout, 'const');
      (* table sizes: *)
      writeln(yyout);
      writeln(yyout, 'yynmarks   = ', yynmarks, ';');
      writeln(yyout, 'yynmatches = ', yynmatches, ';');
      writeln(yyout, 'yyntrans   = ', yyntrans, ';');
      writeln(yyout, 'yynstates  = ', yynstates, ';');
      (* mark table: *)
      writeln(yyout);
      writeln(yyout, 'yyk : array [1..yynmarks] of Integer = (');
      count := 0;
      for s := 0 to n_states-1 do with state_table^[s] do
        begin
          writeln(yyout, '  { ', s, ': }');
          for i := 1 to size(state_pos^) do
            with pos_table^[state_pos^[i]] do
              if (pos_type=mark_pos) and (pos=1) then
                begin
                  write(yyout, '  ', rule); inc(count);
                  if count<yynmarks then write(yyout, ',');
                  writeln(yyout);
                end;
        end;
      writeln(yyout, ');');
      (* match table: *)
      writeln(yyout);
      writeln(yyout, 'yym : array [1..yynmatches] of Integer = (');
      count := 0;
      for s := 0 to n_states-1 do with state_table^[s] do
        begin
          writeln(yyout, '{ ', s, ': }');
          for i := 1 to size(state_pos^) do
            with pos_table^[state_pos^[i]] do
              if (pos_type=mark_pos) and (pos=0) then
                begin
                  write(yyout, '  ', rule); inc(count);
                  if count<yynmatches then write(yyout, ',');
                  writeln(yyout);
                end;
        end;
      writeln(yyout, ');');
      (* transition table: *)
      writeln(yyout);
      writeln(yyout, 'yyt : array [1..yyntrans] of YYTrec = (');
      count := 0;
      for s := 0 to n_states-1 do with state_table^[s] do
        begin
          writeln(yyout, '{ ', s, ': }');
          for i := trans_lo to trans_hi do
            with trans_table^[i] do
              begin
                write(yyout, '  ( cc: ');
                writecc(yyout, cc^);
                write(yyout, '; s: ');
                write(yyout, next_state, ')');
                inc(count);
                if count<yyntrans then write(yyout, ',');
                writeln(yyout);
              end;
        end;
      writeln(yyout, ');');
      (* offset tables: *)
      writeln(yyout);
      writeln(yyout, 'yykl : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yykl[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);