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   TTextParser = class
  28   public
  29     const
  30       TTNone = -1;
  31       TTEOF = 0;
  32       TTId = 1;
  33       TTInt = 2;
  34       //TTFloat = 3; // not yet
  35       TTStr = 4; // string
  36       TTComma = 5; // ','
  37       TTColon = 6; // ':'
  38       TTSemi = 7; // ';'
  39       TTBegin = 8; // left curly
  40       TTEnd = 9; // right curly
  41       TTDelim = 10; // other delimiters
  42
  43   private
  44     mLine, mCol: Integer;
  45     mCurChar, mNextChar: AnsiChar;
  46
  47     mAllowSignedNumbers: Boolean; // internal control
  48
  49     mTokLine, mTokCol: Integer; // token start
  50     mTokType: Integer;
  51     mTokStr: AnsiString; // string or identifier
  52     mTokChar: AnsiChar; // for delimiters
  53     mTokInt: Integer;
  54
  55   protected
  56     procedure warmup (); virtual; // called in constructor to warm up the system
  57     procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
  58
  59   public
  60     constructor Create (loadToken: Boolean=true);
  61     destructor Destroy (); override;
  62
  63     function isEOF (): Boolean; inline;
  64
  65     function skipChar (): Boolean; // returns `false` on eof
  66
  67     function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
  68
  69     function skipToken (): Boolean; // returns `false` on eof
  70
  71     function expectId (): AnsiString;
  72     procedure expectId (const aid: AnsiString);
  73     function eatId (const aid: AnsiString): Boolean;
  74
  75     function expectStr (allowEmpty: Boolean=false): AnsiString;
  76     function expectInt (): Integer;
  77
  78     procedure expectTT (ttype: Integer);
  79     function eatTT (ttype: Integer): Boolean;
  80
  81     function expectDelim (const ch: AnsiChar): AnsiChar;
  82     function eatDelim (const ch: AnsiChar): Boolean;
  83
  84   public
  85     property col: Integer read mCol;
  86     property line: Integer read mLine;
  87
  88     property curChar: AnsiChar read mCurChar;
  89     property nextChar: AnsiChar read mNextChar;
  90
  91     // token start
  92     property tokCol: Integer read mTokCol;
  93     property tokLine: Integer read mTokLine;
  94
  95     property tokType: Integer read mTokType; // see TTXXX constants
  96     property tokStr: AnsiString read mTokStr; // string or identifier
  97     property tokChar: AnsiChar read mTokChar; // for delimiters
  98     property tokInt: Integer read mTokInt;
  99   end;
 100
 101
 102 // ////////////////////////////////////////////////////////////////////////// //
 103 type
 104   TFileTextParser = class(TTextParser)
 105   private
 106     mFile: TStream;
 107
 108   protected
 109     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 110
 111   public
 112     constructor Create (const fname: AnsiString; loadToken: Boolean=true);
 113     constructor Create (st: TStream; loadToken: Boolean=true); // will take ownership on st
 114     destructor Destroy (); override;
 115   end;
 116
 117   TStrTextParser = class(TTextParser)
 118   private
 119     mStr: AnsiString;
 120     mPos: Integer;
 121
 122   protected
 123     procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
 124
 125   public
 126     constructor Create (const astr: AnsiString; loadToken: Boolean=true);
 127     destructor Destroy (); override;
 128   end;
 129
 130
 131 // ////////////////////////////////////////////////////////////////////////// //
 132 type
 133   TTextWriter = class
 134   protected
 135     mIndent: Integer;
 136
 137   protected
 138     procedure putBuf (constref buf; len: SizeUInt); virtual; abstract;
 139
 140   public
 141     constructor Create ();
 142
 143     procedure put (const s: AnsiString); overload;
 144     procedure put (v: Byte); overload;
 145     procedure put (v: Integer); overload;
 146     procedure put (const fmt: AnsiString; args: array of const); overload;
 147     procedure putIndent ();
 148     procedure indent ();
 149     procedure unindent ();
 150   end;
 151
 152
 153 // ////////////////////////////////////////////////////////////////////////// //
 154 type
 155   TFileTextWriter = class(TTextWriter)
 156   private
 157     mFile: TStream;
 158
 159   protected
 160     procedure putBuf (constref buf; len: SizeUInt); override;
 161
 162   public
 163     constructor Create (const fname: AnsiString);
 164     destructor Destroy (); override;
 165   end;
 166
 167
 168 implementation
 169
 170 uses
 171   SysUtils, utils;
 172
 173
 174 var
 175   wc2shitmap: array[0..65535] of AnsiChar;
 176   wc2shitmapInited: Boolean = false;
 177
 178
 179 // ////////////////////////////////////////////////////////////////////////// //
 180 procedure initShitMap ();
 181 const
 182   cp1251: array[0..127] of Word = (
 183     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 184     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 185     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 186     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 187     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 188     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 189     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 190     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 191   );
 192 var
 193   f: Integer;
 194 begin
 195   for f := 0 to High(wc2shitmap) do wc2shitmap[f] := '?';
 196   for f := 0 to 127 do wc2shitmap[f] := AnsiChar(f);
 197   for f := 0 to 127 do wc2shitmap[cp1251[f]] := AnsiChar(f+128);
 198   wc2shitmapInited := true;
 199 end;
 200
 201
 202 // ////////////////////////////////////////////////////////////////////////// //
 203 // TODO: make a hash or something
 204 function wcharTo1251 (wc: WideChar): AnsiChar; inline;
 205 begin
 206   if not wc2shitmapInited then initShitMap();
 207   if (LongWord(wc) > 65535) then result := '?' else result := wc2shitmap[LongWord(wc)];
 208 end;
 209
 210
 211 // ////////////////////////////////////////////////////////////////////////// //
 212 constructor TTextParser.Create (loadToken: Boolean=true);
 213 begin
 214   mLine := 1;
 215   mCol := 1;
 216   mCurChar := #0;
 217   mNextChar := #0;
 218   mTokType := TTNone;
 219   mTokStr := '';
 220   mTokChar := #0;
 221   mTokInt := 0;
 222   mAllowSignedNumbers := true;
 223   warmup(); // change `mAllowSignedNumbers` there, if necessary
 224   if loadToken then skipToken();
 225 end;
 226
 227
 228 destructor TTextParser.Destroy ();
 229 begin
 230   inherited;
 231 end;
 232
 233
 234 function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end;
 235
 236
 237 procedure TTextParser.warmup ();
 238 begin
 239   mNextChar := ' ';
 240   loadNextChar();
 241   mCurChar := mNextChar;
 242   if (mNextChar <> #0) then loadNextChar();
 243 end;
 244
 245
 246 function TTextParser.skipChar (): Boolean;
 247 begin
 248   if (mCurChar = #0) then begin result := false; exit; end;
 249   if (mCurChar = #10) then begin mCol := 1; Inc(mLine); end else Inc(mCol);
 250   mCurChar := mNextChar;
 251   if (mCurChar = #0) then begin result := false; exit; end;
 252   loadNextChar();
 253   // skip CR in CR/LF
 254   if (mCurChar = #13) then
 255   begin
 256     if (mNextChar = #10) then loadNextChar();
 257     mCurChar := #10;
 258   end;
 259   result := true;
 260 end;
 261
 262
 263 function TTextParser.skipBlanks (): Boolean;
 264 var
 265   level: Integer;
 266 begin
 267   while not isEOF do
 268   begin
 269     if (curChar = '/') then
 270     begin
 271       // single-line comment
 272       if (nextChar = '/') then
 273       begin
 274         while not isEOF and (curChar <> #10) do skipChar();
 275         skipChar(); // skip EOL
 276         continue;
 277       end;
 278       // multline comment
 279       if (nextChar = '*') then
 280       begin
 281         // skip comment start
 282         skipChar();
 283         skipChar();
 284         while not isEOF do
 285         begin
 286           if (curChar = '*') and (nextChar = '/') then
 287           begin
 288             // skip comment end
 289             skipChar();
 290             skipChar();
 291             break;
 292           end;
 293           skipChar();
 294         end;
 295         continue;
 296       end;
 297       // nesting multline comment
 298       if (nextChar = '+') then
 299       begin
 300         // skip comment start
 301         skipChar();
 302         skipChar();
 303         level := 1;
 304         while not isEOF do
 305         begin
 306           if (curChar = '+') and (nextChar = '/') then
 307           begin
 308             // skip comment end
 309             skipChar();
 310             skipChar();
 311             Dec(level);
 312             if (level = 0) then break;
 313             continue;
 314           end;
 315           if (curChar = '/') and (nextChar = '+') then
 316           begin
 317             // skip comment start
 318             skipChar();
 319             skipChar();
 320             Inc(level);
 321             continue;
 322           end;
 323           skipChar();
 324         end;
 325         continue;
 326       end;
 327     end;
 328     if (curChar > ' ') then break;
 329     skipChar(); // skip blank
 330   end;
 331   result := not isEOF;
 332 end;
 333
 334
 335 function TTextParser.skipToken (): Boolean;
 336
 337   procedure parseInt ();
 338   var
 339     neg: Boolean = false;
 340     base: Integer = -1;
 341     n: Integer;
 342   begin
 343     if mAllowSignedNumbers then
 344     begin
 345       if (curChar = '+') or (curChar = '-') then
 346       begin
 347         neg := (curChar = '-');
 348         skipChar();
 349         if (curChar < '0') or (curChar > '9') then
 350         begin
 351           mTokType := TTDelim;
 352           if (neg) then mTokChar := '-' else mTokChar := '+';
 353           exit;
 354         end;
 355       end;
 356     end;
 357     if (curChar = '0') then
 358     begin
 359       case nextChar of
 360         'b','B': base := 2;
 361         'o','O': base := 8;
 362         'd','D': base := 10;
 363         'h','H': base := 16;
 364       end;
 365       if (base > 0) then
 366       begin
 367         // skip prefix
 368         skipChar();
 369         skipChar();
 370       end;
 371     end;
 372     // default base
 373     if (base < 0) then base := 10;
 374     if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number');
 375     mTokType := TTInt;
 376     mTokInt := 0; // just in case
 377     while not isEOF do
 378     begin
 379       n := digitInBase(curChar, base);
 380       if (n < 0) then break;
 381       n := mTokInt*10+n;
 382       if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow');
 383       mTokInt := n;
 384       skipChar();
 385     end;
 386     // check for valid number end
 387     if not isEOF then
 388     begin
 389       if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet');
 390       if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then
 391       begin
 392         raise Exception.Create('invalid number');
 393       end;
 394     end;
 395     if neg then mTokInt := -mTokInt;
 396   end;
 397
 398   procedure parseString ();
 399   var
 400     qch, ch: AnsiChar;
 401     n: Integer;
 402   begin
 403     mTokType := TTStr;
 404     mTokStr := ''; // just in case
 405     qch := curChar;
 406     skipChar(); // skip starting quote
 407     while not isEOF do
 408     begin
 409       // escape
 410       if (qch = '"') and (curChar = '\') then
 411       begin
 412         if (nextChar = #0) then raise Exception.Create('unterminated string escape');
 413         ch := nextChar;
 414         // skip backslash and escape type
 415         skipChar();
 416         skipChar();
 417         case ch of
 418           't': mTokStr += #9;
 419           'n': mTokStr += #10;
 420           'r': mTokStr += #13;
 421           'z': mTokStr += #0;
 422           'e': mTokStr += #27;
 423           'x', 'X': // hex escape
 424             begin
 425               n := digitInBase(curChar, 16);
 426               if (n < 0) then raise Exception.Create('invalid hexstr escape');
 427               skipChar();
 428               if (digitInBase(curChar, 16) > 0) then
 429               begin
 430                 n := n*16+digitInBase(curChar, 16);
 431                 skipChar();
 432               end;
 433               mTokStr += AnsiChar(n);
 434             end;
 435           else mTokStr += ch;
 436         end;
 437         continue;
 438       end;
 439       // duplicate single quote (pascal style)
 440       if (qch = '''') and (curChar = '''') and (nextChar = '''') then
 441       begin
 442         // skip both quotes
 443         skipChar();
 444         skipChar();
 445         mTokStr += '''';
 446         continue;
 447       end;
 448       if (curChar = qch) then
 449       begin
 450         skipChar(); // skip ending quote
 451         break;
 452       end;
 453       mTokStr += curChar;
 454       skipChar();
 455     end;
 456   end;
 457
 458   procedure parseId ();
 459   begin
 460     mTokType := TTId;
 461     mTokStr := ''; // just in case
 462     while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or
 463           ((curChar >= 'A') and (curChar <= 'Z')) or
 464           ((curChar >= 'a') and (curChar <= 'z')) or
 465           (curChar >= #128) do
 466     begin
 467       mTokStr += curChar;
 468       skipChar();
 469     end;
 470   end;
 471
 472 begin
 473   mTokType := TTEOF;
 474   mTokStr := '';
 475   mTokChar := #0;
 476   mTokInt := 0;
 477
 478   if not skipBlanks() then
 479   begin
 480     result := false;
 481     mTokLine := mLine;
 482     mTokCol := mCol;
 483     exit;
 484   end;
 485
 486   mTokLine := mLine;
 487   mTokCol := mCol;
 488
 489   result := true;
 490
 491   // number?
 492   if mAllowSignedNumbers and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end;
 493   if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end;
 494
 495   // string?
 496   if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end;
 497
 498   // identifier?
 499   if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end;
 500
 501   // known delimiters?
 502   case curChar of
 503     ',': mTokType := TTComma;
 504     ':': mTokType := TTColon;
 505     ';': mTokType := TTSemi;
 506     '{': mTokType := TTBegin;
 507     '}': mTokType := TTEnd;
 508     else mTokType := TTDelim;
 509   end;
 510   mTokChar := curChar;
 511   skipChar();
 512 end;
 513
 514
 515 function TTextParser.expectId (): AnsiString;
 516 begin
 517   if (mTokType <> TTId) then raise Exception.Create('identifier expected');
 518   result := mTokStr;
 519   skipToken();
 520 end;
 521
 522
 523 procedure TTextParser.expectId (const aid: AnsiString);
 524 begin
 525   if (mTokType <> TTId) or (CompareText(mTokStr, aid) <> 0) then raise Exception.Create('identifier '''+aid+''' expected');
 526   skipToken();
 527 end;
 528
 529
 530 function TTextParser.eatId (const aid: AnsiString): Boolean;
 531 begin
 532   result := false;
 533   if (mTokType <> TTId) or (CompareText(mTokStr, aid) <> 0) then exit;
 534   result := true;
 535   skipToken();
 536 end;
 537
 538
 539 function TTextParser.expectStr (allowEmpty: Boolean=false): AnsiString;
 540 begin
 541   if (mTokType <> TTStr) then raise Exception.Create('string expected');
 542   if (not allowEmpty) and (Length(mTokStr) = 0) then raise Exception.Create('non-empty string expected');
 543   result := mTokStr;
 544   skipToken();
 545 end;
 546
 547
 548 function TTextParser.expectInt (): Integer;
 549 begin
 550   if (mTokType <> TTInt) then raise Exception.Create('string expected');
 551   result := mTokInt;
 552   skipToken();
 553 end;
 554
 555
 556 procedure TTextParser.expectTT (ttype: Integer);
 557 begin
 558   if (mTokType <> ttype) then raise Exception.Create('unexpected token');
 559   skipToken();
 560 end;
 561
 562
 563 function TTextParser.eatTT (ttype: Integer): Boolean;
 564 begin
 565   result := (mTokType = ttype);
 566   if result then skipToken();
 567 end;
 568
 569
 570 function TTextParser.expectDelim (const ch: AnsiChar): AnsiChar;
 571 begin
 572   if (mTokType <> TTDelim) then raise Exception.Create(Format('delimiter ''%s'' expected', [ch]));
 573   result := mTokChar;
 574   skipToken();
 575 end;
 576
 577
 578 function TTextParser.eatDelim (const ch: AnsiChar): Boolean;
 579 begin
 580   result := false;
 581   if (mTokType <> TTDelim) or (mTokChar <> ch) then exit;
 582   result := true;
 583   skipToken();
 584 end;
 585
 586
 587 // ////////////////////////////////////////////////////////////////////////// //
 588 constructor TFileTextParser.Create (const fname: AnsiString; loadToken: Boolean=true);
 589 begin
 590   mFile := openDiskFileRO(fname);
 591   inherited Create(loadToken);
 592 end;
 593
 594
 595 constructor TFileTextParser.Create (st: TStream; loadToken: Boolean=true);
 596 begin
 597   if (st = nil) then raise Exception.Create('cannot create parser for nil stream');
 598   mFile := st;
 599   inherited Create(loadToken);
 600 end;
 601
 602
 603 destructor TFileTextParser.Destroy ();
 604 begin
 605   mFile.Free();
 606   inherited;
 607 end;
 608
 609
 610 procedure TFileTextParser.loadNextChar ();
 611 var
 612   rd: Integer;
 613 begin
 614   rd := mFile.Read(mNextChar, 1);
 615   if (rd = 0) then begin mNextChar := #0; exit; end;
 616   if (mNextChar = #0) then mNextChar := ' ';
 617 end;
 618
 619
 620 // ////////////////////////////////////////////////////////////////////////// //
 621 constructor TStrTextParser.Create (const astr: AnsiString; loadToken: Boolean=true);
 622 begin
 623   mStr := astr;
 624   mPos := 1;
 625   inherited Create(loadToken);
 626 end;
 627
 628
 629 destructor TStrTextParser.Destroy ();
 630 begin
 631   mStr := '';
 632   inherited;
 633 end;
 634
 635
 636 procedure TStrTextParser.loadNextChar ();
 637 begin
 638   mNextChar := #0;
 639   if (mPos > Length(mStr)) then exit;
 640   mNextChar := mStr[mPos]; Inc(mPos);
 641   if (mNextChar = #0) then mNextChar := ' ';
 642 end;
 643
 644
 645 // ////////////////////////////////////////////////////////////////////////// //
 646 constructor TTextWriter.Create (); begin mIndent := 0; end;
 647 procedure TTextWriter.put (const s: AnsiString); overload; begin if (Length(s) > 0) then putBuf((@(s[1]))^, Length(s)); end;
 648 procedure TTextWriter.put (v: Byte); overload; begin put('%d', [v]); end;
 649 procedure TTextWriter.put (v: Integer); overload; begin put('%d', [v]); end;
 650 procedure TTextWriter.put (const fmt: AnsiString; args: array of const); overload; begin put(formatstrf(fmt, args)); end;
 651 procedure TTextWriter.putIndent (); var f: Integer; begin for f := 1 to mIndent do put(' '); end;
 652 procedure TTextWriter.indent (); begin Inc(mIndent, 2); end;
 653 procedure TTextWriter.unindent (); begin Dec(mIndent, 2); end;
 654
 655
 656 // ////////////////////////////////////////////////////////////////////////// //
 657 constructor TFileTextWriter.Create (const fname: AnsiString);
 658 begin
 659   mFile := createDiskFile(fname);
 660   inherited Create();
 661 end;
 662
 663
 664 destructor TFileTextWriter.Destroy ();
 665 begin
 666   mFile.Free();
 667   inherited;
 668 end;
 669
 670
 671 procedure TFileTextWriter.putBuf (constref buf; len: SizeUInt);
 672 var
 673   pc: PChar;
 674 begin
 675   if (len > 0) then
 676   begin
 677     pc := @buf;
 678     mFile.WriteBuffer(pc^, len);
 679     {
 680     while (len > 0) do
 681     begin
 682       write(pc^);
 683       Inc(pc);
 684       Dec(len);
 685     end;
 686     }
 687   end;
 688 end;
 689
 690
 691 end.