lexlib.pas

公式解析源码

{$H-}

unit LexLib;

(* Standard Lex library unit for TP Lex Version 3.0. 2-11-91 AG *)
(* 24.3.98: repacked into an class to make code thread-safe *)

interface
uses SysUtils;

const
  max_matches = 1024;
  max_rules   = 256;
  nl = #10;  (* newline character *)
  max_chars = 2048;

type
  TLexLib = class
    yyinput, yyoutput : widestring;        (* input and output file *)
    yyline            : String;      (* current input line *)
    yylineno, yycolno : Integer;     (* current input position *)
    yytext            : String;      (* matched text (should be considered r/o) *)
    yystate    : Integer; (* current state of lexical analyzer *)
    yyactchar  : Char;    (* current character *)
    yylastchar : Char;    (* last matched character (#0 if none) *)
    yyrule     : Integer; (* matched rule *)
    yyreject   : Boolean; (* current match rejected? *)
    yydone     : Boolean; (* yylex return value set? *)
    yyretval   : Integer; (* yylex return value *)

    constructor Create;
    function get_char : Char;
    procedure unget_char ( c : Char );
    procedure put_char ( c : Char );
    procedure echo;
    procedure yymore;
    procedure yyless ( n : Integer );
    procedure reject;
    procedure return ( n : Integer );
    procedure returnc ( c : Char );
    procedure start ( state : Integer );
    function yywrap : Boolean;
    procedure yyinit; { Gp }
    procedure yynew;
    procedure yyscan;
    procedure yymark ( n : Integer );
    procedure yymatch ( n : Integer );
    function yyfind ( var n : Integer ) : Boolean;
    function yydefault : Boolean;
    procedure yyclear;
  private
    bufptr : Integer;
    buf    : array [1..max_chars] of Char;
    yystext            : String;
    yysstate, yylstate : Integer;
    yymatches          : Integer;
    yystack            : array [1..max_matches] of Integer;
    yypos              : array [1..max_rules] of Integer;
    yysleng            : Byte;
  end; { TLexLib }

implementation

procedure fatal ( msg : String );
  (* writes a fatal error message and halts program *)
  begin
    writeln('LexLib: ', msg);
    halt(1);
  end(*fatal*);

(* I/O routines: *)

function TLexLib.get_char: Char;
  var i : Integer;
  begin
    if (bufptr=0) and (Length(yyinput) > 0) then
      begin
        i := Pos(#13, yyinput);
        if i > 0 then
        begin
          yyline := Copy(yyinput, 1, i - 1);
          system.Delete(yyinput, 1, i);
          yyinput := Trim(yyinput);
        end
        else
        begin
          yyline := yyinput;
          yyinput := '';
        end;

        inc(yylineno); yycolno := 1;
        buf[1] := nl;
        for i := 1 to length(yyline) do
          buf[i+1] := yyline[length(yyline)-i+1];
        inc(bufptr, length(yyline)+1);
      end;
    if bufptr>0 then
      begin
        get_char := buf[bufptr];
        dec(bufptr);
        inc(yycolno);
      end
    else
      get_char := #0;
  end(*get_char*);

procedure TLexLib.unget_char ( c : Char );
  begin
    if bufptr=max_chars then fatal('input buffer overflow');
    inc(bufptr);
    dec(yycolno);
    buf[bufptr] := c;
  end(*unget_char*);

procedure TLexLib.put_char ( c : Char );
  begin
    if c=#0 then
      { ignore }
    else if c=nl then
      yyoutput := yyoutput + #13#10
    else
      yyoutput := yyoutput + c;
  end(*put_char*);

(* Utilities: *)

procedure TLexLib.echo;
  var i : Integer;
  begin
    for i := 1 to Length(yytext) do
      put_char(yytext[i])
  end(*echo*);

procedure TLexLib.yymore;
  begin
    yystext := yytext;
  end(*yymore*);

procedure TLexLib.yyless ( n : Integer );
  var i : Integer;
  begin
    for i := Length(yytext) downto n+1 do
      unget_char(yytext[i]);
    Length(yytext) := n;
  end(*yyless*);

procedure TLexLib.reject;
  var i : Integer;
  begin
    yyreject := true;
    for i := Length(yytext)+1 to yysleng do
      yytext := yytext+get_char;
    dec(yymatches);
  end(*reject*);

procedure TLexLib.return ( n : Integer );
  begin
    yyretval := n;
    yydone := true;
  end(*return*);

procedure TLexLib.returnc ( c : Char );
  begin
    yyretval := ord(c);
    yydone := true;
  end(*returnc*);

procedure TLexLib.start ( state : Integer );
  begin
    yysstate := state;
  end(*start*);

(* yywrap: *)

function TLexLib.yywrap : Boolean;
  begin
    {close(yyinput); close(yyoutput);} {Gp}
    yywrap := true;
  end(*yywrap*);

(* Internal routines: *)

procedure TLexLib.yynew;
  begin
    if yylastchar<>#0 then
      if yylastchar=nl then
        yylstate := 1
      else
        yylstate := 0;
    yystate := yysstate+yylstate;
    yytext  := yystext;
    yystext := '';
    yymatches := 0;
    yydone := false;
  end(*yynew*);

procedure TLexLib.yyscan;
  begin
    if Length(yytext)=255 then fatal('yytext overflow');
    yyactchar := get_char;
    inc(Length(yytext));
    yytext[Length(yytext)] := yyactchar;
  end(*yyscan*);

procedure TLexLib.yymark ( n : Integer );
  begin
    if n>max_rules then fatal('too many rules');
    yypos[n] := Length(yytext);
  end(*yymark*);

procedure TLexLib.yymatch ( n : Integer );
  begin
    inc(yymatches);
    if yymatches>max_matches then fatal('match stack overflow');
    yystack[yymatches] := n;
  end(*yymatch*);

function TLexLib.yyfind ( var n : Integer ) : Boolean;
  begin
    yyreject := false;
    while (yymatches>0) and (yypos[yystack[yymatches]]=0) do
      dec(yymatches);
    if yymatches>0 then
      begin
        yysleng := Length(yytext);
        n       := yystack[yymatches];
        yyless(yypos[n]);
        yypos[n] := 0;
        if Length(yytext)>0 then
          yylastchar := yytext[Length(yytext)]
        else
          yylastchar := #0;
        yyfind := true;
      end
    else
      begin
        yyless(0);
        yylastchar := #0;
        yyfind := false;
      end
  end(*yyfind*);

function TLexLib.yydefault : Boolean;
  begin
    yyreject := false;
    yyactchar := get_char;
    if yyactchar<>#0 then
      begin
        put_char(yyactchar);
        yydefault := true;
      end
    else
      begin
        yylstate := 1;
        yydefault := false;
      end;
    yylastchar := yyactchar;
  end(*yydefault*);

procedure TLexLib.yyclear;
  begin
    bufptr := 0;
    yysstate := 0;
    yylstate := 1;
    yylastchar := #0;
    yytext := '';
    yystext := '';
  end(*yyclear*);

procedure TLexLib.yyinit; { Gp }
begin
  yylineno := 0;
  yyclear;
end(*yyinit*);

  constructor TLexLib.Create;
  begin
    inherited Create;
    yyinit;
  end; { TLexLib.Create }

begin
end(*LexLib*).