src/shared/xparser.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   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 unit xparser;
  18
  19 interface
  20
  21
  22 // ////////////////////////////////////////////////////////////////////////// //
  23 type
  24   TUtf8DecoderFast = packed record
  25   public
  26     const Replacement = $FFFD; // replacement char for invalid unicode
  27     const Accept = 0;
  28     const Reject = 12;
  29
  30   private
  31     state: LongWord;
  32
  33   public
  34     codepoint: LongWord; // decoded codepoint (valid only when decoder is in "complete" state)
  35
  36   public
  37     constructor Create (v: Boolean{fuck you, fpc});
  38
  39     procedure reset (); inline;
  40
  41     function complete (): Boolean; inline; // is current character complete? take `codepoint` then
  42     function invalid (): Boolean; inline;
  43     function completeOrInvalid (): Boolean; inline;
  44
  45     // process one byte, return `true` if codepoint is ready
  46     function decode (b: Byte): Boolean; inline; overload;
  47     function decode (c: AnsiChar): Boolean; inline; overload;
  48   end;
  49
  50
  51 // ////////////////////////////////////////////////////////////////////////// //
  52 type
  53   TTextParser = class
  54   public
  55     const
  56       TTNone = -1;
  57       TTEOF = 0;
  58       TTId = 1;
  59       TTInt = 2;
  60       //TTFloat = 3; // not yet
  61       TTStr = 4; // string
  62       TTComma = 5; // ','
  63       TTColon = 6; // ':'
  64       TTSemi = 7; // ';'
  65       TTBegin = 8; // left curly
  66       TTEnd = 9; // right curly
  67       TTDelim = 10; // other delimiters
  68
  69   private
  70     mLine, mCol: Integer;
  71     mCurChar, mNextChar: AnsiChar;
  72
  73     mAllowSignedNumbers: Boolean; // internal control
  74
  75     mTokLine, mTokCol: Integer; // token start
  76     mTokType: Integer;
  77     mTokStr: AnsiString; // string or identifier
  78     mTokChar: AnsiChar; // for delimiters
  79     mTokInt: Integer;
  80
  81   protected
  82     procedure warmup (); virtual; abstract; // called in constructor to warm up the system
  83     procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
  84
  85   public
  86     class function quote (const s: AnsiString): AnsiString;
  87
  88   public
  89     constructor Create (loadToken: Boolean=true);
  90     destructor Destroy (); override;
  91
  92     function isEOF (): Boolean; inline;
  93
  94     function skipChar (): Boolean; // returns `false` on eof
  95
  96     function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
  97
  98     function skipToken (): Boolean; // returns `false` on eof
  99
 100     function expectId (): AnsiString;
 101     procedure expectId (const aid: AnsiString);
 102     function eatId (const aid: AnsiString): Boolean;
 103
 104     function expectStr (allowEmpty: Boolean=false): AnsiString;
 105     function expectInt (): Integer;
 106
 107     procedure expectTT (ttype: Integer);
 108     function eatTT (ttype: Integer): Boolean;
 109
 110     function expectDelim (const ch: AnsiChar): AnsiChar;
 111     function eatDelim (const ch: AnsiChar): Boolean;
 112
 113   public
 114     property col: Integer read mCol;
 115     property line: Integer read mLine;
 116
 117     property curChar: AnsiChar read mCurChar;
 118     property nextChar: AnsiChar read mNextChar;
 119
 120     // token start
 121     property tokCol: Integer read mTokCol;
 122     property tokLine: Integer read mTokLine;
 123
 124     property tokType: Integer read mTokType; // see TTXXX constants
 125     property tokStr: AnsiString read mTokStr; // string or identifier
 126     property tokChar: AnsiChar read mTokChar; // for delimiters
 127     property tokInt: Integer read mTokInt;
 128   end;
 129
 130
 131 // ////////////////////////////////////////////////////////////////////////// //
 132 type
 133   TFileTextParser = class(TTextParser)
 134   private
 135     mFile: File;
 136
 137   protected
 138     procedure warmup (); override; // called in constructor to warm up the system
 139     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 140
 141   public
 142     constructor Create (const fname: AnsiString; loadToken: Boolean=true);
 143     destructor Destroy (); override;
 144   end;
 145
 146   TStrTextParser = class(TTextParser)
 147   private
 148     mStr: AnsiString;
 149     mPos: Integer;
 150
 151   protected
 152     procedure warmup (); override; // called in constructor to warm up the system
 153     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 154
 155   public
 156     constructor Create (const astr: AnsiString; loadToken: Boolean=true);
 157     destructor Destroy (); override;
 158   end;
 159
 160
 161 // ////////////////////////////////////////////////////////////////////////// //
 162 type
 163   TTextWriter = class
 164   protected
 165     mIndent: Integer;
 166
 167   protected
 168     procedure putBuf (constref buf; len: SizeUInt); virtual; abstract;
 169
 170   public
 171     constructor Create ();
 172
 173     procedure put (const s: AnsiString); overload;
 174     procedure put (v: Byte); overload;
 175     procedure put (v: Integer); overload;
 176     procedure put (const fmt: AnsiString; args: array of const); overload;
 177     procedure putIndent ();
 178     procedure indent ();
 179     procedure unindent ();
 180   end;
 181
 182
 183 // ////////////////////////////////////////////////////////////////////////// //
 184 type
 185   TFileTextWriter = class(TTextWriter)
 186   private
 187     mFile: File;
 188
 189   protected
 190     procedure putBuf (constref buf; len: SizeUInt); override;
 191
 192   public
 193     constructor Create (const fname: AnsiString);
 194     destructor Destroy (); override;
 195   end;
 196
 197
 198 // ////////////////////////////////////////////////////////////////////////// //
 199 function wcharTo1251 (wc: WideChar): AnsiChar; inline;
 200 function utfTo1251 (const s: AnsiString): AnsiString;
 201
 202 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 203
 204
 205 implementation
 206
 207 uses
 208   SysUtils, utils;
 209
 210
 211 var
 212   wc2shitmap: array[0..65535] of AnsiChar;
 213   wc2shitmapInited: Boolean = false;
 214
 215
 216 // ////////////////////////////////////////////////////////////////////////// //
 217 procedure initShitMap ();
 218 const
 219   cp1251: array[0..127] of Word = (
 220     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 221     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 222     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 223     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 224     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 225     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 226     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 227     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 228   );
 229 var
 230   f: Integer;
 231 begin
 232   for f := 0 to High(wc2shitmap) do wc2shitmap[f] := '?';
 233   for f := 0 to 127 do wc2shitmap[f] := AnsiChar(f);
 234   for f := 0 to 127 do wc2shitmap[cp1251[f]] := AnsiChar(f+128);
 235   wc2shitmapInited := true;
 236 end;
 237
 238
 239 // ////////////////////////////////////////////////////////////////////////// //
 240 // TODO: make a hash or something
 241 function wcharTo1251 (wc: WideChar): AnsiChar; inline;
 242 begin
 243   if not wc2shitmapInited then initShitMap();
 244   if (LongWord(wc) > 65535) then result := '?' else result := wc2shitmap[LongWord(wc)];
 245 end;
 246
 247
 248 // ////////////////////////////////////////////////////////////////////////// //
 249 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
 250 // code points from invalid range will never be valid, this is the property of the state machine
 251 const
 252   // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
 253   utf8dfa: array[0..$16c-1] of Byte = (
 254     // maps bytes to character classes
 255     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 00-0f
 256     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 10-1f
 257     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 20-2f
 258     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 30-3f
 259     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 40-4f
 260     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 50-5f
 261     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 60-6f
 262     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 70-7f
 263     $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01, // 80-8f
 264     $09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09, // 90-9f
 265     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // a0-af
 266     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // b0-bf
 267     $08,$08,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // c0-cf
 268     $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // d0-df
 269     $0a,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$04,$03,$03, // e0-ef
 270     $0b,$06,$06,$06,$05,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, // f0-ff
 271     // maps a combination of a state of the automaton and a character class to a state
 272     $00,$0c,$18,$24,$3c,$60,$54,$0c,$0c,$0c,$30,$48,$0c,$0c,$0c,$0c, // 100-10f
 273     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$00,$0c,$0c,$0c,$0c,$0c,$00, // 110-11f
 274     $0c,$00,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$18,$0c,$0c, // 120-12f
 275     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c, // 130-13f
 276     $0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$24, // 140-14f
 277     $0c,$24,$0c,$0c,$0c,$24,$0c,$0c,$0c,$0c,$0c,$24,$0c,$24,$0c,$0c, // 150-15f
 278     $0c,$24,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c);
 279
 280
 281 // ////////////////////////////////////////////////////////////////////////// //
 282 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
 283
 284 procedure TUtf8DecoderFast.reset (); inline; begin state := Accept; codepoint := 0; end;
 285
 286 function TUtf8DecoderFast.complete (): Boolean; inline; begin result := (state = Accept); end;
 287 function TUtf8DecoderFast.invalid (): Boolean; inline; begin result := (state = Reject); end;
 288 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
 289
 290 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
 291
 292 function TUtf8DecoderFast.decode (b: Byte): Boolean; inline; overload;
 293 var
 294   tp: LongWord;
 295 begin
 296   if (state = Reject) then begin state := Accept; codepoint := 0; end;
 297   tp := utf8dfa[b];
 298   if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
 299   state := utf8dfa[256+state+tp];
 300   if (state = Reject) then begin codepoint := Replacement; state := Accept; end;
 301   result := (state = Accept);
 302 end;
 303
 304
 305 // ////////////////////////////////////////////////////////////////////////// //
 306 function utfTo1251 (const s: AnsiString): AnsiString;
 307 var
 308   f, c: Integer;
 309   ud: TUtf8DecoderFast;
 310 begin
 311   for f := 1 to Length(s) do
 312   begin
 313     if (Byte(s[f]) > 127) then
 314     begin
 315       ud := TUtf8DecoderFast.Create(true);
 316       result := '';
 317       for c := 1 to Length(s) do
 318       begin
 319         if ud.decode(s[c]) then result += wcharTo1251(WideChar(ud.codepoint));
 320       end;
 321       exit;
 322     end;
 323   end;
 324   result := s;
 325 end;
 326
 327
 328 // ////////////////////////////////////////////////////////////////////////// //
 329 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 330 begin
 331   result := -1;
 332   if (base < 1) or (base > 36) then exit;
 333   if (ch < '0') then exit;
 334   if (base <= 10) then
 335   begin
 336     if (Integer(ch) >= 48+base) then exit;
 337     result := Integer(ch)-48;
 338   end
 339   else
 340   begin
 341     if (ch >= '0') and (ch <= '9') then begin result := Integer(ch)-48; exit; end;
 342     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32); // poor man's tolower()
 343     if (ch < 'A') or (Integer(ch) >= 65+(base-10)) then exit;
 344     result := Integer(ch)-65+10;
 345   end;
 346 end;
 347
 348
 349 // ////////////////////////////////////////////////////////////////////////// //
 350 class function TTextParser.quote (const s: AnsiString): AnsiString;
 351
 352   function squote (const s: AnsiString): AnsiString;
 353   var
 354     f: Integer;
 355   begin
 356     result := '''';
 357     for f := 1 to Length(s) do
 358     begin
 359       if (s[f] = '''') then result += '''';
 360       result += s[f];
 361     end;
 362     result += '''';
 363   end;
 364
 365   function dquote (const s: AnsiString): AnsiString;
 366   var
 367     f: Integer;
 368     ch: AnsiChar;
 369   begin
 370     result := '"';
 371     for f := 1 to Length(s) do
 372     begin
 373       ch := s[f];
 374            if (ch = #0) then result += '\z'
 375       else if (ch = #9) then result += '\t'
 376       else if (ch = #10) then result += '\n'
 377       else if (ch = #13) then result += '\r'
 378       else if (ch = #27) then result += '\e'
 379       else if (ch < ' ') or (ch = #127) then
 380       begin
 381         result += '\x';
 382         result += LowerCase(IntToHex(Integer(ch), 2));
 383       end
 384       else if (ch = '"') or (ch = '\') then
 385       begin
 386         result += '\';
 387         result += ch;
 388       end
 389       else
 390       begin
 391         result += ch;
 392       end;
 393     end;
 394     result += '"';
 395   end;
 396
 397 var
 398   needSingle: Boolean = false;
 399   f: Integer;
 400 begin
 401   for f := 1 to Length(s) do
 402   begin
 403     if (s[f] = '''') then begin needSingle := true; continue; end;
 404     if (s[f] < ' ') or (s[f] = #127) then begin result := dquote(s); exit; end;
 405   end;
 406   if needSingle then result := squote(s) else result := ''''+s+'''';
 407 end;
 408
 409
 410 // ////////////////////////////////////////////////////////////////////////// //
 411 constructor TTextParser.Create (loadToken: Boolean=true);
 412 begin
 413   mLine := 1;
 414   mCol := 1;
 415   mCurChar := #0;
 416   mNextChar := #0;
 417   mTokType := TTNone;
 418   mTokStr := '';
 419   mTokChar := #0;
 420   mTokInt := 0;
 421   mAllowSignedNumbers := true;
 422   warmup(); // change `mAllowSignedNumbers` there, if necessary
 423   if loadToken then skipToken();
 424 end;
 425
 426
 427 destructor TTextParser.Destroy ();
 428 begin
 429   inherited;
 430 end;
 431
 432
 433 function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end;
 434
 435
 436 function TTextParser.skipChar (): Boolean;
 437 begin
 438   if (mCurChar = #0) then begin result := false; exit; end;
 439   if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
 440   mCurChar := mNextChar;
 441   if (mCurChar = #0) then begin result := false; exit; end;
 442   loadNextChar();
 443   // skip CR in CR/LF
 444   if (mCurChar = #13) then
 445   begin
 446     if (mNextChar = #10) then loadNextChar();
 447     mCurChar := #10;
 448   end;
 449   result := true;
 450 end;
 451
 452
 453 function TTextParser.skipBlanks (): Boolean;
 454 var
 455   level: Integer;
 456 begin
 457   while not isEOF do
 458   begin
 459     if (curChar = '/') then
 460     begin
 461       // single-line comment
 462       if (nextChar = '/') then
 463       begin
 464         while not isEOF and (curChar <> #10) do skipChar();
 465         skipChar(); // skip EOL
 466         continue;
 467       end;
 468       // multline comment
 469       if (nextChar = '*') then
 470       begin
 471         // skip comment start
 472         skipChar();
 473         skipChar();
 474         while not isEOF do
 475         begin
 476           if (curChar = '*') and (nextChar = '/') then
 477           begin
 478             // skip comment end
 479             skipChar();
 480             skipChar();
 481             break;
 482           end;
 483           skipChar();
 484         end;
 485         continue;
 486       end;
 487       // nesting multline comment
 488       if (nextChar = '+') then
 489       begin
 490         // skip comment start
 491         skipChar();
 492         skipChar();
 493         level := 1;
 494         while not isEOF do
 495         begin
 496           if (curChar = '+') and (nextChar = '/') then
 497           begin
 498             // skip comment end
 499             skipChar();
 500             skipChar();
 501             Dec(level);
 502             if (level = 0) then break;
 503             continue;
 504           end;
 505           if (curChar = '/') and (nextChar = '+') then
 506           begin
 507             // skip comment start
 508             skipChar();
 509             skipChar();
 510             Inc(level);
 511             continue;
 512           end;
 513           skipChar();
 514         end;
 515         continue;
 516       end;
 517     end;
 518     if (curChar > ' ') then break;
 519     skipChar(); // skip blank
 520   end;
 521   result := not isEOF;
 522 end;
 523
 524
 525 function TTextParser.skipToken (): Boolean;
 526
 527   procedure parseInt ();
 528   var
 529     neg: Boolean = false;
 530     base: Integer = -1;
 531     n: Integer;
 532   begin
 533     if mAllowSignedNumbers then
 534     begin
 535       if (curChar = '+') or (curChar = '-') then
 536       begin
 537         neg := (curChar = '-');
 538         skipChar();
 539         if (curChar < '0') or (curChar > '9') then
 540         begin
 541           mTokType := TTDelim;
 542           if (neg) then mTokChar := '-' else mTokChar := '+';
 543           exit;
 544         end;
 545       end;
 546     end;
 547     if (curChar = '0') then
 548     begin
 549       case nextChar of
 550         'b','B': base := 2;
 551         'o','O': base := 8;
 552         'd','D': base := 10;
 553         'h','H': base := 16;
 554       end;
 555       if (base > 0) then
 556       begin
 557         // skip prefix
 558         skipChar();
 559         skipChar();
 560       end;
 561     end;
 562     // default base
 563     if (base < 0) then base := 10;
 564     if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number');
 565     mTokType := TTInt;
 566     mTokInt := 0; // just in case
 567     while not isEOF do
 568     begin
 569       n := digitInBase(curChar, base);
 570       if (n < 0) then break;
 571       n := mTokInt*10+n;
 572       if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
 573       mTokInt := n;
 574       skipChar();
 575     end;
 576     // check for valid number end
 577     if not isEOF then
 578     begin
 579       if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
 580       if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then
 581       begin
 582         raise Exception.Create('invalid number');
 583       end;
 584     end;
 585     if neg then mTokInt := -mTokInt;
 586   end;
 587
 588   procedure parseString ();
 589   var
 590     qch, ch: AnsiChar;
 591     n: Integer;
 592   begin
 593     mTokType := TTStr;
 594     mTokStr := ''; // just in case
 595     qch := curChar;
 596     skipChar(); // skip starting quote
 597     while not isEOF do
 598     begin
 599       // escape
 600       if (qch = '"') and (curChar = '\') then
 601       begin
 602         if (nextChar = #0) then raise Exception.Create('unterminated string escape');
 603         ch := nextChar;
 604         // skip backslash and escape type
 605         skipChar();
 606         skipChar();
 607         case ch of
 608           't': mTokStr += #9;
 609           'n': mTokStr += #10;
 610           'r': mTokStr += #13;
 611           'z': mTokStr += #0;
 612           'e': mTokStr += #27;
 613           'x', 'X': // hex escape
 614             begin
 615               n := digitInBase(curChar, 16);
 616               if (n < 0) then raise Exception.Create('invalid hexstr escape');
 617               skipChar();
 618               if (digitInBase(curChar, 16) > 0) then
 619               begin
 620                 n := n*16+digitInBase(curChar, 16);
 621                 skipChar();
 622               end;
 623               mTokStr += AnsiChar(n);
 624             end;
 625           else mTokStr += ch;
 626         end;
 627         continue;
 628       end;
 629       // duplicate single quote (pascal style)
 630       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 631       begin
 632         // skip both quotes
 633         skipChar();
 634         skipChar();
 635         mTokStr += '''';
 636         continue;
 637       end;
 638       if (curChar = qch) then
 639       begin
 640         skipChar(); // skip ending quote
 641         break;
 642       end;
 643       mTokStr += curChar;
 644       skipChar();
 645     end;
 646   end;
 647
 648   procedure parseId ();
 649   begin
 650     mTokType := TTId;
 651     mTokStr := ''; // just in case
 652     while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or
 653           ((curChar >= 'A') and (curChar <= 'Z')) or
 654           ((curChar >= 'a') and (curChar <= 'z')) or
 655           (curChar >= #128) do
 656     begin
 657       mTokStr += curChar;
 658       skipChar();
 659     end;
 660   end;
 661
 662 begin
 663   mTokType := TTEOF;
 664   mTokStr := '';
 665   mTokChar := #0;
 666   mTokInt := 0;
 667
 668   if not skipBlanks() then
 669   begin
 670     result := false;
 671     mTokLine := mLine;
 672     mTokCol := mCol;
 673     exit;
 674   end;
 675
 676   mTokLine := mLine;
 677   mTokCol := mCol;
 678
 679   result := true;
 680
 681   // number?
 682   if mAllowSignedNumbers and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 683   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 684
 685   // string?
 686   if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end;
 687
 688   // identifier?
 689   if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end;
 690
 691   // known delimiters?
 692   case curChar of
 693     ',': mTokType := TTComma;
 694     ':': mTokType := TTColon;
 695     ';': mTokType := TTSemi;
 696     '{': mTokType := TTBegin;
 697     '}': mTokType := TTEnd;
 698     else mTokType := TTDelim;
 699   end;
 700   mTokChar := curChar;
 701   skipChar();
 702 end;
 703
 704
 705 function TTextParser.expectId (): AnsiString;
 706 begin
 707   if (mTokType <> TTId) then raise Exception.Create('identifier expected');
 708   result := mTokStr;
 709   skipToken();
 710 end;
 711
 712
 713 procedure TTextParser.expectId (const aid: AnsiString);
 714 begin
 715   if (mTokType <> TTId) or (CompareText(mTokStr, aid) <> 0) then raise Exception.Create('identifier '''+aid+''' expected');
 716   skipToken();
 717 end;
 718
 719
 720 function TTextParser.eatId (const aid: AnsiString): Boolean;
 721 begin
 722   result := false;
 723   if (mTokType <> TTId) or (CompareText(mTokStr, aid) <> 0) then exit;
 724   result := true;
 725   skipToken();
 726 end;
 727
 728
 729 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 730 begin
 731   if (mTokType <> TTStr) then raise Exception.Create('string expected');
 732   if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
 733   result := mTokStr;
 734   skipToken();
 735 end;
 736
 737
 738 function TTextParser.expectInt (): Integer;
 739 begin
 740   if (mTokType <> TTInt) then raise Exception.Create('string expected');
 741   result := mTokInt;
 742   skipToken();
 743 end;
 744
 745
 746 procedure TTextParser.expectTT (ttype: Integer);
 747 begin
 748   if (mTokType <> ttype) then raise Exception.Create('unexpected token');
 749   skipToken();
 750 end;
 751
 752
 753 function TTextParser.eatTT (ttype: Integer): Boolean;
 754 begin
 755   result := (mTokType = ttype);
 756   if result then skipToken();
 757 end;
 758
 759
 760 function TTextParser.expectDelim (const ch: AnsiChar): AnsiChar;
 761 begin
 762   if (mTokType <> TTDelim) then raise Exception.Create(Format('delimiter ''%s'' expected', [ch]));
 763   result := mTokChar;
 764   skipToken();
 765 end;
 766
 767
 768 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 769 begin
 770   result := false;
 771   if (mTokType <> TTDelim) or (mTokChar <> ch) then exit;
 772   result := true;
 773   skipToken();
 774 end;
 775
 776
 777 // ////////////////////////////////////////////////////////////////////////// //
 778 constructor TFileTextParser.Create (const fname: AnsiString; loadToken: Boolean=true);
 779 begin
 780   AssignFile(mFile, fname);
 781   Reset(mFile, 1);
 782   inherited Create(loadToken);
 783 end;
 784
 785
 786 destructor TFileTextParser.Destroy ();
 787 begin
 788   CloseFile(mFile);
 789   inherited;
 790 end;
 791
 792
 793 procedure TFileTextParser.warmup ();
 794 var
 795   rd: Integer;
 796 begin
 797   blockRead(mFile, mCurChar, 1, rd);
 798   if (rd = 0) then begin mCurChar := #0; exit; end;
 799   if (mCurChar = #0) then mCurChar := ' ';
 800   loadNextChar();
 801 end;
 802
 803
 804 procedure TFileTextParser.loadNextChar ();
 805 var
 806   rd: Integer;
 807 begin
 808   blockRead(mFile, mNextChar, 1, rd);
 809   if (rd = 0) then begin mNextChar := #0; exit; end;
 810   if (mNextChar = #0) then mNextChar := ' ';
 811 end;
 812
 813
 814 // ////////////////////////////////////////////////////////////////////////// //
 815 constructor TStrTextParser.Create (const astr: AnsiString; loadToken: Boolean=true);
 816 begin
 817   mStr := astr;
 818   mPos := 1;
 819   inherited Create(loadToken);
 820 end;
 821
 822
 823 destructor TStrTextParser.Destroy ();
 824 begin
 825   mStr := '';
 826   inherited;
 827 end;
 828
 829
 830 procedure TStrTextParser.warmup ();
 831 begin
 832   if (mPos > Length(mStr)) then
 833   begin
 834     mCurChar := #0;
 835     mNextChar := #0;
 836     exit;
 837   end;
 838   mCurChar := mStr[mPos]; Inc(mPos);
 839   if (mCurChar = #0) then mCurChar := ' ';
 840   loadNextChar();
 841 end;
 842
 843
 844 procedure TStrTextParser.loadNextChar ();
 845 begin
 846   mNextChar := #0;
 847   if (mPos > Length(mStr)) then exit;
 848   mNextChar := mStr[mPos]; Inc(mPos);
 849   if (mNextChar = #0) then mNextChar := ' ';
 850 end;
 851
 852
 853 // ////////////////////////////////////////////////////////////////////////// //
 854 constructor TTextWriter.Create (); begin mIndent := 0; end;
 855 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
 856 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
 857 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
 858 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
 859 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
 860 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
 861 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
 862
 863
 864 // ////////////////////////////////////////////////////////////////////////// //
 865 constructor TFileTextWriter.Create (const fname: AnsiString);
 866 begin
 867   AssignFile(mFile, fname);
 868   Rewrite(mFile, 1);
 869   inherited Create();
 870 end;
 871
 872
 873 destructor TFileTextWriter.Destroy ();
 874 begin
 875   CloseFile(mFile);
 876 end;
 877
 878
 879 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
 880 var
 881   wr: SizeUInt;
 882   pc: PChar;
 883 begin
 884   if (len > 0) then
 885   begin
 886     pc := @buf;
 887     BlockWrite(mFile, pc^, len, wr);
 888     if (wr <> len) then raise Exception.Create('write error');
 889     {
 890     while (len > 0) do
 891     begin
 892       write(pc^);
 893       Inc(pc);
 894       Dec(len);
 895     end;
 896     }
 897   end;
 898 end;
 899
 900
 901 end.