lex.pas

Yacc例子代码

      writeln(yyout, 'yykh : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yykh[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);
      writeln(yyout, 'yyml : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yyml[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);
      writeln(yyout, 'yymh : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yymh[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);
      writeln(yyout, 'yytl : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yytl[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);
      writeln(yyout, 'yyth : array [0..yynstates-1] of Integer = (');
      for s := 0 to n_states-1 do
        begin
          write(yyout, '{ ', s, ': } ', yyth[s]);
          if s<n_states-1 then write(yyout, ',');
          writeln(yyout);
        end;
      writeln(yyout, ');');
      writeln(yyout);
    end(*tables*);

  begin
    counters; tables;
  end(*generate_table*);

(* Parser: *)

const

max_items = 255;

var

itemstr : String;
itemc   : Integer;
itempos,
itemlen : array [1..max_items] of Integer;

procedure split ( str : String; count : Integer );
  (* split str into at most count whitespace-delimited items
     (result in itemstr, itemc, itempos, itemlen) *)
  procedure scan(var act_pos : Integer);
    (* scan one item *)
    var l : Integer;
    begin
      while (act_pos<=length(itemstr)) and
            ((itemstr[act_pos]=' ') or (itemstr[act_pos]=tab)) do
        inc(act_pos);
      l := 0;
      while (act_pos+l<=length(itemstr)) and
            (itemstr[act_pos+l]<>' ') and (itemstr[act_pos+l]<>tab) do
        inc(l);
      inc(itemc);
      itempos[itemc] := act_pos;
      itemlen[itemc] := l;
      inc(act_pos, l+1);
      while (act_pos<=length(itemstr)) and
            ((itemstr[act_pos]=' ') or (itemstr[act_pos]=tab)) do
        inc(act_pos);
    end(*scan*);
  var act_pos : Integer;
  begin
    itemstr := str; act_pos := 1;
    itemc := 0;
    while (itemc<count-1) and (act_pos<=length(itemstr)) do scan(act_pos);
    if act_pos<=length(itemstr) then
      begin
        inc(itemc);
        itempos[itemc] := act_pos;
        itemlen[itemc] := length(itemstr)-act_pos+1;
      end;
  end(*split*);

function itemv ( i : Integer ) : String;
  (* return ith item in splitted string (whole string for i=0) *)
  begin
    if i=0 then
      itemv := itemstr
    else if (i<0) or (i>itemc) then
      itemv := ''
    else
      itemv := copy(itemstr, itempos[i], itemlen[i])
  end(*itemv*);

procedure code;
  begin
    while not eof(yyin) do
      begin
        get_line;
        if line='%}' then
          exit
        else
          writeln(yyout, line);
      end;
    error(unmatched_lbrace, length(line)+1);
  end(*code*);

procedure definitions;
  procedure definition;
    function check_id ( symbol : String ) : Boolean;
      var i : Integer;
      begin
        if (symbol='') or not (symbol[1] in letters) then
          check_id := false
        else
          begin
            for i := 2 to length(symbol) do
              if not (symbol[i] in alphanums) then
                begin
                  check_id := false;
                  exit;
                end;
            check_id := true
          end
      end(*check_id*);
    var i : Integer;
	com : String;
    begin
      split(line, 2);
      com := upper(itemv(1));
      if (com='%S') or (com='%START') then
        begin
          split(line, max_items);
          for i := 2 to itemc do
            if check_id(itemv(i)) then
              define_start_state(itemv(i), itempos[i])
            else
              error(syntax_error, itempos[i]);
        end
      else if check_id(itemv(1)) then
        define_macro(itemv(1), itemv(2))
      else
        error(syntax_error, 1);
    end(*definition*);
  begin
    while not eof(yyin) do
      begin
        get_line;
        if line='' then
          writeln(yyout)
        else if line='%%' then
          exit
        else if line='%{' then
          code
        else if (line[1]='%') or (line[1] in letters) then
          definition
        else
          writeln(yyout, line)
      end;
  end(*definitions*);

procedure rules;
  begin
    next_section;
    if line='%%' then
      while not eof(yyin) do
        begin
          get_line;
          if line='' then
            writeln(yyout)
          else if line='%%' then
            begin
              next_section;
              exit;
            end
          else if line='%{' then
            code
          else if (line[1]<>' ') and (line[1]<>tab) then
            begin
              if n_rules=0 then next_section;
              inc(n_rules);
              parse_rule(n_rules);
              if errors=0 then
                begin
                  add_rule;
                  write(yyout, '  ', n_rules);
                  if strip(stmt)='|' then
                    writeln(yyout, ',')
                  else
                    begin
                      writeln(yyout, ':');
                      writeln(yyout, blankStr(expr), stmt);
                    end;
                end
            end
          else
            writeln(yyout, line)
        end
    else
      error(unexpected_eof, length(line)+1);
    next_section;
  end(*rules*);

procedure auxiliary_procs;
  begin
    if line='%%' then
      begin
        writeln(yyout);
        while not eof(yyin) do
          begin
            get_line;
            writeln(yyout, line);
          end;
      end;
  end(*auxiliary_procs*);

(* Main program: *)

var i : Integer;

begin
{$ifdef linux}
  codfilepath:='/usr/lib/fpc/lexyacc/';
{$else}
  codfilepath:=path(paramstr(0));
{$endif}

  (* sign-on: *)

  writeln(sign_on);

  (* parse command line: *)

  if paramCount=0 then
    begin
      writeln(usage);
      writeln(options);
      halt(0);
    end;

  lfilename := '';
  pasfilename := '';

  for i := 1 to paramCount do
    if copy(paramStr(i), 1, 1)='-' then
      if upper(paramStr(i))='-V' then
        verbose := true
      else if upper(paramStr(i))='-O' then
        optimize := true
      else
        begin
          writeln(invalid_option, paramStr(i));
          halt(1);
        end
    else if lfilename='' then
      lfilename := addExt(paramStr(i), 'l')
    else if pasfilename='' then
      pasfilename := addExt(paramStr(i), 'pas')
    else
      begin
        writeln(illegal_no_args);
        halt(1);
      end;

  if lfilename='' then
    begin
      writeln(illegal_no_args);
      halt(1);
    end;

  if pasfilename='' then pasfilename := root(lfilename)+'.pas';
  lstfilename := root(lfilename)+'.lst';

  (* open files: *)

  assign(yyin, lfilename);
  assign(yyout, pasfilename);
  assign(yylst, lstfilename);

  reset(yyin);    if ioresult<>0 then fatal(cannot_open_file+lfilename);
  rewrite(yyout); if ioresult<>0 then fatal(cannot_open_file+pasfilename);
  rewrite(yylst); if ioresult<>0 then fatal(cannot_open_file+lstfilename);

  (* search code template in current directory, then on path where Lex
     was executed from: *)
  codfilename := 'yylex.cod';
  assign(yycod, codfilename);
  reset(yycod);
  if ioresult<>0 then
    begin
      codfilename := codfilepath+'yylex.cod';
      assign(yycod, codfilename);
      reset(yycod);
      if ioresult<>0 then fatal(cannot_open_file+codfilename);
    end;

  (* parse source grammar: *)

  write('parse ... ');
  lno := 0; n_rules := 0; next_section;
  first_pos_table^[0] := newIntSet;
  first_pos_table^[1] := newIntSet;
  definitions;
  rules;
  if n_rules=0 then error(empty_grammar, length(line)+1);
  if errors=0 then
    begin
      (* generate DFA table and listings and write output code: *)
      write('DFA construction ... ');
      makeDFATable;
      if optimize then
        begin
          write('DFA optimization ... ');
          optimizeDFATable;
        end;
      write('code generation ... ');
      if verbose then listDFATable;
      generate_table; next_section;
    end;
  auxiliary_procs;
  if errors=0 then writeln('DONE');

  (* close files: *)

  close(yyin); close(yyout); close(yylst); close(yycod);

  (* print statistics: *)

  if errors>0 then
    writeln( lno, ' lines, ',
             errors, ' errors found.' )
  else
    writeln( lno, ' lines, ',
             n_rules, ' rules, ',
             n_pos, '/', max_pos, ' p, ',
             n_states, '/', max_states, ' s, ',
             n_trans, '/', max_trans, ' t.');

  if warnings>0 then writeln(warnings, ' warnings.');

{$ifndef fpc}
{$IFNDEF Win32}
  writeln( n_bytes, '/', max_bytes, ' bytes of memory used.');
{$ENDIF}
{$endif}

  (* terminate: *)

  if errors>0 then erase(yyout);
  if file_size(lstfilename)=0 then
    erase(yylst)
  else
    writeln('(see ', lstfilename, ' for more information)');

  halt(errors);

end(*Lex*).