lexbase.pas

Yacc例子代码

        r1 := r^.r1;
        r2 := r^.r2
      end
    else
      is_catExpr := false
  end(*is_catExpr*);
function is_altExpr(r : RegExpr; var r1, r2 : RegExpr) : Boolean;
  begin
    if r=epsExpr then
      is_altExpr := false
    else if r^.node_type=alt_node then
      begin
        is_altExpr := true;
        r1 := r^.r1;
        r2 := r^.r2
      end
    else
      is_altExpr := false
  end(*is_altExpr*);

(* Quicksort: *)

procedure quicksort(lo, hi: Integer;
                    less : OrderPredicate;
                    swap : SwapProc);
  (* derived from the quicksort routine in QSORT.PAS in the Turbo Pascal
     distribution *)
  procedure sort(l, r: Integer);
    var i, j, k : Integer;
    begin
      i := l; j := r; k := (l+r) DIV 2;
      repeat
        while less(i, k) do inc(i);
        while less(k, j) do dec(j);
        if i<=j then
          begin
            swap(i, j);
            if k=i then k := j (* pivot element swapped! *)
            else if k=j then k := i;
            inc(i); dec(j);
          end;
      until i>j;
      if l<j then sort(l,j);
      if i<r then sort(i,r);
    end(*sort*);
  begin
    if lo<hi then sort(lo,hi);
  end(*quicksort*);

(* Generic hash table routines: *)

function hash(str : String; table_size : Integer) : Integer;
  (* computes a hash key for str *)
  var i, key : Integer;
  begin
    key := 0;
    for i := 1 to length(str) do
      inc(key, ord(str[i]));
    hash := key mod table_size + 1;
  end(*hash*);

procedure newPos(var pos, incr, count : Integer; table_size : Integer);
  (* computes a new position in the table (quadratic collision strategy)
     - pos: current position (+inc)
     - incr: current increment (+2)
     - count: current number of collisions (+1)
     quadratic collision formula for position of str after n collisions:
       pos(str, n) = (hash(str)+n^2) mod table_size +1
     note that n^2-(n-1)^2 = 2n-1 <=> n^2 = (n-1)^2 + (2n-1) for n>0,
     i.e. the increment inc=2n-1 increments by two in each collision *)
  begin
    inc(count);
    inc(pos, incr);
    if pos>table_size then pos := pos mod table_size + 1;
    inc(incr, 2)
  end(*newPos*);

function key(symbol : String;
             table_size : Integer;
             lookup : TableLookupProc;
             entry  : TableEntryProc) : Integer;
  var pos, incr, count : Integer;
  begin
    pos := hash(symbol, table_size);
    incr := 1;
    count := 0;
    while count<=table_size do
      if lookup(pos)='' then
        begin
          entry(pos, symbol);
          key := pos;
          exit
        end
      else if lookup(pos)=symbol then
        begin
          key := pos;
          exit
        end
      else
        newPos(pos, incr, count, table_size);
    fatal(sym_table_overflow)
  end(*key*);

function definedKey(symbol : String;
                    table_size : Integer;
                    lookup : TableLookupProc) : Boolean;
  var pos, incr, count : Integer;
  begin
    pos := hash(symbol, table_size);
    incr := 1;
    count := 0;
    while count<=table_size do
      if lookup(pos)='' then
        begin
          definedKey := false;
          exit
        end
      else if lookup(pos)=symbol then
        begin
          definedKey := true;
          exit
        end
      else
        newPos(pos, incr, count, table_size);
    definedKey := false
  end(*definedKey*);

(* Utility routines: *)

function min(i, j : Integer) : Integer;
  begin
    if i<j then
      min := i
    else
      min := j
  end(*min*);
function max(i, j : Integer) : Integer;
  begin
    if i>j then
      max := i
    else
      max := j
  end(*max*);
function nchars(cc : CClass) : Integer;
  var
    c : Char;
    count : Integer;
  begin
    count := 0;
    for c := #0 to #255 do if c in cc then inc(count);
    nchars := count;
  end(*nchars*);
function upper(str : String) : String;
  var i : Integer;
  begin
    for i := 1 to length(str) do
      str[i] := upCase(str[i]);
    upper := str
  end(*upper*);
function strip(str : String) : String;
  begin
    while (length(str)>0) and ((str[1]=' ') or (str[1]=tab)) do
      delete(str, 1, 1);
    while (length(str)>0) and
          ((str[length(str)]= ' ') or
           (str[length(str)]=tab)) do
      delete(str, length(str), 1);
    strip := str;
  end(*strip*);
function blankStr(str : String) : String;
  var i : Integer;
  begin
    for i := 1 to length(str) do
      if str[i]<>tab then str[i] := ' ';
    blankStr := str;
  end(*blankStr*);
function intStr(i : Integer) : String;
  var s : String;
  begin
    str(i, s);
    intStr := s
  end(*intStr*);
function isInt(str : String; var i : Integer) : Boolean;
  var res : Integer;
  begin
    val(str, i, res);
    isInt := res = 0;
  end(*isInt*);
function path(filename : String) : String;
  var i : Integer;
  begin
    i := length(filename);
    while (i>0) and (filename[i]<>'\') and (filename[i]<>':') do
      dec(i);
    path := copy(filename, 1, i);
  end(*path*);
function root(filename : String) : String;
  var
    i : Integer;
  begin
    root := filename;
    for i := length(filename) downto 1 do
      case filename[i] of
        '.' :
          begin
            root := copy(filename, 1, i-1);
            exit
          end;
        '\': exit;
        else
      end;
  end(*addExt*);
function addExt(filename, ext : String) : String;
  (* implemented with goto for maximum efficiency *)
  label x;
  var
    i : Integer;
  begin
    addExt := filename;
    for i := length(filename) downto 1 do
      case filename[i] of
        '.' : exit;
        '\': goto x;
        else
      end;
    x : addExt := filename+'.'+ext
  end(*addExt*);
function file_size(filename : String) : LongInt;
  var f : File;
  begin
    assign(f, filename);
    reset(f, 1);
    if ioresult=0 then
      file_size := fileSize(f)
    else
      file_size := 0;
    close(f);
  end(*file_size*);

(* Utility functions for list generating routines: *)

function charStr(c : char; reserved : CClass) : String;
  function octStr(c : char) : String;
    (* return octal string representation of character c *)
    begin
      octStr := intStr(ord(c) div 64)+intStr((ord(c) mod 64) div 8)+
                intStr(ord(c) mod 8);
    end(*octStr*);
  begin
    case c of
      #0..#7,      (* nonprintable characters *)
      #11,#14..#31,
      #127..#255 : charStr := '\'+octStr(c);
      bs         : charStr := '\b';
      tab        : charStr := '\t';
      nl         : charStr := '\n';
      cr         : charStr := '\c';
      ff         : charStr := '\f';
      '\'        : charStr := '\\';
      else if c in reserved then
        charStr := '\'+c
      else
        charStr := c
    end
  end(*charStr*);

function singleQuoteStr(str : String) : String;
  var
    i : Integer;
    str1 : String;
  begin
    str1 := '';
    for i := 1 to length(str) do
      str1 := str1+charStr(str[i], ['''']);
    singleQuoteStr := ''''+str1+''''
  end(*singleQuoteStr*);

function doubleQuoteStr(str : String) : String;
  var
    i : Integer;
    str1 : String;
  begin
    str1 := '';
    for i := 1 to length(str) do
      str1 := str1+charStr(str[i], ['"']);
    doubleQuoteStr := '"'+str1+'"'
  end(*doubleQuoteStr*);

function cclassStr(cc : CClass) : String;
  const
    reserved : CClass = ['^','-',']'];
    MaxChar = #255;
  var
    c1, c2 : Char;
    str : String;
    Quit: Boolean;
  begin
    if cc=[#1..#255]-[nl] then
      cclassStr := '.'
    else
      begin
        str := '';
        if nchars(cc)>128 then
          begin
            str := '^';
            cc := [#0..#255]-cc;
          end;
        c1 := chr(0);
        Quit := False;
        while not Quit do  begin
	  if c1 in cc then  begin
	    c2 := c1;
	    while (c2<MaxChar) and (succ(c2) in cc) do
              c2 := succ(c2);
	    if c1=c2
             then  str := str+charStr(c1, reserved)
	     else
               if c2=succ(c1)
                then  str := str+charStr(c1, reserved)+charStr(c2, reserved)
	        else  str := str+charStr(c1, reserved)+'-'+charStr(c2, reserved);
              c1 := c2;
	  end;
          Quit := c1 = MaxChar;
          if not Quit then
            c1 := Succ(c1);
        end; { of while }
        cclassStr := '['+str+']'
      end
  end(*cclassStr*);

function cclassOrCharStr(cc : CClass) : String;
  var count : Integer;
      c, c1 : Char;
  begin
    count := 0;
    for c := #0 to #255 do
      if c in cc then
        begin
          c1 := c;
          inc(count);
          if count>1 then
            begin
              cclassOrCharStr := cclassStr(cc);
              exit;
            end;
        end;
    if count=1 then
      cclassOrCharStr := singleQuoteStr(c1)
    else
      cclassOrCharStr := '[]';
  end(*cclassOrCharStr*);

function regExprStr(r : RegExpr) : String;
  function unparseExpr(r : RegExpr) : String;
    var rule_no, pos : Integer;
        c : Char;
        str : StrPtr;
        cc : CClassPtr;
        r1, r2 : RegExpr;
    begin
      if is_epsExpr(r) then
        unparseExpr := ''
      else if is_markExpr(r, rule_no, pos) then
        unparseExpr := '#('+intStr(rule_no)+','+intStr(pos)+')'
      else if is_charExpr(r, c) then
        unparseExpr := charStr(c, [ '"','.','^','$','[',']','*','+','?',
                                    '{','}','|','(',')','/','<','>'])
      else if is_strExpr(r, str) then
        unparseExpr := doubleQuoteStr(str^)
      else if is_cclassExpr(r, cc) then
        unparseExpr := cclassStr(cc^)
      else if is_starExpr(r, r1) then
        unparseExpr := unparseExpr(r1)+'*'
      else if is_plusExpr(r, r1) then
        unparseExpr := unparseExpr(r1)+'+'
      else if is_optExpr(r, r1) then
        unparseExpr := unparseExpr(r1)+'?'
      else if is_catExpr(r, r1, r2) then
        unparseExpr := '('+unparseExpr(r1)+unparseExpr(r2)+')'
      else if is_altExpr(r, r1, r2) then
        unparseExpr := '('+unparseExpr(r1)+'|'+unparseExpr(r2)+')'
      else
        fatal('invalid expression');
    end(*unparseExpr*);
  begin
    regExprStr := unparseExpr(r);
  end(*regExprStr*);

end(*LexBase*).