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