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