src/shared/xparser.pas

   1 (* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
   2  * Understanding is not required. Only obedience.
   3  *
   4  * This program is free software: you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 3 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program. If not, see <http://www.gnu.org/licenses/>.
  16  *)
  17 {$INCLUDE a_modes.inc}
  18 {.$DEFINE XPARSER_DEBUG}
  19 unit xparser;
  20
  21 interface
  22
  23 uses
  24   SysUtils, Classes{$IFDEF USE_MEMPOOL}, mempool{$ENDIF};
  25
  26
  27 // ////////////////////////////////////////////////////////////////////////// //
  28 type
  29   TTextParser = class;
  30
  31   TParserException = class(Exception)
  32   public
  33     tokLine, tokCol: Integer;
  34
  35   public
  36     constructor Create (pr: TTextParser; const amsg: AnsiString);
  37     constructor CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
  38   end;
  39
  40   TTextParser = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF}
  41   public
  42     const
  43       TTNone = -1;
  44       TTEOF = 0;
  45       TTId = 1;
  46       TTInt = 2;
  47       //TTFloat = 3; // not yet
  48       TTStr = 4; // string
  49       TTDelim = 5; // one-char delimiters
  50       //
  51       TTLogAnd = 11; // &&
  52       TTLogOr = 12; // ||
  53       TTLessEqu = 13; // <=
  54       TTGreatEqu = 14; // >=
  55       TTNotEqu = 15; // !=
  56       TTEqu = 16; // == or <>
  57       TTAss = 17; // :=
  58       TTShl = 18; // <<
  59       TTShr = 19; // >>
  60       TTDotDot = 19; // ..
  61
  62   public
  63     type
  64       TOption = (
  65         SignedNumbers, // allow signed numbers; otherwise sign will be TTDelim
  66         DollarIsId, // allow dollar in identifiers; otherwise dollar will be TTDelim
  67         DotIsId, // allow dot in identifiers; otherwise dot will be TTDelim
  68         DashIsId, // '-' can be part of identifier (but identifier cannot start with '-')
  69         HtmlColors, // #rgb or #rrggbb colors
  70         PascalComments // allow `{}` pascal comments
  71       );
  72       TOptions = set of TOption;
  73
  74   private
  75     type
  76       TAnsiCharSet = set of AnsiChar;
  77     const
  78       CharBufSize = 8;
  79
  80   private
  81     mLine, mCol: Integer;
  82     // chars for 'unget'
  83     mCharBuf: packed array [0..CharBufSize-1] of AnsiChar;
  84     mCharBufUsed: Integer;
  85     mCharBufPos: Integer;
  86     mEofHit: Boolean; // no more chars to load into mCharBuf
  87
  88     mOptions: TOptions;
  89
  90     mTokLine, mTokCol: Integer; // token start
  91     mTokType: Integer;
  92     mTokStr: AnsiString; // string or identifier
  93     mTokChar: AnsiChar; // for delimiters
  94     mTokInt: Integer;
  95
  96   private
  97     procedure fillCharBuf ();
  98     function popFrontChar (): AnsiChar; inline; // never drains char buffer (except on "total EOF")
  99     function peekCurChar (): AnsiChar; inline;
 100     function peekNextChar (): AnsiChar; inline;
 101     function peekChar (dest: Integer): AnsiChar; inline;
 102
 103   protected
 104     function loadChar (): AnsiChar; virtual; abstract; // loads next char; #0 means 'eof'
 105
 106   public
 107     function isIdStartChar (ch: AnsiChar): Boolean; inline;
 108     function isIdMidChar (ch: AnsiChar): Boolean; inline;
 109
 110   public
 111     constructor Create (aopts: TOptions=[TOption.SignedNumbers]);
 112     destructor Destroy (); override;
 113
 114     procedure error (const amsg: AnsiString); noreturn;
 115     procedure errorfmt (const afmt: AnsiString; const args: array of const); noreturn;
 116
 117     function skipChar (): Boolean; // returns `false` on eof
 118
 119     function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
 120
 121     function skipToken (): Boolean; // returns `false` on eof
 122     {$IFDEF XPARSER_DEBUG}
 123     function skipToken1 (): Boolean;
 124     {$ENDIF}
 125
 126     function isEOF (): Boolean; inline;
 127     function isId (): Boolean; inline;
 128     function isInt (): Boolean; inline;
 129     function isStr (): Boolean; inline;
 130     function isDelim (): Boolean; inline;
 131     function isIdOrStr (): Boolean; inline;
 132
 133     function expectId (): AnsiString;
 134     procedure expectId (const aid: AnsiString; caseSens: Boolean=true);
 135     function eatId (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 136     function eatIdOrStr (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 137     function eatIdOrStrCI (const aid: AnsiString): Boolean; inline;
 138
 139     function expectStr (allowEmpty: Boolean=false): AnsiString;
 140     function expectInt (): Integer;
 141
 142     function expectIdOrStr (allowEmpty: Boolean=false): AnsiString;
 143
 144     procedure expectTT (ttype: Integer);
 145     function eatTT (ttype: Integer): Boolean;
 146
 147     procedure expectDelim (const ch: AnsiChar);
 148     function expectDelims (const ch: TAnsiCharSet): AnsiChar;
 149     function eatDelim (const ch: AnsiChar): Boolean;
 150
 151     function isDelim (const ch: AnsiChar): Boolean; inline;
 152
 153   public
 154     property options: TOptions read mOptions write mOptions;
 155
 156   public
 157     property col: Integer read mCol;
 158     property line: Integer read mLine;
 159
 160     property curChar: AnsiChar read peekCurChar;
 161     property nextChar: AnsiChar read peekNextChar;
 162
 163     // token start
 164     property tokCol: Integer read mTokCol;
 165     property tokLine: Integer read mTokLine;
 166
 167     property tokType: Integer read mTokType; // see TTXXX constants
 168     property tokStr: AnsiString read mTokStr; // string or identifier
 169     property tokChar: AnsiChar read mTokChar; // for delimiters
 170     property tokInt: Integer read mTokInt;
 171   end;
 172
 173
 174 // ////////////////////////////////////////////////////////////////////////// //
 175 type
 176   TFileTextParser = class(TTextParser)
 177   private
 178     const BufSize = 16384;
 179
 180   private
 181     mFile: TStream;
 182     mStreamOwned: Boolean;
 183     mBuffer: PChar;
 184     mBufLen: Integer;
 185     mBufPos: Integer;
 186
 187   protected
 188     function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
 189
 190   public
 191     constructor Create (const fname: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 192     constructor Create (st: TStream; astOwned: Boolean=true; aopts: TOptions=[TOption.SignedNumbers]);
 193     destructor Destroy (); override;
 194   end;
 195
 196   TStrTextParser = class(TTextParser)
 197   private
 198     mStr: AnsiString;
 199     mPos: Integer;
 200
 201   protected
 202     function loadChar (): AnsiChar; override; // loads next char; #0 means 'eof'
 203
 204   public
 205     constructor Create (const astr: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 206     destructor Destroy (); override;
 207   end;
 208
 209
 210 // ////////////////////////////////////////////////////////////////////////// //
 211 type
 212   TTextWriter = class
 213   protected
 214     mIndent: Integer;
 215
 216   protected
 217     procedure putBuf (constref buf; len: SizeUInt); virtual; abstract;
 218
 219   public
 220     constructor Create ();
 221
 222     procedure flush (); virtual;
 223
 224     procedure put (const s: AnsiString); overload;
 225     procedure put (v: Byte); overload;
 226     procedure put (v: Integer); overload;
 227     procedure put (const fmt: AnsiString; args: array of const); overload;
 228     procedure putIndent ();
 229     procedure indent ();
 230     procedure unindent ();
 231
 232   public
 233     property curIndent: Integer read mIndent;
 234   end;
 235
 236
 237 // ////////////////////////////////////////////////////////////////////////// //
 238 type
 239   TFileTextWriter = class(TTextWriter)
 240   private
 241     const BufSize = 16384;
 242
 243   private
 244     mFile: TStream;
 245     mStreamOwned: Boolean;
 246     mBuffer: PAnsiChar;
 247     mBufUsed: Integer;
 248
 249   protected
 250     procedure putBuf (constref buf; len: SizeUInt); override;
 251
 252   public
 253     constructor Create (const fname: AnsiString);
 254     constructor Create (ast: TStream; astOwned: Boolean=true); // will own the stream by default
 255     destructor Destroy (); override;
 256
 257     procedure flush (); override;
 258   end;
 259
 260   TStrTextWriter = class(TTextWriter)
 261   private
 262     mStr: AnsiString;
 263
 264   protected
 265     procedure putBuf (constref buf; len: SizeUInt); override;
 266
 267   public
 268     constructor Create ();
 269     destructor Destroy (); override;
 270
 271     property str: AnsiString read mStr;
 272   end;
 273
 274
 275 implementation
 276
 277 uses
 278   utils;
 279
 280
 281 // ////////////////////////////////////////////////////////////////////////// //
 282 constructor TParserException.Create (pr: TTextParser; const amsg: AnsiString);
 283 begin
 284   if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end;
 285   inherited Create(amsg);
 286 end;
 287
 288 constructor TParserException.CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
 289 begin
 290   if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end;
 291   inherited Create(formatstrf(afmt, args));
 292 end;
 293
 294
 295 // ////////////////////////////////////////////////////////////////////////// //
 296 constructor TTextParser.Create (aopts: TOptions=[TOption.SignedNumbers]);
 297 begin
 298   mLine := 1;
 299   mCol := 1;
 300   mCharBufUsed := 0;
 301   mCharBufPos := 0;
 302   mEofHit := false;
 303   mTokType := TTNone;
 304   mTokStr := '';
 305   mTokChar := #0;
 306   mTokInt := 0;
 307   mOptions := aopts;
 308   skipToken();
 309 end;
 310
 311
 312 destructor TTextParser.Destroy ();
 313 begin
 314   inherited;
 315 end;
 316
 317
 318 procedure TTextParser.error (const amsg: AnsiString); noreturn;
 319 begin
 320   raise TParserException.Create(self, amsg);
 321 end;
 322
 323
 324 procedure TTextParser.errorfmt (const afmt: AnsiString; const args: array of const); noreturn;
 325 begin
 326   raise TParserException.CreateFmt(self, afmt, args);
 327 end;
 328
 329
 330 function TTextParser.isIdStartChar (ch: AnsiChar): Boolean; inline;
 331 begin
 332   result :=
 333     (ch = '_') or
 334     ((ch >= 'A') and (ch <= 'Z')) or
 335     ((ch >= 'a') and (ch <= 'z')) or
 336     (ch >= #128) or
 337     ((ch = '$') and (TOption.DollarIsId in mOptions)) or
 338     ((ch = '.') and (TOption.DotIsId in mOptions));
 339 end;
 340
 341 function TTextParser.isIdMidChar (ch: AnsiChar): Boolean; inline;
 342 begin
 343   result :=
 344     ((ch >= '0') and (ch <= '9')) or
 345     ((ch = '-') and (TOption.DashIsId in mOptions)) or
 346     isIdStartChar(ch);
 347 end;
 348
 349
 350 procedure TTextParser.fillCharBuf ();
 351 var
 352   ch: AnsiChar;
 353 begin
 354   if (mEofHit) then begin mCharBuf[mCharBufPos] := #0; exit; end;
 355   while (not mEofHit) and (mCharBufUsed < CharBufSize) do
 356   begin
 357     ch := loadChar();
 358     mCharBuf[(mCharBufPos+mCharBufUsed) mod CharBufSize] := ch;
 359     if (ch = #0) then begin mEofHit := true; break; end;
 360     Inc(mCharBufUsed);
 361   end;
 362 end;
 363
 364
 365 // never drains char buffer (except on "total EOF")
 366 function TTextParser.popFrontChar (): AnsiChar; inline;
 367 begin
 368   if (mEofHit) and (mCharBufUsed = 0) then begin result := #0; exit; end;
 369   assert(mCharBufUsed > 0);
 370   result := mCharBuf[mCharBufPos];
 371   mCharBufPos := (mCharBufPos+1) mod CharBufSize;
 372   Dec(mCharBufUsed);
 373   if (not mEofHit) and (mCharBufUsed = 0) then fillCharBuf();
 374 end;
 375
 376 function TTextParser.peekCurChar (): AnsiChar; inline;
 377 begin
 378   if (mCharBufUsed = 0) and (not mEofHit) then fillCharBuf();
 379   result := mCharBuf[mCharBufPos]; // it is safe, 'cause `fillCharBuf()` will put #0 on "total EOF"
 380 end;
 381
 382 function TTextParser.peekNextChar (): AnsiChar; inline;
 383 begin
 384   if (mCharBufUsed < 2) and (not mEofHit) then fillCharBuf();
 385   if (mCharBufUsed < 2) then result := #0 else result := mCharBuf[(mCharBufPos+1) mod CharBufSize];
 386 end;
 387
 388 function TTextParser.peekChar (dest: Integer): AnsiChar; inline;
 389 begin
 390   if (dest < 0) or (dest >= CharBufSize) then error('internal text parser error');
 391   if (mCharBufUsed < dest+1) then fillCharBuf();
 392   if (mCharBufUsed < dest+1) then result := #0 else result := mCharBuf[(mCharBufPos+dest) mod CharBufSize];
 393 end;
 394
 395
 396 function TTextParser.skipChar (): Boolean;
 397 var
 398   ch: AnsiChar;
 399 begin
 400   ch := popFrontChar();
 401   if (ch = #0) then begin result := false; exit; end;
 402   result := true;
 403   // CR?
 404   case ch of
 405     #10:
 406       begin
 407         mCol := 1;
 408         Inc(mLine);
 409       end;
 410     #13:
 411       begin
 412         mCol := 1;
 413         Inc(mLine);
 414         if (mCharBufUsed > 0) and (mCharBuf[0] = #10) then
 415         begin
 416           if (popFrontChar() = #0) then result := false;
 417         end;
 418       end;
 419     else
 420       Inc(mCol);
 421   end;
 422 end;
 423
 424
 425 function TTextParser.skipBlanks (): Boolean;
 426 var
 427   level: Integer;
 428 begin
 429   while (curChar <> #0) do
 430   begin
 431     if (curChar = '/') then
 432     begin
 433       // single-line comment
 434       if (nextChar = '/') then
 435       begin
 436         //writeln('spos=(', mLine, ',', mCol, ')');
 437         while (curChar <> #0) and (curChar <> #10) and (curChar <> #13) do skipChar();
 438         skipChar(); // skip EOL
 439         //writeln('{', curChar, '}');
 440         //writeln('epos=(', mLine, ',', mCol, ')');
 441         continue;
 442       end;
 443       // multline comment
 444       if (nextChar = '*') then
 445       begin
 446         // skip comment start
 447         skipChar();
 448         skipChar();
 449         while (curChar <> #0) do
 450         begin
 451           if (curChar = '*') and (nextChar = '/') then
 452           begin
 453             // skip comment end
 454             skipChar();
 455             skipChar();
 456             break;
 457           end;
 458           skipChar();
 459         end;
 460         continue;
 461       end;
 462       // nesting multline comment
 463       if (nextChar = '+') then
 464       begin
 465         // skip comment start
 466         skipChar();
 467         skipChar();
 468         level := 1;
 469         while (curChar <> #0) do
 470         begin
 471           if (curChar = '+') and (nextChar = '/') then
 472           begin
 473             // skip comment end
 474             skipChar();
 475             skipChar();
 476             Dec(level);
 477             if (level = 0) then break;
 478             continue;
 479           end;
 480           if (curChar = '/') and (nextChar = '+') then
 481           begin
 482             // skip comment start
 483             skipChar();
 484             skipChar();
 485             Inc(level);
 486             continue;
 487           end;
 488           skipChar();
 489         end;
 490         continue;
 491       end;
 492     end
 493     else if (curChar = '(') and (nextChar = '*') then
 494     begin
 495       // pascal comment; skip comment start
 496       skipChar();
 497       skipChar();
 498       while (curChar <> #0) do
 499       begin
 500         if (curChar = '*') and (nextChar = ')') then
 501         begin
 502           // skip comment end
 503           skipChar();
 504           skipChar();
 505           break;
 506         end;
 507         skipChar();
 508       end;
 509       continue;
 510     end
 511     else if (curChar = '{') and (TOption.PascalComments in mOptions) then
 512     begin
 513       // pascal comment; skip comment start
 514       skipChar();
 515       while (curChar <> #0) do
 516       begin
 517         if (curChar = '}') then
 518         begin
 519           // skip comment end
 520           skipChar();
 521           break;
 522         end;
 523         skipChar();
 524       end;
 525       continue;
 526     end;
 527     if (curChar > ' ') then break;
 528     skipChar(); // skip blank
 529   end;
 530   result := (curChar <> #0);
 531 end;
 532
 533
 534 {$IFDEF XPARSER_DEBUG}
 535 function TTextParser.skipToken (): Boolean;
 536 begin
 537   writeln('getting token...');
 538   result := skipToken1();
 539   writeln('  got token: ', mTokType, ' <', mTokStr, '> : <', mTokChar, '>');
 540 end;
 541
 542 function TTextParser.skipToken1 (): Boolean;
 543 {$ELSE}
 544 function TTextParser.skipToken (): Boolean;
 545 {$ENDIF}
 546   procedure parseInt ();
 547   var
 548     neg: Boolean = false;
 549     base: Integer = -1;
 550     n: Integer;
 551   begin
 552     if (TOption.SignedNumbers in mOptions) then
 553     begin
 554       if (curChar = '+') or (curChar = '-') then
 555       begin
 556         neg := (curChar = '-');
 557         skipChar();
 558         if (curChar < '0') or (curChar > '9') then
 559         begin
 560           mTokType := TTDelim;
 561           if (neg) then mTokChar := '-' else mTokChar := '+';
 562           exit;
 563         end;
 564       end;
 565     end;
 566     if (curChar = '0') then
 567     begin
 568       case nextChar of
 569         'b','B': base := 2;
 570         'o','O': base := 8;
 571         'd','D': base := 10;
 572         'h','H': base := 16;
 573       end;
 574       if (base > 0) then
 575       begin
 576         // skip prefix
 577         skipChar();
 578         skipChar();
 579       end;
 580     end;
 581     // default base
 582     if (base < 0) then base := 10;
 583     if (digitInBase(curChar, base) < 0) then error('invalid number');
 584     mTokType := TTInt;
 585     mTokInt := 0; // just in case
 586     while (curChar <> #0) do
 587     begin
 588       if (curChar = '_') then
 589       begin
 590         skipChar();
 591         if (curChar = #0) then break;
 592       end;
 593       n := digitInBase(curChar, base);
 594       if (n < 0) then break;
 595       n := mTokInt*10+n;
 596       if (n < 0) or (n < mTokInt) then error('integer overflow');
 597       mTokInt := n;
 598       skipChar();
 599     end;
 600     // check for valid number end
 601     if (curChar <> #0) then
 602     begin
 603       if (curChar = '.') then error('floating numbers aren''t supported yet');
 604       if (isIdMidChar(curChar)) then error('invalid number');
 605     end;
 606     if neg then mTokInt := -mTokInt;
 607   end;
 608
 609   procedure parseString ();
 610   var
 611     qch, ch: AnsiChar;
 612     n: Integer;
 613   begin
 614     mTokType := TTStr;
 615     mTokStr := ''; // just in case
 616     qch := curChar;
 617     skipChar(); // skip starting quote
 618     while (curChar <> #0) do
 619     begin
 620       // escape
 621       if (qch = '"') and (curChar = '\') then
 622       begin
 623         if (nextChar = #0) then error('unterminated string escape');
 624         ch := nextChar;
 625         // skip backslash and escape type
 626         skipChar();
 627         skipChar();
 628         case ch of
 629           't': mTokStr += #9;
 630           'n': mTokStr += #10;
 631           'r': mTokStr += #13;
 632           'z': mTokStr += #0;
 633           'e': mTokStr += #27;
 634           'x', 'X': // hex escape
 635             begin
 636               n := digitInBase(curChar, 16);
 637               if (n < 0) then error('invalid hexstr escape');
 638               skipChar();
 639               if (digitInBase(curChar, 16) > 0) then
 640               begin
 641                 n := n*16+digitInBase(curChar, 16);
 642                 skipChar();
 643               end;
 644               mTokStr += AnsiChar(n);
 645             end;
 646           else mTokStr += ch;
 647         end;
 648         continue;
 649       end;
 650       // duplicate single quote (pascal style)
 651       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 652       begin
 653         // skip both quotes
 654         skipChar();
 655         skipChar();
 656         mTokStr += '''';
 657         continue;
 658       end;
 659       if (curChar = qch) then
 660       begin
 661         skipChar(); // skip ending quote
 662         break;
 663       end;
 664       mTokStr += curChar;
 665       skipChar();
 666     end;
 667   end;
 668
 669   procedure parseId ();
 670   begin
 671     mTokType := TTId;
 672     mTokStr := ''; // just in case
 673     while (isIdMidChar(curChar)) do
 674     begin
 675       if (curChar = '.') and (nextChar = '.') then break; // dotdot is a token by itself
 676       mTokStr += curChar;
 677       skipChar();
 678     end;
 679   end;
 680
 681 var
 682   xpos: Integer;
 683 begin
 684   mTokType := TTNone;
 685   mTokStr := '';
 686   mTokChar := #0;
 687   mTokInt := 0;
 688
 689   if not skipBlanks() then
 690   begin
 691     result := false;
 692     mTokType := TTEOF;
 693     mTokLine := mLine;
 694     mTokCol := mCol;
 695     exit;
 696   end;
 697
 698   mTokLine := mLine;
 699   mTokCol := mCol;
 700
 701   result := true;
 702
 703   // number?
 704   if (TOption.SignedNumbers in mOptions) and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 705   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 706
 707   // string?
 708   if (curChar = '"') or (curChar = '''') or (curChar = '`') then begin parseString(); exit; end;
 709
 710   // html color?
 711   if (curChar = '#') and (TOption.HtmlColors in mOptions) then
 712   begin
 713     if (digitInBase(peekChar(1), 16) >= 0) and (digitInBase(peekChar(2), 16) >= 0) and (digitInBase(peekChar(3), 16) >= 0) then
 714     begin
 715       if (digitInBase(peekChar(4), 16) >= 0) and (digitInBase(peekChar(5), 16) >= 0) and (digitInBase(peekChar(6), 16) >= 0) then xpos := 7 else xpos := 4;
 716       if (not isIdMidChar(peekChar(xpos))) then
 717       begin
 718         mTokType := TTId;
 719         mTokStr := '';
 720         while (xpos > 0) do
 721         begin
 722           mTokStr += curChar;
 723           skipChar();
 724           Dec(xpos);
 725         end;
 726         exit;
 727       end;
 728     end;
 729   end;
 730
 731   // identifier?
 732   if (isIdStartChar(curChar)) then
 733   begin
 734     if (curChar = '.') and (nextChar = '.') then
 735     begin
 736       // nothing to do here, as dotdot is a token by itself
 737     end
 738     else
 739     begin
 740       parseId();
 741       exit;
 742     end;
 743   end;
 744
 745   // known delimiters?
 746   mTokChar := curChar;
 747   mTokType := TTDelim;
 748   skipChar();
 749   if (curChar = '=') then
 750   begin
 751     case mTokChar of
 752       '<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end;
 753       '>': begin mTokType := TTGreatEqu; mTokStr := '>='; skipChar(); exit; end;
 754       '!': begin mTokType := TTNotEqu; mTokStr := '!='; skipChar(); exit; end;
 755       '=': begin mTokType := TTEqu; mTokStr := '=='; skipChar(); exit; end;
 756       ':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end;
 757     end;
 758   end
 759   else if (mTokChar = curChar) then
 760   begin
 761     case mTokChar of
 762       '<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end;
 763       '>': begin mTokType := TTShr; mTokStr := '>>'; skipChar(); exit; end;
 764       '&': begin mTokType := TTLogAnd; mTokStr := '&&'; skipChar(); exit; end;
 765       '|': begin mTokType := TTLogOr; mTokStr := '||'; skipChar(); exit; end;
 766     end;
 767   end
 768   else
 769   begin
 770     case mTokChar of
 771       '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
 772       '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
 773     end;
 774   end;
 775 end;
 776
 777
 778 function TTextParser.isEOF (): Boolean; inline; begin result := (mTokType = TTEOF); end;
 779 function TTextParser.isId (): Boolean; inline; begin result := (mTokType = TTId); end;
 780 function TTextParser.isInt (): Boolean; inline; begin result := (mTokType = TTInt); end;
 781 function TTextParser.isStr (): Boolean; inline; begin result := (mTokType = TTStr); end;
 782 function TTextParser.isDelim (): Boolean; inline; begin result := (mTokType = TTDelim); end;
 783 function TTextParser.isIdOrStr (): Boolean; inline; begin result := (mTokType = TTId) or (mTokType = TTStr); end;
 784
 785
 786 function TTextParser.expectId (): AnsiString;
 787 begin
 788   if (mTokType <> TTId) then error('identifier expected');
 789   result := mTokStr;
 790   skipToken();
 791 end;
 792
 793
 794 procedure TTextParser.expectId (const aid: AnsiString; caseSens: Boolean=true);
 795 begin
 796   if caseSens then
 797   begin
 798     if (mTokType <> TTId) or (mTokStr <> aid) then error('identifier '''+aid+''' expected');
 799   end
 800   else
 801   begin
 802     if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then error('identifier '''+aid+''' expected');
 803   end;
 804   skipToken();
 805 end;
 806
 807
 808 function TTextParser.eatId (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 809 begin
 810   if caseSens then
 811   begin
 812     result := (mTokType = TTId) and (mTokStr = aid);
 813   end
 814   else
 815   begin
 816     result := (mTokType = TTId) and strEquCI1251(mTokStr, aid);
 817   end;
 818   if result then skipToken();
 819 end;
 820
 821
 822 function TTextParser.eatIdOrStr (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 823 begin
 824   if caseSens then
 825   begin
 826     result := (mTokType = TTId) and (mTokStr = aid);
 827     if not result then result := (mTokType = TTStr) and (mTokStr = aid);
 828   end
 829   else
 830   begin
 831     result := (mTokType = TTId) and strEquCI1251(mTokStr, aid);
 832     if not result then result := (mTokType = TTStr) and strEquCI1251(mTokStr, aid);
 833   end;
 834   if result then skipToken();
 835 end;
 836
 837
 838 function TTextParser.eatIdOrStrCI (const aid: AnsiString): Boolean; inline;
 839 begin
 840   result := eatIdOrStr(aid, false);
 841 end;
 842
 843
 844 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 845 begin
 846   if (mTokType <> TTStr) then error('string expected');
 847   if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
 848   result := mTokStr;
 849   skipToken();
 850 end;
 851
 852
 853 function TTextParser.expectIdOrStr (allowEmpty: Boolean=false): AnsiString;
 854 begin
 855   case mTokType of
 856     TTStr:
 857       if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
 858     TTId:
 859       begin end;
 860     else
 861       error('string or identifier expected');
 862   end;
 863   result := mTokStr;
 864   skipToken();
 865 end;
 866
 867
 868 function TTextParser.expectInt (): Integer;
 869 begin
 870   if (mTokType <> TTInt) then error('string expected');
 871   result := mTokInt;
 872   skipToken();
 873 end;
 874
 875
 876 procedure TTextParser.expectTT (ttype: Integer);
 877 begin
 878   if (mTokType <> ttype) then error('unexpected token');
 879   skipToken();
 880 end;
 881
 882
 883 function TTextParser.eatTT (ttype: Integer): Boolean;
 884 begin
 885   result := (mTokType = ttype);
 886   if result then skipToken();
 887 end;
 888
 889
 890 procedure TTextParser.expectDelim (const ch: AnsiChar);
 891 begin
 892   if (mTokType <> TTDelim) or (mTokChar <> ch) then errorfmt('delimiter ''%s'' expected', [ch]);
 893   skipToken();
 894 end;
 895
 896
 897 function TTextParser.expectDelims (const ch: TAnsiCharSet): AnsiChar;
 898 begin
 899   if (mTokType <> TTDelim) then error('delimiter expected');
 900   if not (mTokChar in ch) then error('delimiter expected');
 901   result := mTokChar;
 902   skipToken();
 903 end;
 904
 905
 906 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 907 begin
 908   result := (mTokType = TTDelim) and (mTokChar = ch);
 909   if result then skipToken();
 910 end;
 911
 912
 913 function TTextParser.isDelim (const ch: AnsiChar): Boolean; inline;
 914 begin
 915   result := (mTokType = TTDelim) and (mTokChar = ch);
 916 end;
 917
 918
 919 // ////////////////////////////////////////////////////////////////////////// //
 920 constructor TFileTextParser.Create (const fname: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 921 begin
 922   mBuffer := nil;
 923   mFile := openDiskFileRO(fname);
 924   mStreamOwned := true;
 925   GetMem(mBuffer, BufSize);
 926   mBufPos := 0;
 927   mBufLen := mFile.Read(mBuffer^, BufSize);
 928   if (mBufLen < 0) then error('TFileTextParser: read error');
 929   inherited Create(aopts);
 930 end;
 931
 932
 933 constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true; aopts: TOptions=[TOption.SignedNumbers]);
 934 begin
 935   if (st = nil) then error('cannot create parser for nil stream');
 936   mFile := st;
 937   mStreamOwned := astOwned;
 938   GetMem(mBuffer, BufSize);
 939   mBufPos := 0;
 940   mBufLen := mFile.Read(mBuffer^, BufSize);
 941   if (mBufLen < 0) then error('TFileTextParser: read error');
 942   inherited Create(aopts);
 943 end;
 944
 945
 946 destructor TFileTextParser.Destroy ();
 947 begin
 948   if (mBuffer <> nil) then FreeMem(mBuffer);
 949   mBuffer := nil;
 950   mBufPos := 0;
 951   mBufLen := 0;
 952   if (mStreamOwned) then FreeAndNil(mFile) else mFile := nil;
 953   inherited;
 954 end;
 955
 956
 957 function TFileTextParser.loadChar (): AnsiChar;
 958 begin
 959   if (mBufLen = 0) then begin result := #0; exit; end;
 960   if (mBufPos >= mBufLen) then
 961   begin
 962     mBufLen := mFile.Read(mBuffer^, BufSize);
 963     if (mBufLen < 0) then error('TFileTextParser: read error');
 964     if (mBufLen = 0) then begin result := #0; exit; end;
 965     mBufPos := 0;
 966   end;
 967   assert(mBufPos < mBufLen);
 968   result := mBuffer[mBufPos];
 969   Inc(mBufPos);
 970   if (result = #0) then result := ' ';
 971 end;
 972
 973
 974 // ////////////////////////////////////////////////////////////////////////// //
 975 constructor TStrTextParser.Create (const astr: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 976 begin
 977   mStr := astr;
 978   mPos := 1;
 979   inherited Create(aopts);
 980 end;
 981
 982
 983 destructor TStrTextParser.Destroy ();
 984 begin
 985   mStr := '';
 986   inherited;
 987 end;
 988
 989
 990 function TStrTextParser.loadChar (): AnsiChar;
 991 begin
 992   result := #0;
 993   if (mPos > Length(mStr)) then exit;
 994   result := mStr[mPos];
 995   Inc(mPos);
 996   if (result = #0) then result := ' ';
 997 end;
 998
 999
1000 // ////////////////////////////////////////////////////////////////////////// //
1001 constructor TTextWriter.Create (); begin mIndent := 0; end;
1002 procedure TTextWriter.flush (); begin end;
1003 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
1004 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
1005 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
1006 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
1007 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
1008 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
1009 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
1010
1011
1012 // ////////////////////////////////////////////////////////////////////////// //
1013 constructor TFileTextWriter.Create (const fname: AnsiString);
1014 begin
1015   mFile := createDiskFile(fname);
1016   mStreamOwned := true;
1017   mBufUsed := 0;
1018   GetMem(mBuffer, BufSize);
1019   assert(mBuffer <> nil);
1020   inherited Create();
1021 end;
1022
1023
1024 constructor TFileTextWriter.Create (ast: TStream; astOwned: Boolean=true);
1025 begin
1026   if (ast = nil) then raise Exception.Create('cannot write to nil stream');
1027   mFile := ast;
1028   mStreamOwned := astOwned;
1029   mBufUsed := 0;
1030   GetMem(mBuffer, BufSize);
1031   assert(mBuffer <> nil);
1032 end;
1033
1034
1035 destructor TFileTextWriter.Destroy ();
1036 begin
1037   flush();
1038   if (mBuffer <> nil) then FreeMem(mBuffer);
1039   mBufUsed := 0;
1040   mBuffer := nil;
1041   if (mStreamOwned) then mFile.Free();
1042   mFile := nil;
1043   inherited;
1044 end;
1045
1046
1047 procedure TFileTextWriter.flush ();
1048 begin
1049   if (mFile <> nil) and (mBufUsed > 0) then
1050   begin
1051     mFile.WriteBuffer(mBuffer^, mBufUsed);
1052   end;
1053   mBufUsed := 0;
1054 end;
1055
1056
1057 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
1058 var
1059   pc: PChar;
1060   left: Integer;
1061 begin
1062   if (len = 0) then exit;
1063   pc := @buf;
1064   while (len > 0) do
1065   begin
1066     left := BufSize-mBufUsed;
1067     if (left = 0) then
1068     begin
1069       flush();
1070       left := BufSize-mBufUsed;
1071       assert(left > 0);
1072     end;
1073     if (left > len) then left := Integer(len);
1074     Move(pc^, (mBuffer+mBufUsed)^, left);
1075     Inc(mBufUsed, left);
1076     pc += left;
1077     len -= left;
1078   end;
1079 end;
1080
1081
1082 // ////////////////////////////////////////////////////////////////////////// //
1083 constructor TStrTextWriter.Create ();
1084 begin
1085   mStr := '';
1086 end;
1087
1088
1089 destructor TStrTextWriter.Destroy ();
1090 begin
1091   mStr := '';
1092   inherited;
1093 end;
1094
1095
1096 procedure TStrTextWriter.putBuf (constref buf; len: SizeUInt);
1097 var
1098   st: AnsiString = '';
1099 begin
1100   if (len > 0) then
1101   begin
1102     SetLength(st, Integer(len));
1103     Move(buf, PChar(st)^, Integer(len));
1104     mStr += st;
1105     st := '';
1106   end;
1107 end;
1108
1109
1110 end.