yacctabl.pas

Yacc例子代码

     symbol 0, `$accept' for nonterminal -1, and a single quoted
     character for literals 1..255) *)

(* Rule table routines: *)

function newRuleRec ( r : RuleRec ) : RuleRecPtr;
  (* obtains a dynamic copy of r (only the number of bytes actually
     needed is allocated) *)

procedure add_rule ( r : RuleRecPtr );
  (* add a rule to the rule table *)

procedure sort_rules;
  (* sorts rules w.r.t. left-hand sides into the rule no table *)

procedure rule_offsets;
  (* computes rule offsets after rules have been sorted *)

function n_nt_rules ( sym : Integer ) : Integer;
  (* returns number of rules for nonterminal sym *)

(* Type Table routines: *)

procedure add_type ( k : Integer );
  (* add a type identifier to the table *)

procedure sort_types;
  (* sort the type table alphabetically, eliminate dups *)

function search_type ( symbol : String ) : Boolean;
  (* search the sorted types table for the given type symbol *)

(* Precedence table routines: *)

function new_prec_level ( prec_type : PrecType ) : Integer;
  (* adds a new precedence level of the denoted type; returns: the new
     level *)

(* State table routines: *)

var act_state : Integer; (* state currently considered *)

procedure new_state;
  (* build a new state *)

procedure add_item ( rule_no, pos_no : Integer );
  (* add an item to the new state (initialize its next field to 0) *)

function add_state : Integer;
  (* add the new state to the state table; if an equivalent state is already
     in the table, dispose the new state, and return the existing state
     number, otherwise return the new state number *)

procedure start_trans;
  (* starts building transitions of the active state *)

procedure add_trans ( sym, next_state : Integer );
  (* adds a transition to the active state *)

procedure end_trans;
  (* ends transitions of the active state *)

procedure start_redns;
  (* starts building reduction actions of the active state *)

procedure add_redn ( symset : IntSetPtr; rule_no : Integer );
  (* adds a reduction to the active state *)

procedure end_redns;
  (* ends reduction actions of the active state *)

function n_state_items ( s : Integer ) : Integer;
function n_state_trans ( s : Integer ) : Integer;
function n_state_redns ( s : Integer ) : Integer;
  (* return the number of kernel items, transitions and reductions in state
     s, respectively *)

function find_item( s : Integer; rule_no, pos_no : Integer ) : Integer;
  (* find item (rule_no, pos_no) in state s; returns: the item number *)

(* Item set routines: *)

procedure empty_item_set ( var item_set : ItemSet );
  (* initializes an empty item set *)

procedure include_item_set ( var item_set : ItemSet;
                             rule_no, pos_no : Integer);
  (* add the denoted item to the given item set *)

procedure get_item_set ( s : Integer; var item_set : ItemSet);
  (* obtain the item set of state s from the item table *)

procedure closure ( var item_set : ItemSet );
  (* compute the closure of item_set (using the closure table) *)

procedure sort_item_set ( var item_set : ItemSet );
  (* sorts an item set w.r.t. position and rule numbers (higher positions,
     lower rules first) *)

implementation

uses YaccMsgs;

{$IFNDEF Win32}
function n_bytes : LongInt;
  begin
    n_bytes := max_bytes-memAvail
  end(*n_bytes*);
{$ENDIF}

(* Symbol table routines: *)

function new_nt : Integer;
  begin
    inc(n_nts);
    if n_nts>max_nts then fatal(nt_table_overflow);
    sym_type^[-n_nts] := 0;
    new_nt := -n_nts;
  end(*new_nt*);

function new_lit : Integer;
  begin
    inc(n_lits);
    if n_lits>max_lits then fatal(lit_table_overflow);
    sym_type^[n_lits-1] := 0;
    sym_prec^[n_lits-1] := 0;
    new_lit := n_lits-1;
  end(*new_lit*);

procedure add_lit ( sym : Integer );
  begin
    if sym>n_lits then n_lits := sym;
    if n_lits>max_lits then fatal(lit_table_overflow);
    sym_type^[sym] := 0;
    sym_prec^[sym] := 0;
  end(*add_lit*);

{$ifndef fpc}{$F+}{$endif}
function lookup(k : Integer) : String;
{$ifndef fpc}{$F-}{$endif}
  (* print name of symbol no. k *)
  begin
    with sym_table^[k] do
      if pname=nil then
        lookup := ''
      else
        lookup := pname^
  end(*lookup*);

{$ifndef fpc}{$F+}{$endif}
procedure entry(k : Integer; symbol : String);
{$ifndef fpc}{$F-}{$endif}
  (* enter symbol into table *)
  begin
    sym_table^[k].pname := newStr(symbol);
  end(*entry*);

function get_key ( symbol : String ) : Integer;
  begin
    get_key := key(symbol, max_keys, {$ifdef fpc}@{$endif}lookup,
		   {$ifdef fpc}@{$endif}entry);
  end(*get_key*);

procedure def_key ( k : Integer; sym : Integer );
  begin
    sym_key^[sym] := k;
    sym_table^[k].deff := true;
    sym_table^[k].sym  := sym;
  end(*def_key*);

function is_def_key ( k : Integer; var sym : Integer ) : Boolean;
  begin
    if sym_table^[k].deff then
      begin
        sym := sym_table^[k].sym;
        is_def_key := true;
      end
    else
      is_def_key := false
  end(*is_def_key*);

function pname ( sym : Integer ) : String;
begin
  case sym of
    1..255 : pname := singleQuoteStr(chr(sym));
    0      : pname := '$end';
    -1     : pname := '$accept';
  else  begin
    if sym_table^[sym_key^[sym]].pname^[1]=''''
      then  begin
        pname := singleQuoteStr(
                   copy( sym_table^[sym_key^[sym]].pname^,
                         2,
                         length(sym_table^[sym_key^[sym]].pname^)-2)
                 )
      end
      else  begin
        pname := sym_table^[sym_key^[sym]].pname^;
      end;
  end;
  end;
end(*pname*);

(* Rule table: *)

function newRuleRec ( r : RuleRec ) : RuleRecPtr;
  var rp : RuleRecPtr;
  begin
    getmem(rp, 2*sizeOf(Integer)+r.rhs_len*sizeOf(Integer));
    move(r, rp^, 2*sizeOf(Integer)+r.rhs_len*sizeOf(Integer));
    newRuleRec := rp;
  end(*newRuleRec*);

procedure add_rule ( r : RuleRecPtr );
  begin
    inc(n_rules);
    if n_rules>max_rules then fatal(rule_table_overflow);
    rule_table^[n_rules] := r;
  end(*add_rule*);

{$ifndef fpc}{$F+}{$endif}
function rule_less ( i, j : Integer ) : Boolean;
{$ifndef fpc}{$F-}{$endif}
  begin
    if rule_table^[rule_no^[i]]^.lhs_sym =
       rule_table^[rule_no^[j]]^.lhs_sym then
      rule_less := rule_no^[i] < rule_no^[j]
    else
      rule_less := rule_table^[rule_no^[i]]^.lhs_sym >
                   rule_table^[rule_no^[j]]^.lhs_sym
  end(*rule_less*);

{$ifndef fpc}{$F+}{$endif}
procedure rule_swap ( i, j : Integer );
{$ifndef fpc}{$F-}{$endif}
  var x : Integer;
  begin
    x := rule_no^[i]; rule_no^[i] := rule_no^[j]; rule_no^[j] := x;
  end(*rule_swap*);

procedure sort_rules;
  var i : Integer;
  begin
    for i := 1 to n_rules do rule_no^[i] := i;
    quicksort ( 1, n_rules, {$ifdef fpc}@{$endif}rule_less,
	       {$ifdef fpc}@{$endif}rule_swap );
  end(*sort_rules*);

procedure rule_offsets;
  var i, sym : Integer;
  begin
    for sym := 1 to n_nts do with rule_offs^[sym] do
      begin
        rule_lo := 1; rule_hi := 0;
      end;
    i := 1;
    while (i<=n_rules) do
      begin
        sym := rule_table^[rule_no^[i]]^.lhs_sym;
        rule_offs^[-sym].rule_lo := i;
        inc(i);
        while (i<=n_rules) and
              (rule_table^[rule_no^[i]]^.lhs_sym=sym) do
          inc(i);
        rule_offs^[-sym].rule_hi := i-1;
      end;
  end(*rule_offsets*);

function n_nt_rules ( sym : Integer ) : Integer;
  begin
    with rule_offs^[-sym] do
      n_nt_rules := rule_hi-rule_lo+1
  end(*n_nt_rules*);

(* Type Table routines: *)

procedure add_type ( k : Integer );
  begin
    inc(n_types);
    if n_types>max_types then fatal(type_table_overflow);
    type_table^[n_types] := k;
  end(*add_type*);

(* Routines to sort type identifiers alphabetically: *)

{$ifndef fpc}{$F+}{$endif}
function type_less ( i, j : Integer ) : Boolean;
{$ifndef fpc}{$F-}{$endif}
  begin
    type_less := sym_table^[type_table^[i]].pname^<
                 sym_table^[type_table^[j]].pname^
  end(*type_less*);

{$ifndef fpc}{$F+}{$endif}
procedure type_swap ( i, j : Integer );
{$ifndef fpc}{$F-}{$endif}
  var x : Integer;
  begin
    x := type_table^[i];
    type_table^[i] := type_table^[j];
    type_table^[j] := x;
  end(*type_swap*);

procedure sort_types;
  var i, j, count : Integer;
  begin
    (* sort: *)
    quicksort(1, n_types, {$ifdef fpc}@{$endif}type_less,
	      {$ifdef fpc}@{$endif}type_swap);
    (* eliminate dups: *)
    i := 1; j := 1; count := 0;
    while i<=n_types do
      begin
        if i<>j then type_table^[j] := type_table^[i];
        while (i<n_types) and (type_table^[i+1]=type_table^[i]) do
          begin
            inc(i); inc(count);
          end;
        inc(i); inc(j);
      end;
    dec(n_types, count);
  end(*sort_types*);

function search_type ( symbol : String ) : Boolean;
  var l, r, k : Integer;
  begin
    (* binary search: *)
    l := 1; r := n_types;
    k := l + (r-l) div 2;
    while (l<r) and (sym_table^[type_table^[k]].pname^<>symbol) do