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   // fuck you, BOM!
 310   {
 311   if (mBufLen >= 3) and (mBuffer[0] = #$EF) and (mBuffer[1] = #$BB) and (mBuffer[2] = #$BF) then
 312   begin
 313     for f := 3 to mBufLen-1 do mBuffer[f-3] := mBuffer[f];
 314     Dec(mBufLen, 3);
 315   end;
 316   }
 317 end;
 318
 319
 320 destructor TTextParser.Destroy ();
 321 begin
 322   inherited;
 323 end;
 324
 325
 326 procedure TTextParser.error (const amsg: AnsiString); noreturn;
 327 begin
 328   raise TParserException.Create(self, amsg);
 329 end;
 330
 331
 332 procedure TTextParser.errorfmt (const afmt: AnsiString; const args: array of const); noreturn;
 333 begin
 334   raise TParserException.CreateFmt(self, afmt, args);
 335 end;
 336
 337
 338 function TTextParser.isIdStartChar (ch: AnsiChar): Boolean; inline;
 339 begin
 340   result :=
 341     (ch = '_') or
 342     ((ch >= 'A') and (ch <= 'Z')) or
 343     ((ch >= 'a') and (ch <= 'z')) or
 344     (ch >= #128) or
 345     ((ch = '$') and (TOption.DollarIsId in mOptions)) or
 346     ((ch = '.') and (TOption.DotIsId in mOptions));
 347 end;
 348
 349 function TTextParser.isIdMidChar (ch: AnsiChar): Boolean; inline;
 350 begin
 351   result :=
 352     ((ch >= '0') and (ch <= '9')) or
 353     ((ch = '-') and (TOption.DashIsId in mOptions)) or
 354     isIdStartChar(ch);
 355 end;
 356
 357
 358 procedure TTextParser.fillCharBuf ();
 359 var
 360   ch: AnsiChar;
 361 begin
 362   if (mEofHit) then begin mCharBuf[mCharBufPos] := #0; exit; end;
 363   while (not mEofHit) and (mCharBufUsed < CharBufSize) do
 364   begin
 365     ch := loadChar();
 366     mCharBuf[(mCharBufPos+mCharBufUsed) mod CharBufSize] := ch;
 367     if (ch = #0) then begin mEofHit := true; break; end;
 368     Inc(mCharBufUsed);
 369   end;
 370 end;
 371
 372
 373 // never drains char buffer (except on "total EOF")
 374 function TTextParser.popFrontChar (): AnsiChar; inline;
 375 begin
 376   if (mEofHit) and (mCharBufUsed = 0) then begin result := #0; exit; end;
 377   assert(mCharBufUsed > 0);
 378   result := mCharBuf[mCharBufPos];
 379   mCharBufPos := (mCharBufPos+1) mod CharBufSize;
 380   Dec(mCharBufUsed);
 381   if (not mEofHit) and (mCharBufUsed = 0) then fillCharBuf();
 382 end;
 383
 384 function TTextParser.peekCurChar (): AnsiChar; inline;
 385 begin
 386   if (mCharBufUsed = 0) and (not mEofHit) then fillCharBuf();
 387   result := mCharBuf[mCharBufPos]; // it is safe, 'cause `fillCharBuf()` will put #0 on "total EOF"
 388 end;
 389
 390 function TTextParser.peekNextChar (): AnsiChar; inline;
 391 begin
 392   if (mCharBufUsed < 2) and (not mEofHit) then fillCharBuf();
 393   if (mCharBufUsed < 2) then result := #0 else result := mCharBuf[(mCharBufPos+1) mod CharBufSize];
 394 end;
 395
 396 function TTextParser.peekChar (dest: Integer): AnsiChar; inline;
 397 begin
 398   if (dest < 0) or (dest >= CharBufSize) then error('internal text parser error');
 399   if (mCharBufUsed < dest+1) then fillCharBuf();
 400   if (mCharBufUsed < dest+1) then result := #0 else result := mCharBuf[(mCharBufPos+dest) mod CharBufSize];
 401 end;
 402
 403
 404 function TTextParser.skipChar (): Boolean;
 405 var
 406   ch: AnsiChar;
 407 begin
 408   ch := popFrontChar();
 409   if (ch = #0) then begin result := false; exit; end;
 410   result := true;
 411   // CR?
 412   case ch of
 413     #10:
 414       begin
 415         mCol := 1;
 416         Inc(mLine);
 417       end;
 418     #13:
 419       begin
 420         mCol := 1;
 421         Inc(mLine);
 422         if (mCharBufUsed > 0) and (mCharBuf[0] = #10) then
 423         begin
 424           if (popFrontChar() = #0) then result := false;
 425         end;
 426       end;
 427     else
 428       Inc(mCol);
 429   end;
 430 end;
 431
 432
 433 function TTextParser.skipBlanks (): Boolean;
 434 var
 435   level: Integer;
 436 begin
 437   //writeln('line=', mLine, '; col=', mCol, '; char0=', Integer(peekChar(0)));
 438   if (mLine = 1) and (mCol = 1) and
 439      (peekChar(0) = #$EF) and
 440      (peekChar(1) = #$BB) and
 441      (peekChar(2) = #$BF) then
 442   begin
 443     skipChar();
 444     skipChar();
 445     skipChar();
 446   end;
 447
 448   while (curChar <> #0) do
 449   begin
 450     if (curChar = '/') then
 451     begin
 452       // single-line comment
 453       if (nextChar = '/') then
 454       begin
 455         //writeln('spos=(', mLine, ',', mCol, ')');
 456         while (curChar <> #0) and (curChar <> #10) and (curChar <> #13) do skipChar();
 457         skipChar(); // skip EOL
 458         //writeln('{', curChar, '}');
 459         //writeln('epos=(', mLine, ',', mCol, ')');
 460         continue;
 461       end;
 462       // multline comment
 463       if (nextChar = '*') then
 464       begin
 465         // skip comment start
 466         skipChar();
 467         skipChar();
 468         while (curChar <> #0) do
 469         begin
 470           if (curChar = '*') and (nextChar = '/') then
 471           begin
 472             // skip comment end
 473             skipChar();
 474             skipChar();
 475             break;
 476           end;
 477           skipChar();
 478         end;
 479         continue;
 480       end;
 481       // nesting multline comment
 482       if (nextChar = '+') then
 483       begin
 484         // skip comment start
 485         skipChar();
 486         skipChar();
 487         level := 1;
 488         while (curChar <> #0) do
 489         begin
 490           if (curChar = '+') and (nextChar = '/') then
 491           begin
 492             // skip comment end
 493             skipChar();
 494             skipChar();
 495             Dec(level);
 496             if (level = 0) then break;
 497             continue;
 498           end;
 499           if (curChar = '/') and (nextChar = '+') then
 500           begin
 501             // skip comment start
 502             skipChar();
 503             skipChar();
 504             Inc(level);
 505             continue;
 506           end;
 507           skipChar();
 508         end;
 509         continue;
 510       end;
 511     end
 512     else if (curChar = '(') and (nextChar = '*') then
 513     begin
 514       // pascal comment; skip comment start
 515       skipChar();
 516       skipChar();
 517       while (curChar <> #0) do
 518       begin
 519         if (curChar = '*') and (nextChar = ')') then
 520         begin
 521           // skip comment end
 522           skipChar();
 523           skipChar();
 524           break;
 525         end;
 526         skipChar();
 527       end;
 528       continue;
 529     end
 530     else if (curChar = '{') and (TOption.PascalComments in mOptions) then
 531     begin
 532       // pascal comment; skip comment start
 533       skipChar();
 534       while (curChar <> #0) do
 535       begin
 536         if (curChar = '}') then
 537         begin
 538           // skip comment end
 539           skipChar();
 540           break;
 541         end;
 542         skipChar();
 543       end;
 544       continue;
 545     end;
 546     if (curChar > ' ') then break;
 547     skipChar(); // skip blank
 548   end;
 549   result := (curChar <> #0);
 550 end;
 551
 552
 553 {$IFDEF XPARSER_DEBUG}
 554 function TTextParser.skipToken (): Boolean;
 555 begin
 556   writeln('getting token...');
 557   result := skipToken1();
 558   writeln('  got token: ', mTokType, ' <', mTokStr, '> : <', mTokChar, '>');
 559 end;
 560
 561 function TTextParser.skipToken1 (): Boolean;
 562 {$ELSE}
 563 function TTextParser.skipToken (): Boolean;
 564 {$ENDIF}
 565   procedure parseInt ();
 566   var
 567     neg: Boolean = false;
 568     base: Integer = -1;
 569     n: Integer;
 570   begin
 571     if (TOption.SignedNumbers in mOptions) then
 572     begin
 573       if (curChar = '+') or (curChar = '-') then
 574       begin
 575         neg := (curChar = '-');
 576         skipChar();
 577         if (curChar < '0') or (curChar > '9') then
 578         begin
 579           mTokType := TTDelim;
 580           if (neg) then mTokChar := '-' else mTokChar := '+';
 581           exit;
 582         end;
 583       end;
 584     end;
 585     if (curChar = '0') then
 586     begin
 587       case nextChar of
 588         'b','B': base := 2;
 589         'o','O': base := 8;
 590         'd','D': base := 10;
 591         'h','H': base := 16;
 592       end;
 593       if (base > 0) then
 594       begin
 595         // skip prefix
 596         skipChar();
 597         skipChar();
 598       end;
 599     end;
 600     // default base
 601     if (base < 0) then base := 10;
 602     if (digitInBase(curChar, base) < 0) then error('invalid number');
 603     mTokType := TTInt;
 604     mTokInt := 0; // just in case
 605     while (curChar <> #0) do
 606     begin
 607       if (curChar = '_') then
 608       begin
 609         skipChar();
 610         if (curChar = #0) then break;
 611       end;
 612       n := digitInBase(curChar, base);
 613       if (n < 0) then break;
 614       n := mTokInt*10+n;
 615       if (n < 0) or (n < mTokInt) then error('integer overflow');
 616       mTokInt := n;
 617       skipChar();
 618     end;
 619     // check for valid number end
 620     if (curChar <> #0) then
 621     begin
 622       if (curChar = '.') then error('floating numbers aren''t supported yet');
 623       if (isIdMidChar(curChar)) then error('invalid number');
 624     end;
 625     if neg then mTokInt := -mTokInt;
 626   end;
 627
 628   procedure parseString ();
 629   var
 630     qch, ch: AnsiChar;
 631     n: Integer;
 632   begin
 633     mTokType := TTStr;
 634     mTokStr := ''; // just in case
 635     qch := curChar;
 636     skipChar(); // skip starting quote
 637     while (curChar <> #0) do
 638     begin
 639       // escape
 640       if (qch = '"') and (curChar = '\') then
 641       begin
 642         if (nextChar = #0) then error('unterminated string escape');
 643         ch := nextChar;
 644         // skip backslash and escape type
 645         skipChar();
 646         skipChar();
 647         case ch of
 648           't': mTokStr += #9;
 649           'n': mTokStr += #10;
 650           'r': mTokStr += #13;
 651           'z': mTokStr += #0;
 652           'e': mTokStr += #27;
 653           'x', 'X': // hex escape
 654             begin
 655               n := digitInBase(curChar, 16);
 656               if (n < 0) then error('invalid hexstr escape');
 657               skipChar();
 658               if (digitInBase(curChar, 16) > 0) then
 659               begin
 660                 n := n*16+digitInBase(curChar, 16);
 661                 skipChar();
 662               end;
 663               mTokStr += AnsiChar(n);
 664             end;
 665           else mTokStr += ch;
 666         end;
 667         continue;
 668       end;
 669       // duplicate single quote (pascal style)
 670       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 671       begin
 672         // skip both quotes
 673         skipChar();
 674         skipChar();
 675         mTokStr += '''';
 676         continue;
 677       end;
 678       if (curChar = qch) then
 679       begin
 680         skipChar(); // skip ending quote
 681         break;
 682       end;
 683       mTokStr += curChar;
 684       skipChar();
 685     end;
 686   end;
 687
 688   procedure parseId ();
 689   begin
 690     mTokType := TTId;
 691     mTokStr := ''; // just in case
 692     while (isIdMidChar(curChar)) do
 693     begin
 694       if (curChar = '.') and (nextChar = '.') then break; // dotdot is a token by itself
 695       mTokStr += curChar;
 696       skipChar();
 697     end;
 698   end;
 699
 700 var
 701   xpos: Integer;
 702 begin
 703   mTokType := TTNone;
 704   mTokStr := '';
 705   mTokChar := #0;
 706   mTokInt := 0;
 707
 708   if not skipBlanks() then
 709   begin
 710     result := false;
 711     mTokType := TTEOF;
 712     mTokLine := mLine;
 713     mTokCol := mCol;
 714     exit;
 715   end;
 716
 717   mTokLine := mLine;
 718   mTokCol := mCol;
 719
 720   result := true;
 721
 722   // number?
 723   if (TOption.SignedNumbers in mOptions) and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 724   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 725
 726   // string?
 727   if (curChar = '"') or (curChar = '''') or (curChar = '`') then begin parseString(); exit; end;
 728
 729   // html color?
 730   if (curChar = '#') and (TOption.HtmlColors in mOptions) then
 731   begin
 732     if (digitInBase(peekChar(1), 16) >= 0) and (digitInBase(peekChar(2), 16) >= 0) and (digitInBase(peekChar(3), 16) >= 0) then
 733     begin
 734       if (digitInBase(peekChar(4), 16) >= 0) and (digitInBase(peekChar(5), 16) >= 0) and (digitInBase(peekChar(6), 16) >= 0) then xpos := 7 else xpos := 4;
 735       if (not isIdMidChar(peekChar(xpos))) then
 736       begin
 737         mTokType := TTId;
 738         mTokStr := '';
 739         while (xpos > 0) do
 740         begin
 741           mTokStr += curChar;
 742           skipChar();
 743           Dec(xpos);
 744         end;
 745         exit;
 746       end;
 747     end;
 748   end;
 749
 750   // identifier?
 751   if (isIdStartChar(curChar)) then
 752   begin
 753     if (curChar = '.') and (nextChar = '.') then
 754     begin
 755       // nothing to do here, as dotdot is a token by itself
 756     end
 757     else
 758     begin
 759       parseId();
 760       exit;
 761     end;
 762   end;
 763
 764   // known delimiters?
 765   mTokChar := curChar;
 766   mTokType := TTDelim;
 767   skipChar();
 768   if (curChar = '=') then
 769   begin
 770     case mTokChar of
 771       '<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end;
 772       '>': begin mTokType := TTGreatEqu; mTokStr := '>='; skipChar(); exit; end;
 773       '!': begin mTokType := TTNotEqu; mTokStr := '!='; skipChar(); exit; end;
 774       '=': begin mTokType := TTEqu; mTokStr := '=='; skipChar(); exit; end;
 775       ':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end;
 776     end;
 777   end
 778   else if (mTokChar = curChar) then
 779   begin
 780     case mTokChar of
 781       '<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end;
 782       '>': begin mTokType := TTShr; mTokStr := '>>'; skipChar(); exit; end;
 783       '&': begin mTokType := TTLogAnd; mTokStr := '&&'; skipChar(); exit; end;
 784       '|': begin mTokType := TTLogOr; mTokStr := '||'; skipChar(); exit; end;
 785     end;
 786   end
 787   else
 788   begin
 789     case mTokChar of
 790       '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end;
 791       '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end;
 792     end;
 793   end;
 794 end;
 795
 796
 797 function TTextParser.isEOF (): Boolean; inline; begin result := (mTokType = TTEOF); end;
 798 function TTextParser.isId (): Boolean; inline; begin result := (mTokType = TTId); end;
 799 function TTextParser.isInt (): Boolean; inline; begin result := (mTokType = TTInt); end;
 800 function TTextParser.isStr (): Boolean; inline; begin result := (mTokType = TTStr); end;
 801 function TTextParser.isDelim (): Boolean; inline; begin result := (mTokType = TTDelim); end;
 802 function TTextParser.isIdOrStr (): Boolean; inline; begin result := (mTokType = TTId) or (mTokType = TTStr); end;
 803
 804
 805 function TTextParser.expectId (): AnsiString;
 806 begin
 807   if (mTokType <> TTId) then error('identifier expected');
 808   result := mTokStr;
 809   skipToken();
 810 end;
 811
 812
 813 procedure TTextParser.expectId (const aid: AnsiString; caseSens: Boolean=true);
 814 begin
 815   if caseSens then
 816   begin
 817     if (mTokType <> TTId) or (mTokStr <> aid) then error('identifier '''+aid+''' expected');
 818   end
 819   else
 820   begin
 821     if (mTokType <> TTId) or (not strEquCI1251(mTokStr, aid)) then error('identifier '''+aid+''' expected');
 822   end;
 823   skipToken();
 824 end;
 825
 826
 827 function TTextParser.eatId (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 828 begin
 829   if caseSens then
 830   begin
 831     result := (mTokType = TTId) and (mTokStr = aid);
 832   end
 833   else
 834   begin
 835     result := (mTokType = TTId) and strEquCI1251(mTokStr, aid);
 836   end;
 837   if result then skipToken();
 838 end;
 839
 840
 841 function TTextParser.eatIdOrStr (const aid: AnsiString; caseSens: Boolean=true): Boolean;
 842 begin
 843   if caseSens then
 844   begin
 845     result := (mTokType = TTId) and (mTokStr = aid);
 846     if not result then result := (mTokType = TTStr) and (mTokStr = aid);
 847   end
 848   else
 849   begin
 850     result := (mTokType = TTId) and strEquCI1251(mTokStr, aid);
 851     if not result then result := (mTokType = TTStr) and strEquCI1251(mTokStr, aid);
 852   end;
 853   if result then skipToken();
 854 end;
 855
 856
 857 function TTextParser.eatIdOrStrCI (const aid: AnsiString): Boolean; inline;
 858 begin
 859   result := eatIdOrStr(aid, false);
 860 end;
 861
 862
 863 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 864 begin
 865   if (mTokType <> TTStr) then error('string expected');
 866   if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
 867   result := mTokStr;
 868   skipToken();
 869 end;
 870
 871
 872 function TTextParser.expectIdOrStr (allowEmpty: Boolean=false): AnsiString;
 873 begin
 874   case mTokType of
 875     TTStr:
 876       if (not allowEmpty) and (Length(mTokStr) = 0) then error('non-empty string expected');
 877     TTId:
 878       begin end;
 879     else
 880       error('string or identifier expected');
 881   end;
 882   result := mTokStr;
 883   skipToken();
 884 end;
 885
 886
 887 function TTextParser.expectInt (): Integer;
 888 begin
 889   if (mTokType <> TTInt) then error('string expected');
 890   result := mTokInt;
 891   skipToken();
 892 end;
 893
 894
 895 procedure TTextParser.expectTT (ttype: Integer);
 896 begin
 897   if (mTokType <> ttype) then error('unexpected token');
 898   skipToken();
 899 end;
 900
 901
 902 function TTextParser.eatTT (ttype: Integer): Boolean;
 903 begin
 904   result := (mTokType = ttype);
 905   if result then skipToken();
 906 end;
 907
 908
 909 procedure TTextParser.expectDelim (const ch: AnsiChar);
 910 begin
 911   if (mTokType <> TTDelim) or (mTokChar <> ch) then errorfmt('delimiter ''%s'' expected', [ch]);
 912   skipToken();
 913 end;
 914
 915
 916 function TTextParser.expectDelims (const ch: TAnsiCharSet): AnsiChar;
 917 begin
 918   if (mTokType <> TTDelim) then error('delimiter expected');
 919   if not (mTokChar in ch) then error('delimiter expected');
 920   result := mTokChar;
 921   skipToken();
 922 end;
 923
 924
 925 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 926 begin
 927   result := (mTokType = TTDelim) and (mTokChar = ch);
 928   if result then skipToken();
 929 end;
 930
 931
 932 function TTextParser.isDelim (const ch: AnsiChar): Boolean; inline;
 933 begin
 934   result := (mTokType = TTDelim) and (mTokChar = ch);
 935 end;
 936
 937
 938 // ////////////////////////////////////////////////////////////////////////// //
 939 constructor TFileTextParser.Create (const fname: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 940 begin
 941   mBuffer := nil;
 942   mFile := openDiskFileRO(fname);
 943   mStreamOwned := true;
 944   GetMem(mBuffer, BufSize);
 945   mBufPos := 0;
 946   mBufLen := mFile.Read(mBuffer^, BufSize);
 947   if (mBufLen < 0) then error('TFileTextParser: read error');
 948   inherited Create(aopts);
 949 end;
 950
 951
 952 constructor TFileTextParser.Create (st: TStream; astOwned: Boolean=true; aopts: TOptions=[TOption.SignedNumbers]);
 953 begin
 954   if (st = nil) then error('cannot create parser for nil stream');
 955   mFile := st;
 956   mStreamOwned := astOwned;
 957   GetMem(mBuffer, BufSize);
 958   mBufPos := 0;
 959   mBufLen := mFile.Read(mBuffer^, BufSize);
 960   if (mBufLen < 0) then error('TFileTextParser: read error');
 961   inherited Create(aopts);
 962 end;
 963
 964
 965 destructor TFileTextParser.Destroy ();
 966 begin
 967   if (mBuffer <> nil) then FreeMem(mBuffer);
 968   mBuffer := nil;
 969   mBufPos := 0;
 970   mBufLen := 0;
 971   if (mStreamOwned) then FreeAndNil(mFile) else mFile := nil;
 972   inherited;
 973 end;
 974
 975
 976 function TFileTextParser.loadChar (): AnsiChar;
 977 begin
 978   if (mBufLen = 0) then begin result := #0; exit; end;
 979   if (mBufPos >= mBufLen) then
 980   begin
 981     mBufLen := mFile.Read(mBuffer^, BufSize);
 982     if (mBufLen < 0) then error('TFileTextParser: read error');
 983     if (mBufLen = 0) then begin result := #0; exit; end;
 984     mBufPos := 0;
 985   end;
 986   assert(mBufPos < mBufLen);
 987   result := mBuffer[mBufPos];
 988   Inc(mBufPos);
 989   if (result = #0) then result := ' ';
 990 end;
 991
 992
 993 // ////////////////////////////////////////////////////////////////////////// //
 994 constructor TStrTextParser.Create (const astr: AnsiString; aopts: TOptions=[TOption.SignedNumbers]);
 995 begin
 996   mStr := astr;
 997   mPos := 1;
 998   inherited Create(aopts);
 999 end;
1000
1001
1002 destructor TStrTextParser.Destroy ();
1003 begin
1004   mStr := '';
1005   inherited;
1006 end;
1007
1008
1009 function TStrTextParser.loadChar (): AnsiChar;
1010 begin
1011   result := #0;
1012   if (mPos > Length(mStr)) then exit;
1013   result := mStr[mPos];
1014   Inc(mPos);
1015   if (result = #0) then result := ' ';
1016 end;
1017
1018
1019 // ////////////////////////////////////////////////////////////////////////// //
1020 constructor TTextWriter.Create (); begin mIndent := 0; end;
1021 procedure TTextWriter.flush (); begin end;
1022 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
1023 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
1024 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
1025 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
1026 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
1027 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
1028 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
1029
1030
1031 // ////////////////////////////////////////////////////////////////////////// //
1032 constructor TFileTextWriter.Create (const fname: AnsiString);
1033 begin
1034   mFile := createDiskFile(fname);
1035   mStreamOwned := true;
1036   mBufUsed := 0;
1037   GetMem(mBuffer, BufSize);
1038   assert(mBuffer <> nil);
1039   inherited Create();
1040 end;
1041
1042
1043 constructor TFileTextWriter.Create (ast: TStream; astOwned: Boolean=true);
1044 begin
1045   if (ast = nil) then raise Exception.Create('cannot write to nil stream');
1046   mFile := ast;
1047   mStreamOwned := astOwned;
1048   mBufUsed := 0;
1049   GetMem(mBuffer, BufSize);
1050   assert(mBuffer <> nil);
1051 end;
1052
1053
1054 destructor TFileTextWriter.Destroy ();
1055 begin
1056   flush();
1057   if (mBuffer <> nil) then FreeMem(mBuffer);
1058   mBufUsed := 0;
1059   mBuffer := nil;
1060   if (mStreamOwned) then mFile.Free();
1061   mFile := nil;
1062   inherited;
1063 end;
1064
1065
1066 procedure TFileTextWriter.flush ();
1067 begin
1068   if (mFile <> nil) and (mBufUsed > 0) then
1069   begin
1070     mFile.WriteBuffer(mBuffer^, mBufUsed);
1071   end;
1072   mBufUsed := 0;
1073 end;
1074
1075
1076 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
1077 var
1078   pc: PChar;
1079   left: Integer;
1080 begin
1081   if (len = 0) then exit;
1082   pc := @buf;
1083   while (len > 0) do
1084   begin
1085     left := BufSize-mBufUsed;
1086     if (left = 0) then
1087     begin
1088       flush();
1089       left := BufSize-mBufUsed;
1090       assert(left > 0);
1091     end;
1092     if (left > len) then left := Integer(len);
1093     Move(pc^, (mBuffer+mBufUsed)^, left);
1094     Inc(mBufUsed, left);
1095     pc += left;
1096     len -= left;
1097   end;
1098 end;
1099
1100
1101 // ////////////////////////////////////////////////////////////////////////// //
1102 constructor TStrTextWriter.Create ();
1103 begin
1104   mStr := '';
1105 end;
1106
1107
1108 destructor TStrTextWriter.Destroy ();
1109 begin
1110   mStr := '';
1111   inherited;
1112 end;
1113
1114
1115 procedure TStrTextWriter.putBuf (constref buf; len: SizeUInt);
1116 var
1117   st: AnsiString = '';
1118 begin
1119   if (len > 0) then
1120   begin
1121     SetLength(st, Integer(len));
1122     Move(buf, PChar(st)^, Integer(len));
1123     mStr += st;
1124     st := '';
1125   end;
1126 end;
1127
1128
1129 end.