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