lexbase.pas

Yacc例子代码

      end;
  end(*include*);

procedure exclude(var M : IntSet; i : Integer);
  var l, r, k : Integer;
  begin
    (* binary search: *)
    l := 1; r := M[0];
    k := l + (r-l) div 2;
    while (l<r) and (M[k]<>i) do
      begin
        if M[k]<i then
          l := succ(k)
        else
          r := pred(k);
        k := l + (r-l) div 2;
      end;
    if (k<=M[0]) and (M[k]=i) then
      begin
        move(M[k+1], M[k], (M[0]-k)*sizeOf(Integer));
        dec(M[0]);
      end;
  end(*exclude*);

procedure setunion(var M, N : IntSet);
  var
    K : IntSet;
    i, j, i_M, i_N : Integer;
  begin
    (* merge sort: *)
    i := 0; i_M := 1; i_N := 1;
    while (i_M<=M[0]) and (i_N<=N[0]) do
      begin
        inc(i);
        if i>max_elems then fatal(intset_overflow);
        if M[i_M]<N[i_N] then
          begin
            K[i] := M[i_M]; inc(i_M);
          end
        else if N[i_N]<M[i_M] then
          begin
            K[i] := N[i_N]; inc(i_N);
          end
        else
          begin
            K[i] := M[i_M]; inc(i_M); inc(i_N);
          end
      end;
    for j := i_M to M[0] do
      begin
        inc(i);
        if i>max_elems then fatal(intset_overflow);
        K[i] := M[j];
      end;
    for j := i_N to N[0] do
      begin
        inc(i);
        if i>max_elems then fatal(intset_overflow);
        K[i] := N[j];
      end;
    K[0] := i;
    move(K, M, succ(i)*sizeOf(Integer));
  end(*setunion*);

procedure setminus(var M, N : IntSet);
  var
    K : IntSet;
    i, i_M, i_N : Integer;
  begin
    i := 0; i_N := 1;
    for i_M := 1 to M[0] do
      begin
        while (i_N<=N[0]) and (N[i_N]<M[i_M]) do inc(i_N);
        if (i_N>N[0]) or (N[i_N]>M[i_M]) then
          begin
            inc(i);
            K[i] := M[i_M];
          end
        else
          inc(i_N);
      end;
    K[0] := i;
    move(K, M, succ(i)*sizeOf(Integer));
  end(*setminus*);

procedure intersect(var M, N : IntSet);
  var
    K : IntSet;
    i, i_M, i_N : Integer;
  begin
    i := 0; i_N := 1;
    for i_M := 1 to M[0] do
      begin
        while (i_N<=N[0]) and (N[i_N]<M[i_M]) do inc(i_N);
        if (i_N<=N[0]) and (N[i_N]=M[i_M]) then
          begin
            inc(i);
            K[i] := M[i_M];
            inc(i_N);
          end
      end;
    K[0] := i;
    move(K, M, succ(i)*sizeOf(Integer));
  end(*intersect*);

function size(var M : IntSet) : Integer;
  begin
    size := M[0]
  end(*size*);

function member(i : Integer; var M : IntSet) : Boolean;
  var l, r, k : Integer;
  begin
    (* binary search: *)
    l := 1; r := M[0];
    k := l + (r-l) div 2;
    while (l<r) and (M[k]<>i) do
      begin
        if M[k]<i then
          l := succ(k)
        else
          r := pred(k);
        k := l + (r-l) div 2;
      end;
    member := (k<=M[0]) and (M[k]=i);
  end(*member*);

function isempty(var M : IntSet) : Boolean;
  begin
    isempty := M[0]=0
  end(*isempty*);

function equal(var M, N : IntSet) : Boolean;
  var i : Integer;
  begin
    if M[0]<>N[0] then
      equal := false
    else
      begin
        for i := 1 to M[0] do
          if M[i]<>N[i] then
            begin
              equal := false;
              exit
            end;
        equal := true
      end
  end(*equal*);

function subseteq(var M, N : IntSet) : Boolean;
  var
    i_M, i_N : Integer;
  begin
    if M[0]>N[0] then
      subseteq := false
    else
      begin
        i_N := 1;
        for i_M := 1 to M[0] do
          begin
            while (i_N<=N[0]) and (N[i_N]<M[i_M]) do inc(i_N);
            if (i_N>N[0]) or (N[i_N]>M[i_M]) then
              begin
                subseteq := false;
                exit
              end
            else
              inc(i_N);
          end;
        subseteq := true
      end;
  end(*subseteq*);

function newIntSet : IntSetPtr;
  var
    MP : IntSetPtr;
  begin
    getmem(MP, (max_elems+1)*sizeOf(Integer));
    MP^[0] := 0;
    newIntSet := MP
  end(*newIntSet*);

(* Constructors for regular expressions: *)

function newExpr(node_type : NodeType; n : Integer) : RegExpr;
  (* returns new RegExpr node (n: number of bytes to allocate) *)
  var x : RegExpr;
  begin
    getmem(x, sizeOf(NodeType)+n);
    x^.node_type := node_type;
    newExpr := x
  end(*newExpr*);
function markExpr(rule, pos : Integer) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(mark_node, 2*sizeOf(Integer));
    x^.rule := rule;
    x^.pos  := pos;
    markExpr := x
  end(*markExpr*);
function charExpr(c : Char) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(char_node, sizeOf(Char));
    x^.c := c;
    charExpr := x
  end(*charExpr*);
function strExpr(str : StrPtr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(str_node, sizeOf(StrPtr));
    x^.str := str;
    strExpr := x
  end(*strExpr*);
function cclassExpr(cc : CClassPtr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(cclass_node, sizeOf(CClassPtr));
    x^.cc := cc;
    cclassExpr := x
  end(*cclassExpr*);
function starExpr(r : RegExpr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(star_node, sizeOf(RegExpr));
    x^.r := r;
    starExpr := x
  end(*starExpr*);
function plusExpr(r : RegExpr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(plus_node, sizeOf(RegExpr));
    x^.r := r;
    plusExpr := x
  end(*plusExpr*);
function optExpr(r : RegExpr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(opt_node, sizeOf(RegExpr));
    x^.r := r;
    optExpr := x
  end(*optExpr*);
function mnExpr(r : RegExpr; m, n : Integer) : RegExpr;
  var
    ri, rmn : RegExpr;
    i : Integer;
  begin
    if (m>n) or (n=0) then
      mnExpr := epsExpr
    else
      begin
        (* construct r^m: *)
        if m=0 then
          ri := epsExpr
        else
          begin
            ri := r;
            for i := 2 to m do
              ri := catExpr(ri, r);
          end;
        (* construct r{m,n}: *)
        rmn := ri;                  (* r{m,n} := r^m *)
        for i := m+1 to n do
          begin
            if is_epsExpr(ri) then
              ri := r
            else
              ri := catExpr(ri, r);
            rmn := altExpr(rmn, ri)  (* r{m,n} := r{m,n} | r^i,
                                        i=m+1,...,n *)
          end;
        mnExpr := rmn
      end
  end(*mnExpr*);
function catExpr(r1, r2 : RegExpr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(cat_node, 2*sizeOf(RegExpr));
    x^.r1 := r1;
    x^.r2 := r2;
    catExpr := x
  end(*catExpr*);
function altExpr(r1, r2 : RegExpr) : RegExpr;
  var x : RegExpr;
  begin
    x := newExpr(alt_node, 2*sizeOf(RegExpr));
    x^.r1 := r1;
    x^.r2 := r2;
    altExpr := x
  end(*altExpr*);

(* Unifiers for regular expressions: *)

function is_epsExpr(r : RegExpr) : Boolean;
  begin
    is_epsExpr := r=epsExpr
  end(*is_epsExpr*);
function is_markExpr(r : RegExpr; var rule, pos : Integer) : Boolean;
  begin
    if r=epsExpr then
      is_markExpr := false
    else if r^.node_type=mark_node then
      begin
        is_markExpr := true;
        rule := r^.rule;
        pos  := r^.pos;
      end
    else
      is_markExpr := false
  end(*is_markExpr*);
function is_charExpr(r : RegExpr; var c : Char) : Boolean;
  begin
    if r=epsExpr then
      is_charExpr := false
    else if r^.node_type=char_node then
      begin
        is_charExpr := true;
        c := r^.c
      end
    else
      is_charExpr := false
  end(*is_charExpr*);
function is_strExpr(r : RegExpr; var str : StrPtr) : Boolean;
  begin
    if r=epsExpr then
      is_strExpr := false
    else if r^.node_type=str_node then
      begin
        is_strExpr := true;
        str := r^.str;
      end
    else
      is_strExpr := false
  end(*is_strExpr*);
function is_cclassExpr(r : RegExpr; var cc : CClassPtr) : Boolean;
  begin
    if r=epsExpr then
      is_cclassExpr := false
    else if r^.node_type=cclass_node then
      begin
        is_cclassExpr := true;
        cc := r^.cc
      end
    else
      is_cclassExpr := false
  end(*is_cclassExpr*);
function is_starExpr(r : RegExpr; var r1 : RegExpr) : Boolean;
  begin
    if r=epsExpr then
      is_starExpr := false
    else if r^.node_type=star_node then
      begin
        is_starExpr := true;
        r1 := r^.r
      end
    else
      is_starExpr := false
  end(*is_starExpr*);
function is_plusExpr(r : RegExpr; var r1 : RegExpr) : Boolean;
  begin
    if r=epsExpr then
      is_plusExpr := false
    else if r^.node_type=plus_node then
      begin
        is_plusExpr := true;
        r1 := r^.r
      end
    else
      is_plusExpr := false
  end(*is_plusExpr*);
function is_optExpr(r : RegExpr; var r1 : RegExpr) : Boolean;
  begin
    if r=epsExpr then
      is_optExpr := false
    else if r^.node_type=opt_node then
      begin
        is_optExpr := true;
        r1 := r^.r
      end
    else
      is_optExpr := false
  end(*is_optExpr*);
function is_catExpr(r : RegExpr; var r1, r2 : RegExpr) : Boolean;
  begin
    if r=epsExpr then
      is_catExpr := false
    else if r^.node_type=cat_node then
      begin
        is_catExpr := true;