a3e39cef4d5ac642c2aab3ee8abfa33f253b707c
1 (* Copyright (C) DooM 2D:Forever Developers
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.
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.
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/>.
16 {$INCLUDE a_modes.inc}
17 {.$DEFINE XPARSER_DEBUG}
23 SysUtils
, Classes
{$IFDEF USE_MEMPOOL}, mempool
{$ENDIF};
26 // ////////////////////////////////////////////////////////////////////////// //
30 TParserException
= class(Exception
)
32 tokLine
, tokCol
: Integer;
35 constructor Create (pr
: TTextParser
; const amsg
: AnsiString);
36 constructor CreateFmt (pr
: TTextParser
; const afmt
: AnsiString; const args
: array of const);
39 TTextParser
= class{$IFDEF USE_MEMPOOL}(TPoolObject
){$ENDIF}
46 //TTFloat = 3; // not yet
48 TTDelim
= 5; // one-char delimiters
53 TTGreatEqu
= 14; // >=
55 TTEqu
= 16; // == or <>
64 SignedNumbers
, // allow signed numbers; otherwise sign will be TTDelim
65 DollarIsId
, // allow dollar in identifiers; otherwise dollar will be TTDelim
66 DotIsId
, // allow dot in identifiers; otherwise dot will be TTDelim
67 PascalComments
// allow `{}` pascal comments
69 TOptions
= set of TOption
;
73 TAnsiCharSet
= set of AnsiChar;
77 mCurChar
, mNextChar
: AnsiChar;
81 mTokLine
, mTokCol
: Integer; // token start
83 mTokStr
: AnsiString; // string or identifier
84 mTokChar
: AnsiChar; // for delimiters
88 procedure warmup (); // called in constructor to warm up the system
89 procedure loadNextChar (); virtual; abstract; // loads next char into mNextChar; #0 means 'eof'
92 constructor Create (aopts
: TOptions
=[TOption
.SignedNumbers
]);
93 destructor Destroy (); override;
95 procedure error (const amsg
: AnsiString); noreturn
;
96 procedure errorfmt (const afmt
: AnsiString; const args
: array of const); noreturn
;
98 function isEOF (): Boolean; inline;
100 function skipChar (): Boolean; // returns `false` on eof
102 function skipBlanks (): Boolean; // ...and comments; returns `false` on eof
104 function skipToken (): Boolean; // returns `false` on eof
105 {$IFDEF XPARSER_DEBUG}
106 function skipToken1 (): Boolean;
109 function isIdOrStr (): Boolean; inline;
111 function expectId (): AnsiString;
112 procedure expectId (const aid
: AnsiString; caseSens
: Boolean=true);
113 function eatId (const aid
: AnsiString; caseSens
: Boolean=true): Boolean;
114 function eatIdOrStr (const aid
: AnsiString; caseSens
: Boolean=true): Boolean;
115 function eatIdOrStrCI (const aid
: AnsiString): Boolean; inline;
117 function expectStr (allowEmpty
: Boolean=false): AnsiString;
118 function expectInt (): Integer;
120 function expectStrOrId (allowEmpty
: Boolean=false): AnsiString;
122 procedure expectTT (ttype
: Integer);
123 function eatTT (ttype
: Integer): Boolean;
125 procedure expectDelim (const ch
: AnsiChar);
126 function expectDelims (const ch
: TAnsiCharSet
): AnsiChar;
127 function eatDelim (const ch
: AnsiChar): Boolean;
129 function isDelim (const ch
: AnsiChar): Boolean; inline;
132 property options
: TOptions read mOptions write mOptions
;
135 property col
: Integer read mCol
;
136 property line
: Integer read mLine
;
138 property curChar
: AnsiChar read mCurChar
;
139 property nextChar
: AnsiChar read mNextChar
;
142 property tokCol
: Integer read mTokCol
;
143 property tokLine
: Integer read mTokLine
;
145 property tokType
: Integer read mTokType
; // see TTXXX constants
146 property tokStr
: AnsiString read mTokStr
; // string or identifier
147 property tokChar
: AnsiChar read mTokChar
; // for delimiters
148 property tokInt
: Integer read mTokInt
;
152 // ////////////////////////////////////////////////////////////////////////// //
154 TFileTextParser
= class(TTextParser
)
156 const BufSize
= 16384;
160 mStreamOwned
: Boolean;
166 procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
169 constructor Create (const fname
: AnsiString; aopts
: TOptions
=[TOption
.SignedNumbers
]);
170 constructor Create (st
: TStream
; astOwned
: Boolean=true; aopts
: TOptions
=[TOption
.SignedNumbers
]);
171 destructor Destroy (); override;
174 TStrTextParser
= class(TTextParser
)
180 procedure loadNextChar (); override; // loads next char into mNextChar; #0 means 'eof'
183 constructor Create (const astr
: AnsiString; aopts
: TOptions
=[TOption
.SignedNumbers
]);
184 destructor Destroy (); override;
188 // ////////////////////////////////////////////////////////////////////////// //
195 procedure putBuf (constref buf
; len
: SizeUInt
); virtual; abstract;
198 constructor Create ();
200 procedure flush (); virtual;
202 procedure put (const s
: AnsiString); overload
;
203 procedure put (v
: Byte); overload
;
204 procedure put (v
: Integer); overload
;
205 procedure put (const fmt
: AnsiString; args
: array of const); overload
;
206 procedure putIndent ();
208 procedure unindent ();
211 property curIndent
: Integer read mIndent
;
215 // ////////////////////////////////////////////////////////////////////////// //
217 TFileTextWriter
= class(TTextWriter
)
219 const BufSize
= 16384;
223 mStreamOwned
: Boolean;
228 procedure putBuf (constref buf
; len
: SizeUInt
); override;
231 constructor Create (const fname
: AnsiString);
232 constructor Create (ast
: TStream
; astOwned
: Boolean=true); // will own the stream by default
233 destructor Destroy (); override;
235 procedure flush (); override;
238 TStrTextWriter
= class(TTextWriter
)
243 procedure putBuf (constref buf
; len
: SizeUInt
); override;
246 constructor Create ();
247 destructor Destroy (); override;
249 property str
: AnsiString read mStr
;
259 // ////////////////////////////////////////////////////////////////////////// //
260 constructor TParserException
.Create (pr
: TTextParser
; const amsg
: AnsiString);
262 if (pr
<> nil) then begin tokLine
:= pr
.tokLine
; tokCol
:= pr
.tokCol
; end;
263 inherited Create(amsg
);
266 constructor TParserException
.CreateFmt (pr
: TTextParser
; const afmt
: AnsiString; const args
: array of const);
268 if (pr
<> nil) then begin tokLine
:= pr
.tokLine
; tokCol
:= pr
.tokCol
; end;
269 inherited Create(formatstrf(afmt
, args
));
273 // ////////////////////////////////////////////////////////////////////////// //
274 constructor TTextParser
.Create (aopts
: TOptions
=[TOption
.SignedNumbers
]);
290 destructor TTextParser
.Destroy ();
296 procedure TTextParser
.error (const amsg
: AnsiString); noreturn
;
298 raise TParserException
.Create(self
, amsg
);
302 procedure TTextParser
.errorfmt (const afmt
: AnsiString; const args
: array of const); noreturn
;
304 raise TParserException
.CreateFmt(self
, afmt
, args
);
308 function TTextParser
.isEOF (): Boolean; inline; begin result
:= (mCurChar
= #0); end;
311 procedure TTextParser
.warmup ();
315 mCurChar
:= mNextChar
;
316 if (mNextChar
<> #0) then loadNextChar();
320 function TTextParser
.skipChar (): Boolean;
322 if (mCurChar
= #0) then begin result
:= false; exit
; end;
323 if (mCurChar
= #10) then begin mCol
:= 1; Inc(mLine
); end else Inc(mCol
);
324 mCurChar
:= mNextChar
;
325 if (mCurChar
= #0) then begin result
:= false; exit
; end;
328 if (mCurChar
= #13) then
330 if (mNextChar
= #10) then loadNextChar();
337 function TTextParser
.skipBlanks (): Boolean;
343 if (curChar
= '/') then
345 // single-line comment
346 if (nextChar
= '/') then
348 while not isEOF
and (curChar
<> #10) do skipChar();
349 skipChar(); // skip EOL
353 if (nextChar
= '*') then
355 // skip comment start
360 if (curChar
= '*') and (nextChar
= '/') then
371 // nesting multline comment
372 if (nextChar
= '+') then
374 // skip comment start
380 if (curChar
= '+') and (nextChar
= '/') then
386 if (level
= 0) then break
;
389 if (curChar
= '/') and (nextChar
= '+') then
391 // skip comment start
402 else if (curChar
= '(') and (nextChar
= '*') then
404 // pascal comment; skip comment start
409 if (curChar
= '*') and (nextChar
= ')') then
420 else if (curChar
= '{') and (TOption
.PascalComments
in mOptions
) then
422 // pascal comment; skip comment start
426 if (curChar
= '}') then
436 if (curChar
> ' ') then break
;
437 skipChar(); // skip blank
443 {$IFDEF XPARSER_DEBUG}
444 function TTextParser
.skipToken (): Boolean;
446 writeln('getting token...');
447 result
:= skipToken1();
448 writeln(' got token: ', mTokType
, ' <', mTokStr
, '> : <', mTokChar
, '>');
451 function TTextParser
.skipToken1 (): Boolean;
453 function TTextParser
.skipToken (): Boolean;
455 procedure parseInt ();
457 neg
: Boolean = false;
461 if (TOption
.SignedNumbers
in mOptions
) then
463 if (curChar
= '+') or (curChar
= '-') then
465 neg
:= (curChar
= '-');
467 if (curChar
< '0') or (curChar
> '9') then
470 if (neg
) then mTokChar
:= '-' else mTokChar
:= '+';
475 if (curChar
= '0') then
491 if (base
< 0) then base
:= 10;
492 if (digitInBase(curChar
, base
) < 0) then raise Exception
.Create('invalid number');
494 mTokInt
:= 0; // just in case
497 n
:= digitInBase(curChar
, base
);
498 if (n
< 0) then break
;
500 if (n
< 0) or (n
< mTokInt
) then raise Exception
.Create('integer overflow');
504 // check for valid number end
507 if (curChar
= '.') then raise Exception
.Create('floating numbers aren''t supported yet');
508 if (curChar
= '_') or ((curChar
>= 'A') and (curChar
<= 'Z')) or ((curChar
>= 'a') and (curChar
<= 'z')) or (curChar
>= #128) then
510 raise Exception
.Create('invalid number');
513 if neg
then mTokInt
:= -mTokInt
;
516 procedure parseString ();
522 mTokStr
:= ''; // just in case
524 skipChar(); // skip starting quote
528 if (qch
= '"') and (curChar
= '\') then
530 if (nextChar
= #0) then raise Exception
.Create('unterminated string escape');
532 // skip backslash and escape type
541 'x', 'X': // hex escape
543 n
:= digitInBase(curChar
, 16);
544 if (n
< 0) then raise Exception
.Create('invalid hexstr escape');
546 if (digitInBase(curChar
, 16) > 0) then
548 n
:= n
*16+digitInBase(curChar
, 16);
551 mTokStr
+= AnsiChar(n
);
557 // duplicate single quote (pascal style)
558 if (qch
= '''') and (curChar
= '''') and (nextChar
= '''') then
566 if (curChar
= qch
) then
568 skipChar(); // skip ending quote
576 procedure parseId ();
579 mTokStr
:= ''; // just in case
580 while (curChar
= '_') or ((curChar
>= '0') and (curChar
<= '9')) or
581 ((curChar
>= 'A') and (curChar
<= 'Z')) or
582 ((curChar
>= 'a') and (curChar
<= 'z')) or
584 ((TOption
.DollarIsId
in mOptions
) and (curChar
= '$')) or
585 ((TOption
.DotIsId
in mOptions
) and (curChar
= '.') and (nextChar
<> '.')) do
598 if not skipBlanks() then
612 if (TOption
.SignedNumbers
in mOptions
) and ((curChar
= '+') or (curChar
= '-')) then begin parseInt(); exit
; end;
613 if (curChar
>= '0') and (curChar
<= '9') then begin parseInt(); exit
; end;
616 if (curChar
= '"') or (curChar
= '''') then begin parseString(); exit
; end;
619 if (curChar
= '_') or ((curChar
>= 'A') and (curChar
<= 'Z')) or ((curChar
>= 'a') and (curChar
<= 'z')) or (curChar
>= #128) then begin parseId(); exit
; end;
620 if (TOption
.DollarIsId
in mOptions
) and (curChar
= '$') then begin parseId(); exit
; end;
621 if (TOption
.DotIsId
in mOptions
) and (curChar
= '.') and (nextChar
<> '.') then begin parseId(); exit
; end;
627 if (curChar
= '=') then
630 '<': begin mTokType
:= TTLessEqu
; mTokStr
:= '<='; skipChar(); exit
; end;
631 '>': begin mTokType
:= TTGreatEqu
; mTokStr
:= '>='; skipChar(); exit
; end;
632 '!': begin mTokType
:= TTNotEqu
; mTokStr
:= '!='; skipChar(); exit
; end;
633 '=': begin mTokType
:= TTEqu
; mTokStr
:= '=='; skipChar(); exit
; end;
634 ':': begin mTokType
:= TTAss
; mTokStr
:= ':='; skipChar(); exit
; end;
637 else if (mTokChar
= curChar
) then
640 '<': begin mTokType
:= TTShl
; mTokStr
:= '<<'; skipChar(); exit
; end;
641 '>': begin mTokType
:= TTShr
; mTokStr
:= '>>'; skipChar(); exit
; end;
642 '&': begin mTokType
:= TTLogAnd
; mTokStr
:= '&&'; skipChar(); exit
; end;
643 '|': begin mTokType
:= TTLogOr
; mTokStr
:= '||'; skipChar(); exit
; end;
649 '<': if (curChar
= '>') then begin mTokType
:= TTNotEqu
; mTokStr
:= '<>'; skipChar(); exit
; end;
650 '.': if (curChar
= '.') then begin mTokType
:= TTDotDot
; mTokStr
:= '..'; skipChar(); exit
; end;
656 function TTextParser
.isIdOrStr (): Boolean; inline;
658 result
:= (mTokType
= TTId
) or (mTokType
= TTStr
);
662 function TTextParser
.expectId (): AnsiString;
664 if (mTokType
<> TTId
) then raise Exception
.Create('identifier expected');
670 procedure TTextParser
.expectId (const aid
: AnsiString; caseSens
: Boolean=true);
674 if (mTokType
<> TTId
) or (mTokStr
<> aid
) then raise Exception
.Create('identifier '''+aid
+''' expected');
678 if (mTokType
<> TTId
) or (not strEquCI1251(mTokStr
, aid
)) then raise Exception
.Create('identifier '''+aid
+''' expected');
684 function TTextParser
.eatId (const aid
: AnsiString; caseSens
: Boolean=true): Boolean;
688 result
:= (mTokType
= TTId
) and (mTokStr
= aid
);
692 result
:= (mTokType
= TTId
) and strEquCI1251(mTokStr
, aid
);
694 if result
then skipToken();
698 function TTextParser
.eatIdOrStr (const aid
: AnsiString; caseSens
: Boolean=true): Boolean;
702 result
:= (mTokType
= TTId
) and (mTokStr
= aid
);
703 if not result
then result
:= (mTokType
= TTStr
) and (mTokStr
= aid
);
707 result
:= (mTokType
= TTId
) and strEquCI1251(mTokStr
, aid
);
708 if not result
then result
:= (mTokType
= TTStr
) and strEquCI1251(mTokStr
, aid
);
710 if result
then skipToken();
714 function TTextParser
.eatIdOrStrCI (const aid
: AnsiString): Boolean; inline;
716 result
:= eatIdOrStr(aid
, false);
720 function TTextParser
.expectStr (allowEmpty
: Boolean=false): AnsiString;
722 if (mTokType
<> TTStr
) then raise Exception
.Create('string expected');
723 if (not allowEmpty
) and (Length(mTokStr
) = 0) then raise Exception
.Create('non-empty string expected');
729 function TTextParser
.expectStrOrId (allowEmpty
: Boolean=false): AnsiString;
733 if (not allowEmpty
) and (Length(mTokStr
) = 0) then raise Exception
.Create('non-empty string expected');
737 raise Exception
.Create('string or identifier expected');
744 function TTextParser
.expectInt (): Integer;
746 if (mTokType
<> TTInt
) then raise Exception
.Create('string expected');
752 procedure TTextParser
.expectTT (ttype
: Integer);
754 if (mTokType
<> ttype
) then raise Exception
.Create('unexpected token');
759 function TTextParser
.eatTT (ttype
: Integer): Boolean;
761 result
:= (mTokType
= ttype
);
762 if result
then skipToken();
766 procedure TTextParser
.expectDelim (const ch
: AnsiChar);
768 if (mTokType
<> TTDelim
) or (mTokChar
<> ch
) then raise Exception
.CreateFmt('delimiter ''%s'' expected', [ch
]);
773 function TTextParser
.expectDelims (const ch
: TAnsiCharSet
): AnsiChar;
775 if (mTokType
<> TTDelim
) then raise Exception
.Create('delimiter expected');
776 if not (mTokChar
in ch
) then raise Exception
.Create('delimiter expected');
782 function TTextParser
.eatDelim (const ch
: AnsiChar): Boolean;
784 result
:= (mTokType
= TTDelim
) and (mTokChar
= ch
);
785 if result
then skipToken();
789 function TTextParser
.isDelim (const ch
: AnsiChar): Boolean; inline;
791 result
:= (mTokType
= TTDelim
) and (mTokChar
= ch
);
795 // ////////////////////////////////////////////////////////////////////////// //
796 constructor TFileTextParser
.Create (const fname
: AnsiString; aopts
: TOptions
=[TOption
.SignedNumbers
]);
799 mFile
:= openDiskFileRO(fname
);
800 mStreamOwned
:= true;
801 GetMem(mBuffer
, BufSize
);
803 mBufLen
:= mFile
.Read(mBuffer
^, BufSize
);
804 if (mBufLen
< 0) then raise Exception
.Create('TFileTextParser: read error');
805 inherited Create(aopts
);
809 constructor TFileTextParser
.Create (st
: TStream
; astOwned
: Boolean=true; aopts
: TOptions
=[TOption
.SignedNumbers
]);
811 if (st
= nil) then raise Exception
.Create('cannot create parser for nil stream');
813 mStreamOwned
:= astOwned
;
814 GetMem(mBuffer
, BufSize
);
816 mBufLen
:= mFile
.Read(mBuffer
^, BufSize
);
817 if (mBufLen
< 0) then raise Exception
.Create('TFileTextParser: read error');
818 inherited Create(aopts
);
822 destructor TFileTextParser
.Destroy ();
824 if (mBuffer
<> nil) then FreeMem(mBuffer
);
828 if mStreamOwned
then mFile
.Free();
834 procedure TFileTextParser
.loadNextChar ();
836 if (mBufLen
= 0) then begin mNextChar
:= #0; exit
; end;
837 if (mBufPos
>= mBufLen
) then
839 mBufLen
:= mFile
.Read(mBuffer
^, BufSize
);
840 if (mBufLen
< 0) then raise Exception
.Create('TFileTextParser: read error');
841 if (mBufLen
= 0) then begin mNextChar
:= #0; exit
; end;
844 assert(mBufPos
< mBufLen
);
845 mNextChar
:= mBuffer
[mBufPos
];
847 if (mNextChar
= #0) then mNextChar
:= ' ';
851 // ////////////////////////////////////////////////////////////////////////// //
852 constructor TStrTextParser
.Create (const astr
: AnsiString; aopts
: TOptions
=[TOption
.SignedNumbers
]);
856 inherited Create(aopts
);
860 destructor TStrTextParser
.Destroy ();
867 procedure TStrTextParser
.loadNextChar ();
870 if (mPos
> Length(mStr
)) then exit
;
871 mNextChar
:= mStr
[mPos
]; Inc(mPos
);
872 if (mNextChar
= #0) then mNextChar
:= ' ';
876 // ////////////////////////////////////////////////////////////////////////// //
877 constructor TTextWriter
.Create (); begin mIndent
:= 0; end;
878 procedure TTextWriter
.flush (); begin end;
879 procedure TTextWriter
.put (const s
: AnsiString); overload
; begin if (Length(s
) > 0) then putBuf((@(s
[1]))^, Length(s
)); end;
880 procedure TTextWriter
.put (v
: Byte); overload
; begin put('%d', [v
]); end;
881 procedure TTextWriter
.put (v
: Integer); overload
; begin put('%d', [v
]); end;
882 procedure TTextWriter
.put (const fmt
: AnsiString; args
: array of const); overload
; begin put(formatstrf(fmt
, args
)); end;
883 procedure TTextWriter
.putIndent (); var f
: Integer; begin for f
:= 1 to mIndent
do put(' '); end;
884 procedure TTextWriter
.indent (); begin Inc(mIndent
, 2); end;
885 procedure TTextWriter
.unindent (); begin Dec(mIndent
, 2); end;
888 // ////////////////////////////////////////////////////////////////////////// //
889 constructor TFileTextWriter
.Create (const fname
: AnsiString);
891 mFile
:= createDiskFile(fname
);
892 mStreamOwned
:= true;
894 GetMem(mBuffer
, BufSize
);
895 assert(mBuffer
<> nil);
900 constructor TFileTextWriter
.Create (ast
: TStream
; astOwned
: Boolean=true);
902 if (ast
= nil) then raise Exception
.Create('cannot write to nil stream');
904 mStreamOwned
:= astOwned
;
906 GetMem(mBuffer
, BufSize
);
907 assert(mBuffer
<> nil);
911 destructor TFileTextWriter
.Destroy ();
914 if (mBuffer
<> nil) then FreeMem(mBuffer
);
917 if (mStreamOwned
) then mFile
.Free();
923 procedure TFileTextWriter
.flush ();
925 if (mFile
<> nil) and (mBufUsed
> 0) then
927 mFile
.WriteBuffer(mBuffer
^, mBufUsed
);
933 procedure TFileTextWriter
.putBuf (constref buf
; len
: SizeUInt
);
938 if (len
= 0) then exit
;
942 left
:= BufSize
-mBufUsed
;
946 left
:= BufSize
-mBufUsed
;
949 if (left
> len
) then left
:= Integer(len
);
950 Move(pc
^, (mBuffer
+mBufUsed
)^, left
);
958 // ////////////////////////////////////////////////////////////////////////// //
959 constructor TStrTextWriter
.Create ();
965 destructor TStrTextWriter
.Destroy ();
972 procedure TStrTextWriter
.putBuf (constref buf
; len
: SizeUInt
);
978 SetLength(st
, Integer(len
));
979 Move(buf
, PChar(st
)^, Integer(len
));