DEADSOFTWARE

8ebac36188754ef6349bbb7bbc5147a1a0ccfe7a
[d2df-sdl.git] / src / shared / xdynrec.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 {.$DEFINE XDYNREC_USE_FIELDHASH} // actually, it is SLOWER with this
18 unit xdynrec;
20 interface
22 uses
23 Classes,
24 xparser, xstreams, utils, hashtable;
27 // ////////////////////////////////////////////////////////////////////////// //
28 type
29 TDynMapDef = class;
30 TDynRecord = class;
31 TDynField = class;
32 TDynEBS = class;
34 TDynFieldList = specialize TSimpleList<TDynField>;
35 TDynRecList = specialize TSimpleList<TDynRecord>;
36 TDynEBSList = specialize TSimpleList<TDynEBS>;
38 // this is base type for all scalars (and arrays)
39 TDynField = class
40 public
41 type
42 TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TList, TTrigData);
43 // TPoint: pair of Integers
44 // TSize: pair of UShorts
45 // TList: actually, array of records
46 // TTrigData: array of mMaxDim bytes, but internally a record (mRecRef)
47 // arrays of chars are pascal shortstrings (with counter in the first byte)
49 private
50 type
51 TEBS = (TNone, TRec, TEnum, TBitSet);
53 private
54 mOwner: TDynRecord;
55 mPasName: AnsiString;
56 mName: AnsiString;
57 mType: TType;
58 mIVal: Integer; // for all integer types
59 mIVal2: Integer; // for point and size
60 mSVal: AnsiString; // string; for byte and char arrays
61 mRVal: TDynRecList; // for list
62 mRHash: THashStrInt; // id -> index in mRVal
63 mRecRef: TDynRecord; // for TEBS.TRec
64 mMaxDim: Integer; // for byte and char arrays; <0: not an array; 0: impossible value
65 mBinOfs: Integer; // offset in binary; <0 - none
66 mSepPosSize: Boolean; // for points and sizes, use separate fields
67 mAsT: Boolean; // for points and sizes, use separate fields, names starts with `t`
68 mDefined: Boolean;
69 mHasDefault: Boolean;
70 mOmitDef: Boolean;
71 mInternal: Boolean;
72 mNegBool: Boolean;
73 mBitSetUnique: Boolean; // bitset can contain only one value
74 mAsMonsterId: Boolean; // special hack for triggers: monster record number+1 in binary (so 0 means "none")
75 // default value
76 mDefUnparsed: AnsiString;
77 mDefSVal: AnsiString; // default string value
78 mDefIVal, mDefIVal2: Integer; // default integer values
79 mDefRecRef: TDynRecord;
80 mEBS: TEBS; // complex type type
81 mEBSTypeName: AnsiString; // name of enum, bitset or record
82 mEBSType: TObject; // either TDynRecord or TDynEBS; nil means "simple type"; nil for `TTrigData` too
84 // for binary parser
85 mRecRefId: AnsiString;
87 // for userdata
88 mTagInt: Integer;
89 mTagPtr: Pointer;
91 private
92 procedure cleanup ();
94 procedure parseDef (pr: TTextParser);
96 procedure parseDefaultValue (); // parse `mDefUnparsed` to `mDefSVal`, `mDefIVal`, `mDefIVal2`, `mDefRecRef`
97 procedure fixDefaultValue (); // this will NOT clone `mDefRecRef`
98 function isDefaultValue (): Boolean;
100 function getListCount (): Integer; inline;
101 function getListItem (idx: Integer): TDynRecord; inline; overload;
102 function getListItem (const aname: AnsiString): TDynRecord; inline; overload;
104 function getRecRefIndex (): Integer;
106 procedure setIVal (v: Integer); inline;
108 protected
109 // returns `true` for duplicate record id
110 function addListItem (rec: TDynRecord): Boolean; inline;
112 public
113 type
114 TListEnumerator = record
115 private
116 mList: TDynRecList;
117 mCurIdx: Integer;
118 public
119 constructor Create (alist: TDynRecList);
120 function MoveNext (): Boolean; inline;
121 function getCurrent (): TDynRecord; inline;
122 property Current: TDynRecord read getCurrent;
123 end;
125 public
126 constructor Create (const aname: AnsiString; atype: TType);
127 constructor Create (pr: TTextParser);
128 destructor Destroy (); override;
130 class function getTypeName (t: TType): AnsiString;
132 function definition (): AnsiString;
133 function pasdef (): AnsiString;
135 function clone (newOwner: TDynRecord=nil): TDynField;
137 procedure parseValue (pr: TTextParser);
138 procedure parseBinValue (st: TStream);
140 procedure writeTo (wr: TTextWriter);
141 procedure writeBinTo (st: TStream);
143 // won't work for lists
144 function isSimpleEqu (fld: TDynField): Boolean;
146 procedure setValue (const s: AnsiString);
148 function GetEnumerator (): TListEnumerator;
150 public
151 property pasname: AnsiString read mPasName;
152 property name: AnsiString read mName;
153 property baseType: TType read mType;
154 property negbool: Boolean read mNegBool;
155 property defined: Boolean read mDefined write mDefined;
156 property internal: Boolean read mInternal write mInternal;
157 property hasTPrefix: Boolean read mAsT;
158 property separatePasFields: Boolean read mSepPosSize;
159 property binOfs: Integer read mBinOfs;
160 property ival: Integer read mIVal write setIVal;
161 property ival2: Integer read mIVal2;
162 property sval: AnsiString read mSVal;
163 property hasDefault: Boolean read mHasDefault;
164 property defsval: AnsiString read mDefSVal;
165 property ebs: TEBS read mEBS;
166 property ebstype: TObject read mEBSType;
167 property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name
168 property recref: TDynRecord read mRecRef write mRecRef; //FIXME: writing is a hack!
169 property recrefIndex: Integer read getRecRefIndex; // search for this record in header; -1: not found
170 // for lists
171 property count: Integer read getListCount;
172 property item[idx: Integer]: TDynRecord read getListItem;
173 property items[const aname: AnsiString]: TDynRecord read getListItem; default; // alas, FPC 3+ lost property overloading feature
174 // userdata
175 property tagInt: Integer read mTagInt write mTagInt;
176 property tagPtr: Pointer read mTagPtr write mTagPtr;
177 end;
180 // "value" header record contains TList fields, with name equal to record type
181 TDynRecord = class
182 private
183 mOwner: TDynMapDef;
184 mId: AnsiString;
185 mPasName: AnsiString;
186 mName: AnsiString;
187 mSize: Integer;
188 mFields: TDynFieldList;
189 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
190 mFieldsHash: THashStrInt; // id -> index in mRVal
191 {$ENDIF}
192 mTrigTypes: array of AnsiString; // if this is triggerdata, we'll hold list of triggers here
193 mHeader: Boolean; // true for header record
194 mBinBlock: Integer; // -1: none
195 mHeaderRec: TDynRecord; // for "value" records this is header record with data, for "type" records this is header type record
197 // for userdata
198 mTagInt: Integer;
199 mTagPtr: Pointer;
201 private
202 procedure parseDef (pr: TTextParser); // parse definition
204 function findByName (const aname: AnsiString): Integer; inline;
205 function hasByName (const aname: AnsiString): Boolean; inline;
206 function getFieldByName (const aname: AnsiString): TDynField; inline;
207 function getFieldAt (idx: Integer): TDynField; inline;
208 function getCount (): Integer; inline;
210 function getIsTrigData (): Boolean; inline;
211 function getIsForTrig (const aname: AnsiString): Boolean; inline;
213 function getForTrigCount (): Integer; inline;
214 function getForTrigAt (idx: Integer): AnsiString; inline;
216 protected
217 function findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
218 function findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
219 function addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean; // `true`: duplicate record id
221 procedure addField (fld: TDynField); inline;
222 function addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
224 public
225 constructor Create ();
226 constructor Create (pr: TTextParser); // parse definition
227 destructor Destroy (); override;
229 function definition (): AnsiString;
230 function pasdef (): AnsiString;
232 function clone (): TDynRecord;
234 function isSimpleEqu (rec: TDynRecord): Boolean;
236 procedure parseValue (pr: TTextParser; beginEaten: Boolean=false);
237 procedure parseBinValue (st: TStream; forceData: Boolean=false);
239 procedure writeTo (wr: TTextWriter; putHeader: Boolean=true);
240 procedure writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
242 // find field with `TriggerType` type
243 function trigTypeField (): TDynField;
245 // number of records of the given instance
246 function instanceCount (const typename: AnsiString): Integer;
248 public
249 property id: AnsiString read mId; // for map parser
250 property pasname: AnsiString read mPasName;
251 property name: AnsiString read mName; // record name
252 property size: Integer read mSize; // size in bytes
253 //property fields: TDynFieldList read mFields;
254 property has[const aname: AnsiString]: Boolean read hasByName;
255 property count: Integer read getCount;
256 property field[const aname: AnsiString]: TDynField read getFieldByName; default;
257 property fieldAt[idx: Integer]: TDynField read getFieldAt;
258 property isTrigData: Boolean read getIsTrigData;
259 property isForTrig[const aname: AnsiString]: Boolean read getIsForTrig;
260 property forTrigCount: Integer read getForTrigCount;
261 property forTrigAt[idx: Integer]: AnsiString read getForTrigAt;
262 property headerRec: TDynRecord read mHeaderRec;
263 property isHeader: Boolean read mHeader;
264 // userdata
265 property tagInt: Integer read mTagInt write mTagInt;
266 property tagPtr: Pointer read mTagPtr write mTagPtr;
267 end;
269 TDynEBS = class
270 private
271 mOwner: TDynMapDef;
272 mIsEnum: Boolean;
273 mName: AnsiString;
274 mIds: array of AnsiString;
275 mVals: array of Integer;
276 mMaxName: AnsiString; // MAX field
277 mMaxVal: Integer; // max value
279 private
280 procedure cleanup ();
282 procedure parseDef (pr: TTextParser); // parse definition
284 function findByName (const aname: AnsiString): Integer; inline;
285 function hasByName (const aname: AnsiString): Boolean; inline;
286 function getFieldByName (const aname: AnsiString): Integer; inline;
288 public
289 constructor Create (pr: TTextParser); // parse definition
290 destructor Destroy (); override;
292 function definition (): AnsiString;
293 function pasdef (): AnsiString;
295 // return empty string if not found
296 function nameByValue (v: Integer): AnsiString;
298 public
299 property name: AnsiString read mName; // record name
300 property isEnum: Boolean read mIsEnum;
301 property has[const aname: AnsiString]: Boolean read hasByName;
302 property field[const aname: AnsiString]: Integer read getFieldByName;
303 end;
306 TDynMapDef = class
307 public
308 recTypes: TDynRecList; // [0] is always header
309 trigTypes: TDynRecList; // trigdata
310 ebsTypes: TDynEBSList; // enums, bitsets
312 private
313 procedure parseDef (pr: TTextParser);
315 function getHeaderRecType (): TDynRecord; inline;
317 function getTrigTypeCount (): Integer; inline;
318 function getTrigTypeAt (idx: Integer): TDynRecord; inline;
320 public
321 constructor Create (pr: TTextParser); // parses data definition
322 destructor Destroy (); override;
324 function findRecType (const aname: AnsiString): TDynRecord;
325 function findTrigFor (const aname: AnsiString): TDynRecord;
326 function findEBSType (const aname: AnsiString): TDynEBS;
328 function pasdef (): AnsiString;
329 function pasdefconst (): AnsiString;
331 // creates new header record
332 function parseMap (pr: TTextParser): TDynRecord;
334 // creates new header record
335 function parseBinMap (st: TStream): TDynRecord;
337 public
338 property headerType: TDynRecord read getHeaderRecType;
339 property trigTypeCount: Integer read getTrigTypeCount;
340 property trigType[idx: Integer]: TDynRecord read getTrigTypeAt;
341 end;
344 {$IF DEFINED(D2D_DYNREC_PROFILER)}
345 procedure xdynDumpProfiles ();
346 {$ENDIF}
349 implementation
351 uses
352 SysUtils, e_log
353 {$IF DEFINED(D2D_DYNREC_PROFILER)},xprofiler{$ENDIF};
356 // ////////////////////////////////////////////////////////////////////////// //
357 function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
360 // ////////////////////////////////////////////////////////////////////////// //
361 constructor TDynField.TListEnumerator.Create (alist: TDynRecList);
362 begin
363 mList := alist;
364 mCurIdx := -1;
365 end;
368 function TDynField.TListEnumerator.MoveNext (): Boolean; inline;
369 begin
370 Inc(mCurIdx);
371 result := (mList <> nil) and (mCurIdx < mList.count);
372 end;
375 function TDynField.TListEnumerator.getCurrent (): TDynRecord; inline;
376 begin
377 result := mList[mCurIdx];
378 end;
381 function TDynField.GetEnumerator (): TListEnumerator;
382 begin
383 result := TListEnumerator.Create(mRVal);
384 end;
387 // ////////////////////////////////////////////////////////////////////////// //
388 constructor TDynField.Create (const aname: AnsiString; atype: TType);
389 begin
390 mRVal := nil;
391 mRecRef := nil;
392 mRHash := nil;
393 cleanup();
394 mName := aname;
395 mType := atype;
396 if (mType = TType.TList) then
397 begin
398 mRVal := TDynRecList.Create();
399 mRHash := hashNewStrInt();
400 end;
401 end;
404 constructor TDynField.Create (pr: TTextParser);
405 begin
406 cleanup();
407 parseDef(pr);
408 end;
411 destructor TDynField.Destroy ();
412 begin
413 cleanup();
414 inherited;
415 end;
418 procedure TDynField.cleanup ();
419 begin
420 mName := '';
421 mType := TType.TInt;
422 mIVal := 0;
423 mIVal2 := 0;
424 mSVal := '';
425 mRVal.Free();
426 mRVal := nil;
427 mRHash.Free();
428 mRHash := nil;
429 mRecRef := nil;
430 mMaxDim := -1;
431 mBinOfs := -1;
432 mSepPosSize := false;
433 mAsT := false;
434 mHasDefault := false;
435 mDefined := false;
436 mOmitDef := false;
437 mInternal := true;
438 mDefUnparsed := '';
439 mDefSVal := '';
440 mDefIVal := 0;
441 mDefIVal2 := 0;
442 mDefRecRef := nil;
443 mEBS := TEBS.TNone;
444 mEBSTypeName := '';
445 mEBSType := nil;
446 mBitSetUnique := false;
447 mAsMonsterId := false;
448 mNegBool := false;
449 mRecRefId := '';
450 mTagInt := 0;
451 mTagPtr := nil;
452 end;
455 function TDynField.clone (newOwner: TDynRecord=nil): TDynField;
456 var
457 rec: TDynRecord;
458 begin
459 result := TDynField.Create(mName, mType);
460 result.mOwner := mOwner;
461 if (newOwner <> nil) then result.mOwner := newOwner else result.mOwner := mOwner;
462 result.mPasName := mPasName;
463 result.mName := mName;
464 result.mType := mType;
465 result.mIVal := mIVal;
466 result.mIVal2 := mIVal2;
467 result.mSVal := mSVal;
468 if (mRVal <> nil) then
469 begin
470 if (result.mRVal = nil) then result.mRVal := TDynRecList.Create(mRVal.count);
471 if (result.mRHash = nil) then result.mRHash := hashNewStrInt();
472 for rec in mRVal do result.addListItem(rec.clone());
473 end;
474 result.mRecRef := mRecRef;
475 result.mMaxDim := mMaxDim;
476 result.mBinOfs := mBinOfs;
477 result.mSepPosSize := mSepPosSize;
478 result.mAsT := mAsT;
479 result.mDefined := mDefined;
480 result.mHasDefault := mHasDefault;
481 result.mOmitDef := mOmitDef;
482 result.mInternal := mInternal;
483 result.mNegBool := mNegBool;
484 result.mBitSetUnique := mBitSetUnique;
485 result.mAsMonsterId := mAsMonsterId;
486 result.mDefUnparsed := mDefUnparsed;
487 result.mDefSVal := mDefSVal;
488 result.mDefIVal := mDefIVal;
489 result.mDefIVal2 := mDefIVal2;
490 result.mDefRecRef := mDefRecRef;
491 result.mEBS := mEBS;
492 result.mEBSTypeName := mEBSTypeName;
493 result.mEBSType := mEBSType;
494 result.mRecRefId := mRecRefId;
495 result.mTagInt := mTagInt;
496 result.mTagPtr := mTagPtr;
497 end;
500 procedure TDynField.setIVal (v: Integer); inline;
501 begin
502 //FIXME: check type
503 mIVal := v;
504 mDefined := true;
505 end;
508 // won't work for lists
509 function TDynField.isSimpleEqu (fld: TDynField): Boolean;
510 begin
511 if (fld = nil) or (mType <> fld.mType) then begin result := false; exit; end;
512 case mType of
513 TType.TBool: result := ((mIVal <> 0) = (fld.mIVal <> 0));
514 TType.TChar: result := (mSVal = fld.mSVal);
515 TType.TByte,
516 TType.TUByte,
517 TType.TShort,
518 TType.TUShort,
519 TType.TInt,
520 TType.TUInt:
521 result := (mIVal = fld.mIVal);
522 TType.TString: result := (mSVal = fld.mSVal);
523 TType.TPoint,
524 TType.TSize:
525 result := ((mIVal = fld.mIVal) and (mIVal2 = fld.mIVal2));
526 TType.TList: result := false;
527 TType.TTrigData:
528 begin
529 if (mRecRef = nil) then begin result := (fld.mRecRef = nil); exit; end;
530 result := mRecRef.isSimpleEqu(fld.mRecRef);
531 end;
532 else raise Exception.Create('ketmar forgot to handle some field type');
533 end;
534 end;
537 procedure TDynField.setValue (const s: AnsiString);
538 var
539 stp: TTextParser;
540 begin
541 stp := TStrTextParser.Create(s+';');
542 try
543 parseValue(stp);
544 finally
545 stp.Free();
546 end;
547 end;
550 procedure TDynField.parseDefaultValue ();
551 var
552 stp: TTextParser = nil;
553 oSVal: AnsiString;
554 oIVal, oIVal2: Integer;
555 oRRef: TDynRecord;
556 oDef: Boolean;
557 begin
558 if not mHasDefault then
559 begin
560 mDefSVal := '';
561 mDefIVal := 0;
562 mDefIVal2 := 0;
563 mDefRecRef := nil;
564 end
565 else
566 begin
567 oSVal := mSVal;
568 oIVal := mIVal;
569 oIVal2 := mIVal2;
570 oRRef := mRecRef;
571 oDef := mDefined;
572 try
573 stp := TStrTextParser.Create(mDefUnparsed+';');
574 parseValue(stp);
575 mDefSVal := mSVal;
576 mDefIVal := mIVal;
577 mDefIVal2 := mIVal2;
578 mDefRecRef := mRecRef;
579 finally
580 mSVal := oSVal;
581 mIVal := oIVal;
582 mIVal2 := oIVal2;
583 mRecRef := oRRef;
584 mDefined := oDef;
585 stp.Free();
586 end;
587 end;
588 end;
591 // default value should be parsed
592 procedure TDynField.fixDefaultValue ();
593 begin
594 if mDefined then exit;
595 if not mHasDefault then
596 begin
597 if mInternal then exit;
598 raise Exception.Create(Format('field ''%s'' in record ''%s'' of record type ''%s'' is not set', [mName, mOwner.mId, mOwner.mName]));
599 end;
600 if (mEBS = TEBS.TRec) then mRecRef := mDefRecRef;
601 mSVal := mDefSVal;
602 mIVal := mDefIVal;
603 mIVal2 := mDefIVal2;
604 mDefined := true;
605 end;
608 // default value should be parsed
609 function TDynField.isDefaultValue (): Boolean;
610 begin
611 if not mHasDefault then begin result := false; exit; end;
612 if (mEBS = TEBS.TRec) then begin result := (mRecRef = mDefRecRef); exit; end;
613 case mType of
614 TType.TChar, TType.TString: result := (mSVal = mDefSVal);
615 TType.TPoint, TType.TSize: result := (mIVal = mDefIVal2) and (mIVal2 = mDefIVal2);
616 TType.TList, TType.TTrigData: result := false; // no default values for those types
617 else result := (mIVal = mDefIVal);
618 end;
619 end;
622 function TDynField.getListCount (): Integer; inline;
623 begin
624 if (mRVal <> nil) then result := mRVal.count else result := 0;
625 end;
628 function TDynField.getListItem (idx: Integer): TDynRecord; inline; overload;
629 begin
630 if (mRVal <> nil) and (idx >= 0) and (idx < mRVal.count) then result := mRVal[idx] else result := nil;
631 end;
634 function TDynField.getListItem (const aname: AnsiString): TDynRecord; inline; overload;
635 var
636 idx: Integer;
637 begin
638 if (mRVal <> nil) and mRHash.get(aname, idx) then result := mRVal[idx] else result := nil;
639 end;
642 function TDynField.addListItem (rec: TDynRecord): Boolean; inline;
643 begin
644 result := false;
645 if (mRVal <> nil) then
646 begin
647 mRVal.append(rec);
648 if (Length(rec.mId) > 0) then result := mRHash.put(rec.mId, mRVal.count-1);
649 end;
650 end;
653 class function TDynField.getTypeName (t: TType): AnsiString;
654 begin
655 case t of
656 TType.TBool: result := 'bool';
657 TType.TChar: result := 'char';
658 TType.TByte: result := 'byte';
659 TType.TUByte: result := 'ubyte';
660 TType.TShort: result := 'short';
661 TType.TUShort: result := 'ushort';
662 TType.TInt: result := 'int';
663 TType.TUInt: result := 'uint';
664 TType.TString: result := 'string';
665 TType.TPoint: result := 'point';
666 TType.TSize: result := 'size';
667 TType.TList: result := 'array';
668 TType.TTrigData: result := 'trigdata';
669 else raise Exception.Create('ketmar forgot to handle some field type');
670 end;
671 end;
674 function TDynField.definition (): AnsiString;
675 begin
676 result := mPasName+' is '+quoteStr(mName)+' type ';
677 result += getTypeName(mType);
678 if (mMaxDim >= 0) then result += Format('[%d]', [mMaxDim]);
679 if (mBinOfs >= 0) then result += Format(' offset %d', [mBinOfs]);
680 case mEBS of
681 TEBS.TNone: begin end;
682 TEBS.TRec: result += ' '+mEBSTypeName;
683 TEBS.TEnum: result += ' enum '+mEBSTypeName;
684 TEBS.TBitSet: begin result += ' bitset '; if mBitSetUnique then result += 'unique '; result += mEBSTypeName; end;
685 end;
686 if mAsMonsterId then result += ' as monsterid';
687 if mHasDefault and (Length(mDefUnparsed) > 0) then result += ' default '+mDefUnparsed;
688 if mSepPosSize then
689 begin
690 if (mType = TType.TPoint) then begin if (mAsT) then result += ' as txy' else result += ' as xy'; end
691 else if (mType = TType.TSize) then begin if (mAsT) then result += ' as twh' else result += ' as wh'; end;
692 end;
693 if mOmitDef then result += ' omitdefault';
694 if mInternal then result += ' internal';
695 end;
698 function TDynField.pasdef (): AnsiString;
699 begin
700 result := mPasName+': ';
701 case mType of
702 TType.TBool: result += 'Boolean;';
703 TType.TChar: if (mMaxDim > 0) then result += formatstrf('Char%d;', [mMaxDim]) else result += 'Char;';
704 TType.TByte: result += 'ShortInt;';
705 TType.TUByte: result += 'Byte;';
706 TType.TShort: result += 'SmallInt;';
707 TType.TUShort: result += 'Word;';
708 TType.TInt: result += 'LongInt;';
709 TType.TUInt: result += 'LongWord;';
710 TType.TString: result += 'AnsiString;';
711 TType.TPoint:
712 if mAsT then result := 'tX, tY: Integer;'
713 else if mSepPosSize then result := 'X, Y: Integer;'
714 else result += 'TDFPoint;';
715 TType.TSize:
716 if mAsT then result := 'tWidth, tHeight: Word;'
717 else if mSepPosSize then result := 'Width, Height: Word;'
718 else result += 'TSize;';
719 TType.TList: assert(false);
720 TType.TTrigData: result += formatstrf('Byte%d;', [mMaxDim]);
721 else raise Exception.Create('ketmar forgot to handle some field type');
722 end;
723 end;
726 procedure TDynField.parseDef (pr: TTextParser);
727 var
728 fldname: AnsiString;
729 fldtype: AnsiString;
730 fldofs: Integer;
731 fldrecname: AnsiString;
732 fldpasname: AnsiString;
733 asxy, aswh, ast: Boolean;
734 ainternal: Boolean;
735 omitdef: Boolean;
736 defstr: AnsiString;
737 defint: Integer;
738 hasdefStr: Boolean;
739 hasdefInt: Boolean;
740 hasdefId: Boolean;
741 lmaxdim: Integer;
742 lebs: TDynField.TEBS;
743 unique: Boolean;
744 asmonid: Boolean;
745 begin
746 fldpasname := '';
747 fldname := '';
748 fldtype := '';
749 fldofs := -1;
750 fldrecname := '';
751 asxy := false;
752 aswh := false;
753 ast := false;
754 ainternal := false;
755 omitdef := false;
756 defstr := '';
757 defint := 0;
758 hasdefStr := false;
759 hasdefInt := false;
760 hasdefId := false;
761 unique := false;
762 asmonid := false;
763 lmaxdim := -1;
764 lebs := TDynField.TEBS.TNone;
766 fldpasname := pr.expectId(); // pascal field name
767 // field name
768 pr.expectId('is');
769 fldname := pr.expectStr();
770 // field type
771 pr.expectId('type');
772 fldtype := pr.expectId();
774 // fixed-size array?
775 if pr.eatDelim('[') then
776 begin
777 lmaxdim := pr.expectInt();
778 if (lmaxdim < 1) then raise Exception.Create(Format('invalid field ''%s'' array size', [fldname]));
779 pr.expectDelim(']');
780 end;
782 while (pr.tokType <> pr.TTSemi) do
783 begin
784 if pr.eatId('offset') then
785 begin
786 if (fldofs >= 0) then raise Exception.Create(Format('duplicate field ''%s'' offset', [fldname]));
787 fldofs := pr.expectInt();
788 if (fldofs < 0) then raise Exception.Create(Format('invalid field ''%s'' offset', [fldname]));
789 continue;
790 end;
792 if pr.eatId('as') then
793 begin
794 if pr.eatId('xy') then asxy := true
795 else if pr.eatId('wh') then aswh := true
796 else if pr.eatId('txy') then begin asxy := true; ast := true; end
797 else if pr.eatId('twh') then begin aswh := true; ast := true; end
798 else if pr.eatId('monsterid') then begin asmonid := true; end
799 else raise Exception.Create(Format('invalid field ''%s'' as what?', [fldname]));
800 continue;
801 end;
803 if pr.eatId('enum') then
804 begin
805 lebs := TDynField.TEBS.TEnum;
806 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
807 fldrecname := pr.expectId();
808 continue;
809 end;
811 if pr.eatId('bitset') then
812 begin
813 lebs := TDynField.TEBS.TBitSet;
814 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
815 unique := pr.eatId('unique');
816 fldrecname := pr.expectId();
817 continue;
818 end;
820 if pr.eatId('default') then
821 begin
822 if hasdefStr or hasdefInt or hasdefId then raise Exception.Create(Format('field ''%s'' has duplicate default', [fldname]));
823 case pr.tokType of
824 pr.TTStr:
825 begin
826 hasdefStr := true;
827 defstr := pr.expectStr(true); // allow empty strings
828 end;
829 pr.TTId:
830 begin
831 hasdefId := true;
832 defstr := pr.expectId();
833 end;
834 pr.TTInt:
835 begin
836 hasdefInt := true;
837 defint := pr.expectInt();
838 end;
839 else
840 raise Exception.Create(Format('field ''%s'' has invalid default', [fldname]));
841 end;
842 continue;
843 end;
845 if pr.eatId('omitdefault') then
846 begin
847 omitdef := true;
848 continue;
849 end;
851 if pr.eatId('internal') then
852 begin
853 ainternal := true;
854 continue;
855 end;
857 if (pr.tokType <> pr.TTId) then raise Exception.Create(Format('field ''%s'' has something unexpected in definition', [fldname]));
859 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
860 fldrecname := pr.expectId();
861 lebs := TDynField.TEBS.TRec;
862 end;
864 pr.expectTT(pr.TTSemi);
866 // create field
867 mName := fldname;
868 if (fldtype = 'bool') then mType := TType.TBool
869 else if (fldtype = 'negbool') then begin mType := TType.TBool; mNegBool := true; end
870 else if (fldtype = 'char') then mType := TType.TChar
871 else if (fldtype = 'byte') then mType := TType.TByte
872 else if (fldtype = 'ubyte') then mType := TType.TUByte
873 else if (fldtype = 'short') then mType := TType.TShort
874 else if (fldtype = 'ushort') then mType := TType.TUShort
875 else if (fldtype = 'int') then mType := TType.TInt
876 else if (fldtype = 'uint') then mType := TType.TUInt
877 else if (fldtype = 'string') then mType := TType.TString
878 else if (fldtype = 'point') then mType := TType.TPoint
879 else if (fldtype = 'size') then mType := TType.TSize
880 else if (fldtype = 'trigdata') then mType := TType.TTrigData
881 else raise Exception.Create(Format('field ''%s'' has invalid type ''%s''', [fldname, fldtype]));
883 if (lmaxdim > 0) and (mType <> TType.TChar) and (mType <> TType.TTrigData) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype]));
884 if (mType = TType.TTrigData) then
885 begin
886 if (lmaxdim < 1) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype]));
887 if (Length(fldrecname) > 0) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot have another type', [fldname, fldtype]));
888 lebs := TDynField.TEBS.TRec;
889 end;
891 if hasdefStr then self.mDefUnparsed := quoteStr(defstr)
892 else if hasdefInt then self.mDefUnparsed := Format('%d', [defint])
893 else if hasdefId then self.mDefUnparsed := defstr;
895 self.mHasDefault := (hasdefStr or hasdefId or hasdefInt);
896 self.mPasName := fldpasname;
897 self.mEBS := lebs;
898 self.mEBSTypeName := fldrecname;
899 self.mBitSetUnique := unique;
900 self.mAsMonsterId := asmonid;
901 self.mMaxDim := lmaxdim;
902 self.mBinOfs := fldofs;
903 self.mSepPosSize := (asxy or aswh);
904 self.mAsT := ast;
905 self.mOmitDef := omitdef;
906 self.mInternal := ainternal;
907 end;
910 function TDynField.getRecRefIndex (): Integer;
911 begin
912 if (mRecRef = nil) then begin result := -1; exit; end;
913 result := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
914 end;
917 procedure TDynField.writeBinTo (st: TStream);
918 var
919 s: AnsiString;
920 f: Integer;
921 maxv: Integer;
922 buf: PByte;
923 ws: TStream = nil;
924 begin
925 case mEBS of
926 TEBS.TNone: begin end;
927 TEBS.TRec:
928 begin
929 if (mMaxDim >= 0) then
930 begin
931 // this must be triggerdata
932 if (mType <> TType.TTrigData) then
933 begin
934 raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
935 end;
936 // write triggerdata
937 GetMem(buf, mMaxDim);
938 if (buf = nil) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
939 try
940 FillChar(buf^, mMaxDim, 0);
941 if (mRecRef <> nil) then
942 begin
943 ws := TSFSMemoryChunkStream.Create(buf, mMaxDim);
944 mRecRef.writeBinTo(ws, mMaxDim); // as trigdata
945 end;
946 st.WriteBuffer(buf^, mMaxDim);
947 finally
948 ws.Free();
949 if (buf <> nil) then FreeMem(buf);
950 end;
951 exit;
952 end;
953 // record reference
954 case mType of
955 TType.TByte: maxv := 127;
956 TType.TUByte: maxv := 254;
957 TType.TShort: maxv := 32767;
958 TType.TUShort: maxv := 65534;
959 TType.TInt: maxv := $7fffffff;
960 TType.TUInt: maxv := $7fffffff;
961 else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
962 end;
963 // find record number
964 if (mRecRef <> nil) then
965 begin
966 f := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
967 if (f < 0) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' not found in record list', [mEBSTypeName, mName]));
968 if mAsMonsterId then Inc(f);
969 if (f > maxv) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' has too big index', [mEBSTypeName, mName]));
970 end
971 else
972 begin
973 if mAsMonsterId then f := 0 else f := -1;
974 end;
975 case mType of
976 TType.TByte, TType.TUByte: writeInt(st, Byte(f));
977 TType.TShort, TType.TUShort: writeInt(st, SmallInt(f));
978 TType.TInt, TType.TUInt: writeInt(st, LongWord(f));
979 else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
980 end;
981 exit;
982 end;
983 TEBS.TEnum: begin end;
984 TEBS.TBitSet: begin end;
985 else raise Exception.Create('ketmar forgot to handle some EBS type');
986 end;
988 case mType of
989 TType.TBool:
990 begin
991 if not mNegBool then
992 begin
993 if (mIVal <> 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
994 end
995 else
996 begin
997 if (mIVal = 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
998 end;
999 exit;
1000 end;
1001 TType.TChar:
1002 begin
1003 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1004 if (mMaxDim < 0) then
1005 begin
1006 if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1007 writeInt(st, Byte(mSVal[1]));
1008 end
1009 else
1010 begin
1011 if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1012 s := utf2win(mSVal);
1013 if (Length(s) > 0) then st.WriteBuffer(PChar(s)^, Length(s));
1014 for f := Length(s) to mMaxDim do writeInt(st, Byte(0));
1015 end;
1016 exit;
1017 end;
1018 TType.TByte,
1019 TType.TUByte:
1020 begin
1021 // triggerdata array was processed earlier
1022 if (mMaxDim >= 0) then Exception.Create(Format('byte array in field ''%s'' cannot be written', [mName]));
1023 writeInt(st, Byte(mIVal));
1024 exit;
1025 end;
1026 TType.TShort,
1027 TType.TUShort:
1028 begin
1029 if (mMaxDim >= 0) then raise Exception.Create(Format('short array in field ''%s'' cannot be written', [mName]));
1030 writeInt(st, Word(mIVal));
1031 exit;
1032 end;
1033 TType.TInt,
1034 TType.TUInt:
1035 begin
1036 if (mMaxDim >= 0) then raise Exception.Create(Format('int array in field ''%s'' cannot be written', [mName]));
1037 writeInt(st, LongWord(mIVal));
1038 exit;
1039 end;
1040 TType.TString:
1041 begin
1042 raise Exception.Create(Format('cannot write string field ''%s''', [mName]));
1043 end;
1044 TType.TPoint:
1045 begin
1046 if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName]));
1047 writeInt(st, LongInt(mIVal));
1048 writeInt(st, LongInt(mIVal2));
1049 exit;
1050 end;
1051 TType.TSize:
1052 begin
1053 if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName]));
1054 writeInt(st, Word(mIVal));
1055 writeInt(st, Word(mIVal2));
1056 exit;
1057 end;
1058 TType.TList:
1059 begin
1060 assert(false);
1061 exit;
1062 end;
1063 TType.TTrigData:
1064 begin
1065 assert(false);
1066 exit;
1067 end;
1068 else raise Exception.Create('ketmar forgot to handle some field type');
1069 end;
1070 end;
1073 procedure TDynField.writeTo (wr: TTextWriter);
1074 var
1075 es: TDynEBS = nil;
1076 f, mask: Integer;
1077 first, found: Boolean;
1078 begin
1079 wr.put(mName);
1080 wr.put(' ');
1081 case mEBS of
1082 TEBS.TNone: begin end;
1083 TEBS.TRec:
1084 begin
1085 if (mRecRef = nil) then
1086 begin
1087 if (mType = TType.TTrigData) then wr.put('{}'#10) else wr.put('null;'#10);
1088 end
1089 else if (Length(mRecRef.mId) = 0) then
1090 begin
1091 mRecRef.writeTo(wr, false); // only data, no header
1092 end
1093 else
1094 begin
1095 wr.put(mRecRef.mId);
1096 wr.put(';'#10);
1097 end;
1098 exit;
1099 end;
1100 TEBS.TEnum:
1101 begin
1102 //def := mOwner.mOwner;
1103 //es := def.findEBSType(mEBSTypeName);
1104 es := nil;
1105 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1106 if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1107 for f := 0 to High(es.mVals) do
1108 begin
1109 if (es.mVals[f] = mIVal) then
1110 begin
1111 wr.put(es.mIds[f]);
1112 wr.put(';'#10);
1113 exit;
1114 end;
1115 end;
1116 raise Exception.Create(Format('value %d in record enum type ''%s'' for field ''%s'' not found', [mIVal, mEBSTypeName, mName]));
1117 end;
1118 TEBS.TBitSet:
1119 begin
1120 //def := mOwner.mOwner;
1121 //es := def.findEBSType(mEBSTypeName);
1122 es := nil;
1123 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1124 if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1125 // none?
1126 if (mIVal = 0) then
1127 begin
1128 for f := 0 to High(es.mVals) do
1129 begin
1130 if (es.mVals[f] = 0) then
1131 begin
1132 wr.put(es.mIds[f]);
1133 wr.put(';'#10);
1134 exit;
1135 end;
1136 end;
1137 raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [0, mEBSTypeName, mName]));
1138 end;
1139 // not none
1140 mask := 1;
1141 first := true;
1142 while (mask <> 0) do
1143 begin
1144 if ((mIVal and mask) <> 0) then
1145 begin
1146 found := false;
1147 for f := 0 to High(es.mVals) do
1148 begin
1149 if (es.mVals[f] = mask) then
1150 begin
1151 if not first then wr.put('+') else first := false;
1152 wr.put(es.mIds[f]);
1153 found := true;
1154 break;
1155 end;
1156 end;
1157 if not found then raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [mask, mEBSTypeName, mName]));
1158 end;
1159 mask := mask shl 1;
1160 end;
1161 wr.put(';'#10);
1162 exit;
1163 end;
1164 else raise Exception.Create('ketmar forgot to handle some EBS type');
1165 end;
1167 case mType of
1168 TType.TBool:
1169 begin
1170 if (mIVal = 0) then wr.put('false;'#10) else wr.put('true;'#10);
1171 exit;
1172 end;
1173 TType.TChar:
1174 begin
1175 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1176 wr.put(quoteStr(mSVal));
1177 wr.put(';'#10);
1178 exit;
1179 end;
1180 TType.TByte,
1181 TType.TUByte,
1182 TType.TShort,
1183 TType.TUShort,
1184 TType.TInt,
1185 TType.TUInt:
1186 begin
1187 wr.put('%d;'#10, [mIVal]);
1188 exit;
1189 end;
1190 TType.TString:
1191 begin
1192 wr.put(quoteStr(mSVal));
1193 wr.put(';'#10);
1194 exit;
1195 end;
1196 TType.TPoint,
1197 TType.TSize:
1198 begin
1199 wr.put('(%d %d);'#10, [mIVal, mIVal2]);
1200 exit;
1201 end;
1202 TType.TList:
1203 begin
1204 assert(false);
1205 exit;
1206 end;
1207 TType.TTrigData:
1208 begin
1209 assert(false);
1210 exit;
1211 end;
1212 else raise Exception.Create('ketmar forgot to handle some field type');
1213 end;
1214 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1215 end;
1218 procedure TDynField.parseBinValue (st: TStream);
1219 var
1220 rec, rc: TDynRecord;
1221 tfld: TDynField;
1222 es: TDynEBS = nil;
1223 tdata: PByte = nil;
1224 f, mask: Integer;
1225 s: AnsiString;
1226 begin
1227 case mEBS of
1228 TEBS.TNone: begin end;
1229 TEBS.TRec:
1230 begin
1231 // this must be triggerdata
1232 if (mType = TType.TTrigData) then
1233 begin
1234 assert(mMaxDim > 0);
1235 rec := mOwner;
1236 // find trigger definition
1237 tfld := rec.trigTypeField();
1238 if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mName]));
1239 rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
1240 if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
1241 rc := rc.clone();
1242 rc.mHeaderRec := mOwner.mHeaderRec;
1243 try
1244 rc.parseBinValue(st, true);
1245 mRecRef := rc;
1246 rc := nil;
1247 finally
1248 rc.Free();
1249 end;
1250 mDefined := true;
1251 exit;
1252 end
1253 else
1254 begin
1255 // not a trigger data
1256 case mType of
1257 TType.TByte: f := readShortInt(st);
1258 TType.TUByte: f := readByte(st);
1259 TType.TShort: f := readSmallInt(st);
1260 TType.TUShort: f := readWord(st);
1261 TType.TInt: f := readLongInt(st);
1262 TType.TUInt: f := readLongWord(st);
1263 else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]));
1264 end;
1265 if mAsMonsterId then Dec(f);
1266 if (f < 0) then mRecRefId := '' else mRecRefId := Format('%s%d', [mEBSTypeName, f]);
1267 end;
1268 mDefined := true;
1269 exit;
1270 end;
1271 TEBS.TEnum,
1272 TEBS.TBitSet:
1273 begin
1274 assert(mMaxDim < 0);
1275 case mType of
1276 TType.TByte: f := readShortInt(st);
1277 TType.TUByte: f := readByte(st);
1278 TType.TShort: f := readSmallInt(st);
1279 TType.TUShort: f := readWord(st);
1280 TType.TInt: f := readLongInt(st);
1281 TType.TUInt: f := readLongWord(st);
1282 else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]));
1283 end;
1284 es := nil;
1285 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1286 if (es = nil) or (es.mIsEnum <> (mEBS = TEBS.TEnum)) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1287 mIVal := f;
1288 // build enum/bitfield values
1289 if (mEBS = TEBS.TEnum) then
1290 begin
1291 mSVal := es.nameByValue(mIVal);
1292 if (Length(mSVal) = 0) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]));
1293 end
1294 else
1295 begin
1296 // special for 'none'
1297 if (mIVal = 0) then
1298 begin
1299 mSVal := es.nameByValue(mIVal);
1300 if (Length(mSVal) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]));
1301 end
1302 else
1303 begin
1304 mSVal := '';
1305 mask := 1;
1306 while (mask <> 0) do
1307 begin
1308 if ((mIVal and mask) <> 0) then
1309 begin
1310 s := es.nameByValue(mask);
1311 if (Length(s) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mask]));
1312 if (Length(mSVal) <> 0) then mSVal += '+';
1313 mSVal += s;
1314 end;
1315 mask := mask shl 1;
1316 end;
1317 end;
1318 end;
1319 //writeln('ebs <', es.mName, '>: ', mSVal);
1320 mDefined := true;
1321 exit;
1322 end;
1323 else raise Exception.Create('ketmar forgot to handle some EBS type');
1324 end;
1326 case mType of
1327 TType.TBool:
1328 begin
1329 f := readByte(st);
1330 if (f <> 0) then f := 1;
1331 if mNegBool then f := 1-f;
1332 mIVal := f;
1333 mDefined := true;
1334 exit;
1335 end;
1336 TType.TChar:
1337 begin
1338 if (mMaxDim < 0) then
1339 begin
1340 mIVal := readByte(st);
1341 end
1342 else
1343 begin
1344 mSVal := '';
1345 GetMem(tdata, mMaxDim);
1346 try
1347 st.ReadBuffer(tdata^, mMaxDim);
1348 f := 0;
1349 while (f < mMaxDim) and (tdata[f] <> 0) do Inc(f);
1350 if (f > 0) then
1351 begin
1352 SetLength(mSVal, f);
1353 Move(tdata^, PChar(mSVal)^, f);
1354 mSVal := win2utf(mSVal);
1355 end;
1356 finally
1357 FreeMem(tdata);
1358 end;
1359 end;
1360 mDefined := true;
1361 exit;
1362 end;
1363 TType.TByte: begin mIVal := readShortInt(st); mDefined := true; exit; end;
1364 TType.TUByte: begin mIVal := readByte(st); mDefined := true; exit; end;
1365 TType.TShort: begin mIVal := readSmallInt(st); mDefined := true; exit; end;
1366 TType.TUShort: begin mIVal := readWord(st); mDefined := true; exit; end;
1367 TType.TInt: begin mIVal := readLongInt(st); mDefined := true; exit; end;
1368 TType.TUInt: begin mIVal := readLongWord(st); mDefined := true; exit; end;
1369 TType.TString:
1370 begin
1371 raise Exception.Create('cannot read strings from binaries yet');
1372 exit;
1373 end;
1374 TType.TPoint:
1375 begin
1376 mIVal := readLongInt(st);
1377 mIVal2 := readLongInt(st);
1378 mDefined := true;
1379 exit;
1380 end;
1381 TType.TSize:
1382 begin
1383 mIVal := readWord(st);
1384 mIVal2 := readWord(st);
1385 mDefined := true;
1386 exit;
1387 end;
1388 TType.TList:
1389 begin
1390 assert(false);
1391 exit;
1392 end;
1393 TType.TTrigData:
1394 begin
1395 assert(false);
1396 exit;
1397 end;
1398 else raise Exception.Create('ketmar forgot to handle some field type');
1399 end;
1400 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1401 end;
1404 procedure TDynField.parseValue (pr: TTextParser);
1406 procedure parseInt (min, max: Integer);
1407 begin
1408 mIVal := pr.expectInt();
1409 if (mIVal < min) or (mIVal > max) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1410 mDefined := true;
1411 end;
1413 var
1414 rec, rc: TDynRecord;
1415 es: TDynEBS = nil;
1416 tfld: TDynField;
1417 tk: AnsiString;
1418 edim: AnsiChar;
1419 begin
1420 // if this field should contain struct, convert type and parse struct
1421 case mEBS of
1422 TEBS.TNone: begin end;
1423 TEBS.TRec:
1424 begin
1425 // ugly hack. sorry.
1426 if (mType = TType.TTrigData) then
1427 begin
1428 pr.expectTT(pr.TTBegin);
1429 if (pr.tokType = pr.TTEnd) then
1430 begin
1431 // '{}'
1432 mRecRef := nil;
1433 pr.expectTT(pr.TTEnd);
1434 end
1435 else
1436 begin
1437 rec := mOwner;
1438 // find trigger definition
1439 tfld := rec.trigTypeField();
1440 if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mName]));
1441 rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
1442 if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
1443 rc := rc.clone();
1444 rc.mHeaderRec := mOwner.mHeaderRec;
1445 //writeln(rc.definition);
1446 try
1447 rc.parseValue(pr, true);
1448 mRecRef := rc;
1449 rc := nil;
1450 finally
1451 rc.Free();
1452 end;
1453 end;
1454 mDefined := true;
1455 pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1456 exit;
1457 end;
1458 // other record types
1459 if (pr.tokType = pr.TTId) then
1460 begin
1461 if pr.eatId('null') then
1462 begin
1463 mRecRef := nil;
1464 end
1465 else
1466 begin
1467 rec := mOwner.findRecordByTypeId(mEBSTypeName, pr.tokStr);
1468 if (rec = nil) then raise Exception.Create(Format('record ''%s'' (%s) value for field ''%s'' not found', [pr.tokStr, mEBSTypeName, mName]));
1469 pr.expectId();
1470 mRecRef := rec;
1471 end;
1472 mDefined := true;
1473 pr.expectTT(pr.TTSemi);
1474 exit;
1475 end
1476 else if (pr.tokType = pr.TTBegin) then
1477 begin
1478 //rec := mOwner.mOwner.findRecType(mEBSTypeName); // find in mapdef
1479 rec := nil;
1480 if (mEBSType <> nil) and (mEBSType is TDynRecord) then rec := (mEBSType as TDynRecord);
1481 if (rec = nil) then raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1482 rc := rec.clone();
1483 rc.mHeaderRec := mOwner.mHeaderRec;
1484 rc.parseValue(pr);
1485 mRecRef := rc;
1486 mDefined := true;
1487 if mOwner.addRecordByType(mEBSTypeName, rc) then
1488 begin
1489 //raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1490 e_LogWritefln('duplicate record with id ''%s'' for field ''%s'' in record ''%s''', [rc.mId, mName, mOwner.mName]);
1491 end;
1492 pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1493 exit;
1494 end;
1495 pr.expectTT(pr.TTBegin);
1496 end;
1497 TEBS.TEnum:
1498 begin
1499 //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef
1500 es := nil;
1501 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1502 if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1503 tk := pr.expectId();
1504 if not es.has[tk] then raise Exception.Create(Format('record enum value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]));
1505 mIVal := es.field[tk];
1506 mSVal := tk;
1507 //writeln('ENUM ', mEBSName, '; element <', mSVal, '> with value ', mIVal);
1508 mDefined := true;
1509 pr.expectTT(pr.TTSemi);
1510 exit;
1511 end;
1512 TEBS.TBitSet:
1513 begin
1514 //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef
1515 es := nil;
1516 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1517 if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1518 mIVal := 0;
1519 while true do
1520 begin
1521 tk := pr.expectId();
1522 if not es.has[tk] then raise Exception.Create(Format('record bitset value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]));
1523 mIVal := mIVal or es.field[tk];
1524 mSVal := tk;
1525 if (pr.tokType <> pr.TTDelim) or ((pr.tokChar <> '|') and (pr.tokChar <> '+')) then break;
1526 if mBitSetUnique then raise Exception.Create(Format('record bitset of type ''%s'' for field ''%s'' expects only one value', [tk, mEBSTypeName, mName]));
1527 //pr.expectDelim('|');
1528 pr.skipToken(); // plus or pipe
1529 end;
1530 mDefined := true;
1531 pr.expectTT(pr.TTSemi);
1532 exit;
1533 end;
1534 else raise Exception.Create('ketmar forgot to handle some EBS type');
1535 end;
1537 case mType of
1538 TType.TBool:
1539 begin
1540 if pr.eatId('true') or pr.eatId('tan') or pr.eatId('yes') then mIVal := 1
1541 else if pr.eatId('false') or pr.eatId('ona') or pr.eatId('no') then mIVal := 0
1542 else raise Exception.Create(Format('invalid bool value for field ''%s''', [mName]));
1543 mDefined := true;
1544 pr.expectTT(pr.TTSemi);
1545 exit;
1546 end;
1547 TType.TChar:
1548 begin
1549 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1550 mSVal := pr.expectStr(true);
1551 if (mMaxDim < 0) then
1552 begin
1553 // single char
1554 if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName]));
1555 mIVal := Integer(mSVal[1]);
1556 mSVal := '';
1557 end
1558 else
1559 begin
1560 // string
1561 if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName]));
1562 end;
1563 mDefined := true;
1564 pr.expectTT(pr.TTSemi);
1565 exit;
1566 end;
1567 TType.TByte:
1568 begin
1569 parseInt(-128, 127);
1570 pr.expectTT(pr.TTSemi);
1571 exit;
1572 end;
1573 TType.TUByte:
1574 begin
1575 parseInt(0, 255);
1576 pr.expectTT(pr.TTSemi);
1577 exit;
1578 end;
1579 TType.TShort:
1580 begin
1581 parseInt(-32768, 32768);
1582 pr.expectTT(pr.TTSemi);
1583 exit;
1584 end;
1585 TType.TUShort:
1586 begin
1587 parseInt(0, 65535);
1588 pr.expectTT(pr.TTSemi);
1589 exit;
1590 end;
1591 TType.TInt:
1592 begin
1593 parseInt(Integer($80000000), $7fffffff);
1594 pr.expectTT(pr.TTSemi);
1595 exit;
1596 end;
1597 TType.TUInt:
1598 begin
1599 parseInt(0, $7fffffff); //FIXME
1600 pr.expectTT(pr.TTSemi);
1601 exit;
1602 end;
1603 TType.TString:
1604 begin
1605 mSVal := pr.expectStr(true);
1606 mDefined := true;
1607 pr.expectTT(pr.TTSemi);
1608 exit;
1609 end;
1610 TType.TPoint,
1611 TType.TSize:
1612 begin
1613 if pr.eatDelim('[') then edim := ']' else begin pr.expectDelim('('); edim := ')'; end;
1614 mIVal := pr.expectInt();
1615 if (mType = TType.TSize) then
1616 begin
1617 if (mIVal < 0) or (mIVal > 32767) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1618 end;
1619 mIVal2 := pr.expectInt();
1620 if (mType = TType.TSize) then
1621 begin
1622 if (mIVal2 < 0) or (mIVal2 > 32767) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1623 end;
1624 mDefined := true;
1625 pr.expectDelim(edim);
1626 pr.expectTT(pr.TTSemi);
1627 exit;
1628 end;
1629 TType.TList:
1630 begin
1631 assert(false);
1632 exit;
1633 end;
1634 TType.TTrigData:
1635 begin
1636 assert(false);
1637 exit;
1638 end;
1639 else raise Exception.Create('ketmar forgot to handle some field type');
1640 end;
1641 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1642 end;
1645 // ////////////////////////////////////////////////////////////////////////// //
1646 constructor TDynRecord.Create (pr: TTextParser);
1647 begin
1648 if (pr = nil) then raise Exception.Create('cannot create record type without type definition');
1649 mId := '';
1650 mName := '';
1651 mSize := 0;
1652 mFields := TDynFieldList.Create();
1653 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1654 mFieldsHash := hashNewStrInt();
1655 {$ENDIF}
1656 mTrigTypes := nil;
1657 mHeader := false;
1658 mHeaderRec := nil;
1659 mBinBlock := -1;
1660 mTagInt := 0;
1661 mTagPtr := nil;
1662 parseDef(pr);
1663 end;
1666 constructor TDynRecord.Create ();
1667 begin
1668 mName := '';
1669 mSize := 0;
1670 mFields := TDynFieldList.Create();
1671 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1672 mFieldsHash := hashNewStrInt();
1673 {$ENDIF}
1674 mTrigTypes := nil;
1675 mHeader := false;
1676 mHeaderRec := nil;
1677 mTagInt := 0;
1678 mTagPtr := nil;
1679 end;
1682 destructor TDynRecord.Destroy ();
1683 begin
1684 mName := '';
1685 mFields.Free();
1686 mFields := nil;
1687 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1688 mFieldsHash.Free();
1689 mFieldsHash := nil;
1690 {$ENDIF}
1691 mTrigTypes := nil;
1692 mHeaderRec := nil;
1693 mTagInt := 0;
1694 mTagPtr := nil;
1695 inherited;
1696 end;
1699 procedure TDynRecord.addField (fld: TDynField); inline;
1700 begin
1701 if (fld = nil) then raise Exception.Create('cannot append nil field to record');
1702 mFields.append(fld);
1703 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1704 if (Length(fld.mName) > 0) then mFieldsHash.put(fld.mName, mFields.count-1);
1705 {$ENDIF}
1706 end;
1709 function TDynRecord.addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
1710 begin
1711 result := false;
1712 if (fld = nil) then raise Exception.Create('cannot append nil field to record');
1713 {$IF not DEFINED(XDYNREC_USE_FIELDHASH)}
1714 if (Length(fld.mName) > 0) then result := hasByName(fld.mName);
1715 {$ENDIF}
1716 mFields.append(fld);
1717 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1718 if (Length(fld.mName) > 0) then result := mFieldsHash.put(fld.mName, mFields.count-1);
1719 {$ENDIF}
1720 end;
1723 function TDynRecord.findByName (const aname: AnsiString): Integer; inline;
1724 begin
1725 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1726 if not mFieldsHash.get(aname, result) then result := -1;
1727 {$ELSE}
1728 result := 0;
1729 while (result < mFields.count) do
1730 begin
1731 if StrEqu(aname, mFields[result].mName) then exit;
1732 Inc(result);
1733 end;
1734 result := -1;
1735 {$ENDIF}
1736 end;
1739 function TDynRecord.hasByName (const aname: AnsiString): Boolean; inline;
1740 begin
1741 result := (findByName(aname) >= 0);
1742 end;
1745 function TDynRecord.getFieldByName (const aname: AnsiString): TDynField; inline;
1746 var
1747 f: Integer;
1748 begin
1749 f := findByName(aname);
1750 if (f >= 0) then result := mFields[f] else result := nil;
1751 end;
1754 function TDynRecord.getFieldAt (idx: Integer): TDynField; inline;
1755 begin
1756 if (idx >= 0) and (idx < mFields.count) then result := mFields[idx] else result := nil;
1757 end;
1760 function TDynRecord.getCount (): Integer; inline;
1761 begin
1762 result := mFields.count;
1763 end;
1766 function TDynRecord.getIsTrigData (): Boolean; inline;
1767 begin
1768 result := (Length(mTrigTypes) > 0);
1769 end;
1772 function TDynRecord.getIsForTrig (const aname: AnsiString): Boolean; inline;
1773 var
1774 f: Integer;
1775 begin
1776 result := true;
1777 for f := 0 to High(mTrigTypes) do if StrEqu(mTrigTypes[f], aname) then exit;
1778 result := false;
1779 end;
1782 function TDynRecord.getForTrigCount (): Integer; inline;
1783 begin
1784 result := Length(mTrigTypes);
1785 end;
1788 function TDynRecord.getForTrigAt (idx: Integer): AnsiString; inline;
1789 begin
1790 if (idx >= 0) and (idx < Length(mTrigTypes)) then result := mTrigTypes[idx] else result := '';
1791 end;
1794 function TDynRecord.clone (): TDynRecord;
1795 var
1796 fld: TDynField;
1797 f: Integer;
1798 begin
1799 result := TDynRecord.Create();
1800 result.mOwner := mOwner;
1801 result.mId := mId;
1802 result.mPasName := mPasName;
1803 result.mName := mName;
1804 result.mSize := mSize;
1805 if (mFields.count > 0) then
1806 begin
1807 result.mFields.capacity := mFields.count;
1808 for fld in mFields do result.addField(fld.clone(result));
1809 end;
1810 SetLength(result.mTrigTypes, Length(mTrigTypes));
1811 for f := 0 to High(mTrigTypes) do result.mTrigTypes[f] := mTrigTypes[f];
1812 result.mHeader := mHeader;
1813 result.mBinBlock := mBinBlock;
1814 result.mHeaderRec := mHeaderRec;
1815 result.mTagInt := mTagInt;
1816 result.mTagPtr := mTagPtr;
1817 end;
1820 function TDynRecord.findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
1821 var
1822 fld: TDynField;
1823 idx: Integer;
1824 begin
1825 result := nil;
1826 if (Length(aid) = 0) then exit;
1827 // find record data
1828 fld := mHeaderRec.field[atypename];
1829 if (fld = nil) then exit;
1830 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1831 // find by id
1832 if (fld.mRVal <> nil) then
1833 begin
1834 if fld.mRHash.get(aid, idx) then begin result := fld.mRVal[idx]; exit; end;
1835 end;
1836 // alas
1837 end;
1840 function TDynRecord.findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
1841 var
1842 fld: TDynField;
1843 idx: Integer;
1844 begin
1845 result := -1;
1846 // find record data
1847 fld := mHeaderRec.field[atypename];
1848 if (fld = nil) then exit;
1849 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1850 // find by ref
1851 if (fld.mRVal <> nil) then
1852 begin
1853 for idx := 0 to fld.mRVal.count-1 do
1854 begin
1855 if (fld.mRVal[idx] = rc) then begin result := idx; exit; end;
1856 end;
1857 end;
1858 // alas
1859 end;
1862 function TDynRecord.addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean;
1863 var
1864 fld: TDynField;
1865 begin
1866 // find record data
1867 fld := mHeaderRec.field[atypename];
1868 if (fld = nil) then
1869 begin
1870 // first record
1871 fld := TDynField.Create(atypename, TDynField.TType.TList);
1872 fld.mOwner := mHeaderRec;
1873 mHeaderRec.addField(fld);
1874 end;
1875 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot append record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1876 // append
1877 if (fld.mRVal = nil) then
1878 begin
1879 fld.mRVal := TDynRecList.Create();
1880 fld.mRHash := hashNewStrInt();
1881 end;
1882 result := fld.addListItem(rc);
1883 end;
1886 function TDynRecord.isSimpleEqu (rec: TDynRecord): Boolean;
1887 var
1888 f: Integer;
1889 begin
1890 if (rec = nil) then begin result := false; exit; end; // self.mRecRef can't be `nil` here
1891 if (rec = self) then begin result := true; exit; end;
1892 if (mFields.count <> rec.mFields.count) then begin result := false; exit; end;
1893 result := false;
1894 for f := 0 to mFields.count-1 do
1895 begin
1896 if not mFields[f].isSimpleEqu(rec.mFields[f]) then exit;
1897 end;
1898 result := true;
1899 end;
1902 function TDynRecord.trigTypeField (): TDynField;
1903 var
1904 fld: TDynField;
1905 es: TDynEBS = nil;
1906 begin
1907 for fld in mFields do
1908 begin
1909 if (fld.mEBS <> TDynField.TEBS.TEnum) then continue;
1910 if not (fld.mEBSType is TDynEBS) then continue;
1911 es := (fld.mEBSType as TDynEBS);
1912 assert(es <> nil);
1913 if StrEqu(es.mName, 'TriggerType') then begin result := fld; exit; end;
1914 end;
1915 result := nil;
1916 end;
1919 // number of records of the given instance
1920 function TDynRecord.instanceCount (const typename: AnsiString): Integer;
1921 var
1922 fld: TDynField;
1923 begin
1924 result := 0;
1925 fld := field[typename];
1926 if (fld <> nil) and (fld.mType = fld.TType.TList) then result := fld.mRVal.count;
1927 end;
1930 procedure TDynRecord.parseDef (pr: TTextParser);
1931 var
1932 fld: TDynField;
1933 tdn: AnsiString;
1934 begin
1935 if pr.eatId('TriggerData') then
1936 begin
1937 pr.expectId('for');
1938 if pr.eatDelim('(') then
1939 begin
1940 while true do
1941 begin
1942 while pr.eatTT(pr.TTComma) do begin end;
1943 if pr.eatDelim(')') then break;
1944 tdn := pr.expectId();
1945 if isForTrig[tdn] then raise Exception.Create(Format('duplicate trigdata ''%s'' trigtype ''%s''', [mName, tdn]));
1946 SetLength(mTrigTypes, Length(mTrigTypes)+1);
1947 mTrigTypes[High(mTrigTypes)] := tdn;
1948 end;
1949 end
1950 else
1951 begin
1952 tdn := pr.expectId();
1953 SetLength(mTrigTypes, 1);
1954 mTrigTypes[0] := tdn;
1955 end;
1956 mName := 'TriggerData';
1957 end
1958 else
1959 begin
1960 mPasName := pr.expectId(); // pascal record name
1961 pr.expectId('is');
1962 mName := pr.expectStr();
1963 while (pr.tokType <> pr.TTBegin) do
1964 begin
1965 if pr.eatId('header') then begin mHeader := true; continue; end;
1966 if pr.eatId('size') then
1967 begin
1968 if (mSize > 0) then raise Exception.Create(Format('duplicate `size` in record ''%s''', [mName]));
1969 mSize := pr.expectInt();
1970 if (mSize < 1) then raise Exception.Create(Format('invalid record ''%s'' size: %d', [mName, mSize]));
1971 pr.expectId('bytes');
1972 continue;
1973 end;
1974 if pr.eatId('binblock') then
1975 begin
1976 if (mBinBlock >= 0) then raise Exception.Create(Format('duplicate `binblock` in record ''%s''', [mName]));
1977 mBinBlock := pr.expectInt();
1978 if (mBinBlock < 1) then raise Exception.Create(Format('invalid record ''%s'' binblock: %d', [mName, mBinBlock]));
1979 continue;
1980 end;
1981 end;
1982 end;
1984 pr.expectTT(pr.TTBegin);
1985 // load fields
1986 while (pr.tokType <> pr.TTEnd) do
1987 begin
1988 fld := TDynField.Create(pr);
1989 //if hasByName(fld.name) then begin fld.Free(); raise Exception.Create(Format('duplicate field ''%s''', [fld.name])); end;
1990 // append
1991 fld.mOwner := self;
1992 if addFieldChecked(fld) then
1993 begin
1994 fld.Free();
1995 raise Exception.Create(Format('duplicate field ''%s''', [fld.name]));
1996 end;
1997 // done with field
1998 end;
1999 pr.expectTT(pr.TTEnd);
2000 end;
2003 function TDynRecord.pasdef (): AnsiString;
2004 var
2005 fld: TDynField;
2006 begin
2007 if isTrigData then
2008 begin
2009 assert(false);
2010 result := '';
2011 end
2012 else
2013 begin
2014 // record
2015 result := ' '+mPasName+' = packed record'#10;
2016 end;
2017 for fld in mFields do
2018 begin
2019 if fld.mInternal then continue;
2020 if (fld.mBinOfs < 0) then continue;
2021 result += ' '+fld.pasdef+#10;
2022 end;
2023 result += ' end;'#10;
2024 end;
2027 function TDynRecord.definition (): AnsiString;
2028 var
2029 f: Integer;
2030 begin
2031 if isTrigData then
2032 begin
2033 // trigger data
2034 result := 'TriggerData for ';
2035 if (Length(mTrigTypes) > 1) then
2036 begin
2037 result += '(';
2038 for f := 0 to High(mTrigTypes) do
2039 begin
2040 if (f <> 0) then result += ', ';
2041 result += mTrigTypes[f];
2042 end;
2043 result += ')';
2044 end
2045 else
2046 begin
2047 result += mTrigTypes[0];
2048 end;
2049 end
2050 else
2051 begin
2052 // record
2053 result := mPasName+' is '+quoteStr(mName);
2054 if (mSize >= 0) then result += Format(' size %d bytes', [mSize]);
2055 if mHeader then result += ' header';
2056 end;
2057 result += ' {'#10;
2058 for f := 0 to mFields.count-1 do
2059 begin
2060 result += ' ';
2061 result += mFields[f].definition;
2062 result += ';'#10;
2063 end;
2064 result += '}';
2065 end;
2068 procedure TDynRecord.parseBinValue (st: TStream; forceData: Boolean=false);
2069 var
2070 sign: string[4];
2071 btype: Integer;
2072 bsize: Integer;
2073 buf: PByte = nil;
2074 loaded: array[0..255] of Boolean;
2075 rec, rect: TDynRecord;
2076 fld: TDynField;
2077 f: Integer;
2078 mst: TSFSMemoryChunkStream = nil;
2080 procedure linkNames (rec: TDynRecord);
2081 var
2082 fld: TDynField;
2083 rt: TDynRecord;
2084 begin
2085 //writeln('*** rec: ', rec.mName, '.', rec.mId, ' (', rec.mFields.count, ')');
2086 for fld in rec.mFields do
2087 begin
2088 if (fld.mType = TDynField.TType.TTrigData) then
2089 begin
2090 if (fld.mRecRef <> nil) then linkNames(fld.mRecRef);
2091 continue;
2092 end;
2093 if (Length(fld.mRecRefId) = 0) then continue;
2094 assert(fld.mEBSType <> nil);
2095 rt := findRecordByTypeId(fld.mEBSTypeName, fld.mRecRefId);
2096 if (rt = nil) then
2097 begin
2098 e_LogWritefln('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId], MSG_WARNING);
2099 //raise Exception.Create(Format('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]));
2100 end;
2101 //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')');
2102 fld.mRecRefId := '';
2103 fld.mRecRef := rt;
2104 fld.mDefined := true;
2105 end;
2106 for fld in rec.mFields do
2107 begin
2108 //writeln(' ', fld.mName);
2109 fld.fixDefaultValue(); // just in case
2110 end;
2111 end;
2113 begin
2114 for f := 0 to High(loaded) do loaded[f] := false;
2115 mst := TSFSMemoryChunkStream.Create(nil, 0);
2116 try
2117 if mHeader and not forceData then
2118 begin
2119 // parse map file as sequence of blocks
2120 sign[0] := #4;
2121 st.ReadBuffer(sign[1], 4);
2122 if (sign <> 'MAP'#1) then raise Exception.Create('invalid binary map signature');
2123 // parse blocks
2124 while (st.position < st.size) do
2125 begin
2126 btype := readByte(st);
2127 if (btype = 0) then break; // no more blocks
2128 readLongWord(st); // reserved
2129 bsize := readLongInt(st);
2130 {$IF DEFINED(D2D_XDYN_DEBUG)}writeln('btype=', btype, '; bsize=', bsize);{$ENDIF}
2131 if (bsize < 0) or (bsize > $1fffffff) then raise Exception.Create(Format('block of type %d has invalid size %d', [btype, bsize]));
2132 if loaded[btype] then raise Exception.Create(Format('block of type %d already loaded', [btype]));
2133 loaded[btype] := true;
2134 // find record type for this block
2135 rect := nil;
2136 for rec in mOwner.recTypes do if (rec.mBinBlock = btype) then begin rect := rec; break; end;
2137 if (rect = nil) then raise Exception.Create(Format('block of type %d has no corresponding record', [btype]));
2138 //writeln('found type ''', rec.mName, ''' for block type ', btype);
2139 if (rec.mSize = 0) or ((bsize mod rec.mSize) <> 0) then raise Exception.Create(Format('block of type %d has invalid number of records', [btype]));
2140 // header?
2141 if (rect.mHeader) then
2142 begin
2143 if (bsize <> mSize) then raise Exception.Create(Format('header block of type %d has invalid number of records', [btype]));
2144 GetMem(buf, bsize);
2145 st.ReadBuffer(buf^, bsize);
2146 mst.setup(buf, mSize);
2147 parseBinValue(mst, true); // force parsing data
2148 end
2149 else
2150 begin
2151 // create list for this type
2152 fld := TDynField.Create(rec.mName, TDynField.TType.TList);
2153 fld.mOwner := self;
2154 addField(fld);
2155 if (bsize > 0) then
2156 begin
2157 GetMem(buf, bsize);
2158 st.ReadBuffer(buf^, bsize);
2159 for f := 0 to (bsize div rec.mSize)-1 do
2160 begin
2161 mst.setup(buf+f*rec.mSize, rec.mSize);
2162 rec := rect.clone();
2163 rec.mHeaderRec := self;
2164 rec.parseBinValue(mst);
2165 rec.mId := Format('%s%d', [rec.mName, f]);
2166 fld.addListItem(rec);
2167 //writeln('parsed ''', rec.mId, '''...');
2168 end;
2169 end;
2170 end;
2171 FreeMem(buf);
2172 buf := nil;
2173 //st.position := st.position+bsize;
2174 end;
2175 // link fields
2176 for fld in mFields do
2177 begin
2178 if (fld.mType <> TDynField.TType.TList) then continue;
2179 for rec in fld.mRVal do linkNames(rec);
2180 end;
2181 exit;
2182 end;
2184 // read fields
2185 if StrEqu(mName, 'TriggerData') then mSize := Integer(st.size-st.position);
2186 if (mSize < 1) then raise Exception.Create(Format('cannot read record of type ''%s'' with unknown size', [mName]));
2187 GetMem(buf, mSize);
2188 st.ReadBuffer(buf^, mSize);
2189 for fld in mFields do
2190 begin
2191 if fld.mInternal then continue;
2192 if (fld.mBinOfs < 0) then continue;
2193 if (fld.mBinOfs >= st.size) then raise Exception.Create(Format('record of type ''%s'' has invalid field ''%s''', [fld.mName]));
2194 mst.setup(buf+fld.mBinOfs, mSize-fld.mBinOfs);
2195 //writeln('parsing ''', mName, '.', fld.mName, '''...');
2196 fld.parseBinValue(mst);
2197 end;
2198 finally
2199 mst.Free();
2200 if (buf <> nil) then FreeMem(buf);
2201 end;
2202 end;
2205 procedure TDynRecord.writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
2206 var
2207 fld: TDynField;
2208 rec, rv: TDynRecord;
2209 buf: PByte = nil;
2210 ws: TStream = nil;
2211 blk, blkmax: Integer;
2212 //f, c: Integer;
2213 bufsz: Integer = 0;
2214 blksz: Integer;
2215 begin
2216 if (trigbufsz < 0) then
2217 begin
2218 if (mBinBlock < 1) then raise Exception.Create('cannot write binary record without block number');
2219 if (mSize < 1) then raise Exception.Create('cannot write binary record without size');
2220 bufsz := mSize;
2221 end
2222 else
2223 begin
2224 bufsz := trigbufsz;
2225 end;
2226 try
2227 GetMem(buf, bufsz);
2228 FillChar(buf^, bufsz, 0);
2229 ws := TSFSMemoryChunkStream.Create(buf, bufsz);
2231 // write normal fields
2232 for fld in mFields do
2233 begin
2234 // record list?
2235 if (fld.mType = fld.TType.TList) then continue; // later
2236 if fld.mInternal then continue;
2237 if (fld.mBinOfs < 0) then continue;
2238 if (fld.mBinOfs >= bufsz) then raise Exception.Create('binary value offset is outside of the buffer');
2239 TSFSMemoryChunkStream(ws).setup(buf+fld.mBinOfs, bufsz-fld.mBinOfs);
2240 //writeln('writing field <', fld.mName, '>');
2241 fld.writeBinTo(ws);
2242 end;
2244 // write block with normal fields
2245 if mHeader and not onlyFields then
2246 begin
2247 //writeln('writing header...');
2248 // signature and version
2249 writeIntBE(st, LongWord($4D415001));
2250 writeInt(st, Byte(mBinBlock)); // type
2251 writeInt(st, LongWord(0)); // reserved
2252 writeInt(st, LongWord(bufsz)); // size
2253 end;
2254 st.WriteBuffer(buf^, bufsz);
2256 ws.Free(); ws := nil;
2257 FreeMem(buf); buf := nil;
2259 // write other blocks, if any
2260 if mHeader and not onlyFields then
2261 begin
2262 // calculate blkmax
2263 blkmax := 0;
2264 for fld in mFields do
2265 begin
2266 // record list?
2267 if (fld.mType = fld.TType.TList) then
2268 begin
2269 if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2270 rec := mOwner.findRecType(fld.mName);
2271 if (rec = nil) then continue;
2272 if (rec.mBinBlock <= 0) then continue;
2273 if (blkmax < rec.mBinBlock) then blkmax := rec.mBinBlock;
2274 end;
2275 end;
2276 // write blocks
2277 for blk := 1 to blkmax do
2278 begin
2279 if (blk = mBinBlock) then continue;
2280 ws := nil;
2281 for fld in mFields do
2282 begin
2283 // record list?
2284 if (fld.mType = fld.TType.TList) then
2285 begin
2286 if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2287 rec := mOwner.findRecType(fld.mName);
2288 if (rec = nil) then continue;
2289 if (rec.mBinBlock <> blk) then continue;
2290 if (ws = nil) then ws := TMemoryStream.Create();
2291 for rv in fld.mRVal do rv.writeBinTo(ws);
2292 end;
2293 end;
2294 // flush block
2295 if (ws <> nil) then
2296 begin
2297 blksz := Integer(ws.position);
2298 ws.position := 0;
2299 writeInt(st, Byte(blk)); // type
2300 writeInt(st, LongWord(0)); // reserved
2301 writeInt(st, LongWord(blksz)); // size
2302 st.CopyFrom(ws, blksz);
2303 ws.Free();
2304 ws := nil;
2305 end;
2306 end;
2307 // write end marker
2308 writeInt(st, Byte(0));
2309 writeInt(st, LongWord(0));
2310 writeInt(st, LongWord(0));
2311 end;
2312 finally
2313 ws.Free();
2314 if (buf <> nil) then FreeMem(buf);
2315 end;
2316 end;
2319 procedure TDynRecord.writeTo (wr: TTextWriter; putHeader: Boolean=true);
2320 var
2321 fld: TDynField;
2322 rec: TDynRecord;
2323 begin
2324 if putHeader then
2325 begin
2326 wr.put(mName);
2327 if (Length(mId) > 0) then begin wr.put(' '); wr.put(mId); end;
2328 wr.put(' ');
2329 end;
2330 wr.put('{'#10);
2331 wr.indent();
2332 try
2333 for fld in mFields do
2334 begin
2335 // record list?
2336 if (fld.mType = fld.TType.TList) then
2337 begin
2338 if not mHeader then raise Exception.Create('record list in non-header record');
2339 if (fld.mRVal <> nil) then
2340 begin
2341 for rec in fld.mRVal do
2342 begin
2343 if (Length(rec.mId) = 0) then continue;
2344 wr.putIndent();
2345 rec.writeTo(wr, true);
2346 end;
2347 end;
2348 continue;
2349 end;
2350 if fld.mInternal then continue;
2351 if fld.mOmitDef and fld.isDefaultValue then continue;
2352 wr.putIndent();
2353 fld.writeTo(wr);
2354 end;
2355 finally
2356 wr.unindent();
2357 end;
2358 wr.putIndent();
2359 wr.put('}'#10);
2360 end;
2363 {$IF DEFINED(D2D_DYNREC_PROFILER)}
2364 var
2365 profCloneRec: UInt64 = 0;
2366 profFindRecType: UInt64 = 0;
2367 profFieldSearching: UInt64 = 0;
2368 profListDupChecking: UInt64 = 0;
2369 profAddRecByType: UInt64 = 0;
2370 profFieldValParsing: UInt64 = 0;
2371 profFixDefaults: UInt64 = 0;
2372 profRecValParse: UInt64 = 0;
2374 procedure xdynDumpProfiles ();
2375 begin
2376 writeln('=== XDYNREC PROFILES ===');
2377 writeln('record cloning: ', profCloneRec div 1000, '.', profCloneRec mod 1000, ' milliseconds');
2378 writeln('findRecType : ', profFindRecType div 1000, '.', profFindRecType mod 1000, ' milliseconds');
2379 writeln('field[] : ', profFieldSearching div 1000, '.', profFieldSearching mod 1000, ' milliseconds');
2380 writeln('list dup check: ', profListDupChecking div 1000, '.', profListDupChecking mod 1000, ' milliseconds');
2381 writeln('addRecByType : ', profAddRecByType div 1000, '.', profAddRecByType mod 1000, ' milliseconds');
2382 writeln('field valparse: ', profFieldValParsing div 1000, '.', profFieldValParsing mod 1000, ' milliseconds');
2383 writeln('fix defaults : ', profFixDefaults div 1000, '.', profFixDefaults mod 1000, ' milliseconds');
2384 writeln('recvalparse : ', profRecValParse div 1000, '.', profRecValParse mod 1000, ' milliseconds');
2385 end;
2386 {$ENDIF}
2389 procedure TDynRecord.parseValue (pr: TTextParser; beginEaten: Boolean=false);
2390 var
2391 fld: TDynField;
2392 rec: TDynRecord = nil;
2393 trc{, rv}: TDynRecord;
2394 {$IF DEFINED(D2D_DYNREC_PROFILER)}
2395 stt, stall: UInt64;
2396 {$ENDIF}
2397 begin
2398 if (mOwner = nil) then raise Exception.Create(Format('can''t parse record ''%s'' value without owner', [mName]));
2400 {$IF DEFINED(D2D_DYNREC_PROFILER)}stall := curTimeMicro();{$ENDIF}
2402 // not a header?
2403 if not mHeader then
2404 begin
2405 // id?
2406 if (not beginEaten) and (pr.tokType = pr.TTId) then mId := pr.expectId();
2407 end
2408 else
2409 begin
2410 assert(mHeaderRec = self);
2411 end;
2413 //writeln('parsing record <', mName, '>');
2414 if not beginEaten then pr.expectTT(pr.TTBegin);
2415 while (pr.tokType <> pr.TTEnd) do
2416 begin
2417 if (pr.tokType <> pr.TTId) then raise Exception.Create('identifier expected');
2418 //writeln('<', mName, '.', pr.tokStr, '>');
2420 // records
2421 if mHeader then
2422 begin
2423 // add records with this type (if any)
2424 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2425 trc := mOwner.findRecType(pr.tokStr);
2426 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := curTimeMicro()-stt;{$ENDIF}
2427 if (trc <> nil) then
2428 begin
2429 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2430 rec := trc.clone();
2431 {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF}
2432 rec.mHeaderRec := mHeaderRec;
2433 try
2434 pr.skipToken();
2435 rec.parseValue(pr);
2436 (*
2437 if (Length(rec.mId) > 0) then
2438 begin
2439 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2440 fld := field[pr.tokStr];
2441 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF}
2442 (*
2443 if (fld <> nil) and (fld.mRVal <> nil) then
2444 begin
2445 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2446 //idtmp := trc.mName+':'+rec.mId;
2447 //if ids.put(idtmp, 1) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName]));
2448 if fld.mRHash.has(rec.mId) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName]));
2449 {$IF DEFINED(D2D_DYNREC_PROFILER)}profListDupChecking := curTimeMicro()-stt;{$ENDIF}
2450 end;
2451 end;
2452 *)
2453 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2454 addRecordByType(rec.mName, rec);
2455 {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := curTimeMicro()-stt;{$ENDIF}
2456 rec := nil;
2457 finally
2458 rec.Free();
2459 end;
2460 continue;
2461 end;
2462 end;
2464 // fields
2465 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2466 fld := field[pr.tokStr];
2467 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF}
2468 if (fld <> nil) then
2469 begin
2470 if fld.defined then raise Exception.Create(Format('duplicate field ''%s'' in record ''%s''', [fld.mName, mName]));
2471 if fld.internal then raise Exception.Create(Format('internal field ''%s'' in record ''%s''', [fld.mName, mName]));
2472 pr.skipToken();
2473 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2474 fld.parseValue(pr);
2475 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldValParsing := curTimeMicro()-stt;{$ENDIF}
2476 continue;
2477 end;
2479 // something is wrong
2480 raise Exception.Create(Format('unknown field ''%s'' in record ''%s''', [pr.tokStr, mName]));
2481 end;
2482 pr.expectTT(pr.TTEnd);
2483 // fix field defaults
2484 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2485 for fld in mFields do fld.fixDefaultValue();
2486 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFixDefaults := curTimeMicro()-stt;{$ENDIF}
2487 //writeln('done parsing record <', mName, '>');
2488 //{$IF DEFINED(D2D_DYNREC_PROFILER)}writeln('stall: ', curTimeMicro()-stall);{$ENDIF}
2489 {$IF DEFINED(D2D_DYNREC_PROFILER)}profRecValParse := curTimeMicro()-stall;{$ENDIF}
2490 end;
2493 // ////////////////////////////////////////////////////////////////////////// //
2494 constructor TDynEBS.Create (pr: TTextParser);
2495 begin
2496 cleanup();
2497 parseDef(pr);
2498 end;
2501 destructor TDynEBS.Destroy ();
2502 begin
2503 cleanup();
2504 inherited;
2505 end;
2508 procedure TDynEBS.cleanup ();
2509 begin
2510 mIsEnum := false;
2511 mName := '';
2512 mIds := nil;
2513 mVals := nil;
2514 mMaxName := '';
2515 mMaxVal := 0;
2516 end;
2519 function TDynEBS.findByName (const aname: AnsiString): Integer;
2520 begin
2521 result := 0;
2522 while (result < Length(mIds)) do
2523 begin
2524 if StrEqu(aname, mIds[result]) then exit;
2525 Inc(result);
2526 end;
2527 result := -1;
2528 end;
2531 function TDynEBS.hasByName (const aname: AnsiString): Boolean; inline;
2532 begin
2533 result := (findByName(aname) >= 0);
2534 end;
2537 function TDynEBS.getFieldByName (const aname: AnsiString): Integer; inline;
2538 var
2539 f: Integer;
2540 begin
2541 f := findByName(aname);
2542 if (f >= 0) then result := mVals[f] else result := 0;
2543 end;
2546 function TDynEBS.definition (): AnsiString;
2547 var
2548 f, cv: Integer;
2549 begin
2550 if mIsEnum then result :='enum ' else result := 'bitset ';
2551 result += mName;
2552 result += ' {'#10;
2553 // fields
2554 if mIsEnum then cv := 0 else cv := 1;
2555 for f := 0 to High(mIds) do
2556 begin
2557 if (mIds[f] = mMaxName) then continue;
2558 result += ' '+mIds[f];
2559 if (mVals[f] <> cv) then
2560 begin
2561 result += Format(' = %d', [mVals[f]]);
2562 if mIsEnum then cv := mVals[f];
2563 result += ','#10;
2564 end
2565 else
2566 begin
2567 result += Format(', // %d'#10, [mVals[f]]);
2568 end;
2569 if mIsEnum then Inc(cv) else if (mVals[f] = cv) then cv := cv shl 1;
2570 end;
2571 // max field
2572 if (Length(mMaxName) > 0) then result += ' '+mMaxName+' = MAX,'#10;
2573 result += '}';
2574 end;
2577 function TDynEBS.pasdef (): AnsiString;
2578 var
2579 f: Integer;
2580 begin
2581 result := '// '+mName+#10'const'#10;
2582 // fields
2583 for f := 0 to High(mIds) do
2584 begin
2585 result += formatstrf(' %s = %d;'#10, [mIds[f], mVals[f]]);
2586 end;
2587 end;
2590 function TDynEBS.nameByValue (v: Integer): AnsiString;
2591 var
2592 f: Integer;
2593 begin
2594 for f := 0 to High(mVals) do
2595 begin
2596 if (mVals[f] = v) then begin result := mIds[f]; exit; end;
2597 end;
2598 result := '';
2599 end;
2602 procedure TDynEBS.parseDef (pr: TTextParser);
2603 var
2604 idname: AnsiString;
2605 cv, v: Integer;
2606 f: Integer;
2607 skipAdd: Boolean;
2608 hasV: Boolean;
2609 begin
2610 if pr.eatId('enum') then mIsEnum := true
2611 else if pr.eatId('bitset') then mIsEnum := false
2612 else pr.expectId('enum');
2613 mName := pr.expectId();
2614 mMaxVal := Integer($80000000);
2615 if mIsEnum then cv := 0 else cv := 1;
2616 pr.expectTT(pr.TTBegin);
2617 while (pr.tokType <> pr.TTEnd) do
2618 begin
2619 idname := pr.expectId();
2620 for f := 0 to High(mIds) do
2621 begin
2622 if StrEqu(mIds[f], idname) then raise Exception.Create(Format('duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2623 end;
2624 if StrEqu(mMaxName, idname) then raise Exception.Create(Format('duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2625 skipAdd := false;
2626 hasV := false;
2627 v := cv;
2628 // has value?
2629 if pr.eatDelim('=') then
2630 begin
2631 if pr.eatId('MAX') then
2632 begin
2633 if (Length(mMaxName) > 0) then raise Exception.Create(Format('duplicate max field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2634 mMaxName := idname;
2635 skipAdd := true;
2636 end
2637 else
2638 begin
2639 v := pr.expectInt();
2640 if mIsEnum then cv := v;
2641 hasV := true;
2642 end;
2643 end;
2644 // append it?
2645 if not skipAdd then
2646 begin
2647 // fix maxvalue
2648 if mIsEnum or (not hasV) then
2649 begin
2650 if (mMaxVal < v) then mMaxVal := v;
2651 end;
2652 SetLength(mIds, Length(mIds)+1);
2653 mIds[High(mIds)] := idname;
2654 SetLength(mVals, Length(mIds));
2655 mVals[High(mVals)] := v;
2656 // next cv
2657 if mIsEnum or (not hasV) then
2658 begin
2659 if mIsEnum then Inc(cv) else cv := cv shl 1;
2660 end;
2661 end;
2662 if (pr.tokType = pr.TTEnd) then break;
2663 pr.expectTT(pr.TTComma);
2664 while pr.eatTT(pr.TTComma) do begin end;
2665 end;
2666 pr.expectTT(pr.TTEnd);
2667 // add max field
2668 if (Length(mMaxName) > 0) then
2669 begin
2670 SetLength(mIds, Length(mIds)+1);
2671 mIds[High(mIds)] := mMaxName;
2672 SetLength(mVals, Length(mIds));
2673 mVals[High(mVals)] := mMaxVal;
2674 end;
2675 end;
2678 // ////////////////////////////////////////////////////////////////////////// //
2679 constructor TDynMapDef.Create (pr: TTextParser);
2680 begin
2681 recTypes := TDynRecList.Create();
2682 trigTypes := TDynRecList.Create();
2683 ebsTypes := TDynEBSList.Create();
2684 parseDef(pr);
2685 end;
2688 destructor TDynMapDef.Destroy ();
2689 var
2690 rec: TDynRecord;
2691 ebs: TDynEBS;
2692 begin
2693 for rec in recTypes do rec.Free();
2694 for rec in trigTypes do rec.Free();
2695 for ebs in ebsTypes do ebs.Free();
2696 recTypes.Free();
2697 trigTypes.Free();
2698 ebsTypes.Free();
2699 recTypes := nil;
2700 trigTypes := nil;
2701 ebsTypes := nil;
2702 inherited;
2703 end;
2706 function TDynMapDef.getHeaderRecType (): TDynRecord; inline;
2707 begin
2708 if (recTypes.count = 0) then raise Exception.Create('no header in empty mapdef');
2709 result := recTypes[0];
2710 end;
2713 function TDynMapDef.findRecType (const aname: AnsiString): TDynRecord;
2714 var
2715 rec: TDynRecord;
2716 begin
2717 for rec in recTypes do
2718 begin
2719 if StrEqu(rec.name, aname) then begin result := rec; exit; end;
2720 end;
2721 result := nil;
2722 end;
2725 function TDynMapDef.findTrigFor (const aname: AnsiString): TDynRecord;
2726 var
2727 rec: TDynRecord;
2728 begin
2729 for rec in trigTypes do
2730 begin
2731 if (rec.isForTrig[aname]) then begin result := rec; exit; end;
2732 end;
2733 result := nil;
2734 end;
2737 function TDynMapDef.findEBSType (const aname: AnsiString): TDynEBS;
2738 var
2739 ebs: TDynEBS;
2740 begin
2741 for ebs in ebsTypes do
2742 begin
2743 if StrEqu(ebs.name, aname) then begin result := ebs; exit; end;
2744 end;
2745 result := nil;
2746 end;
2749 procedure TDynMapDef.parseDef (pr: TTextParser);
2750 var
2751 rec, hdr: TDynRecord;
2752 eb: TDynEBS;
2753 f: Integer;
2755 // setup header links and type links
2756 procedure linkRecord (rec: TDynRecord);
2757 var
2758 fld: TDynField;
2759 begin
2760 rec.mHeaderRec := recTypes[0];
2761 for fld in rec.mFields do
2762 begin
2763 if (fld.mType = fld.TType.TTrigData) then continue;
2764 case fld.mEBS of
2765 TDynField.TEBS.TNone: begin end;
2766 TDynField.TEBS.TRec:
2767 begin
2768 fld.mEBSType := findRecType(fld.mEBSTypeName);
2769 if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding record definition', [fld.mName, fld.mEBSTypeName]));
2770 end;
2771 TDynField.TEBS.TEnum,
2772 TDynField.TEBS.TBitSet:
2773 begin
2774 fld.mEBSType := findEBSType(fld.mEBSTypeName);
2775 if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding enum/bitset', [fld.mName, fld.mEBSTypeName]));
2776 if ((fld.mEBS = TDynField.TEBS.TEnum) <> (fld.mEBSType as TDynEBS).mIsEnum) then raise Exception.Create(Format('field ''%s'' of type ''%s'' enum/bitset type conflict', [fld.mName, fld.mEBSTypeName]));
2777 end;
2778 end;
2779 end;
2780 end;
2782 // setup default values
2783 procedure fixRecordDefaults (rec: TDynRecord);
2784 var
2785 fld: TDynField;
2786 begin
2787 for fld in rec.mFields do if fld.mHasDefault then fld.parseDefaultValue();
2788 end;
2790 begin
2791 hdr := nil;
2792 while true do
2793 begin
2794 if not pr.skipBlanks() then break;
2795 if (pr.tokType <> pr.TTId) then raise Exception.Create('identifier expected');
2797 if (pr.tokStr = 'enum') or (pr.tokStr = 'bitset') then
2798 begin
2799 eb := TDynEBS.Create(pr);
2800 if (findEBSType(eb.name) <> nil) then
2801 begin
2802 eb.Free();
2803 raise Exception.Create(Format('duplicate enum/bitset ''%s''', [eb.name]));
2804 end;
2805 eb.mOwner := self;
2806 ebsTypes.append(eb);
2807 //writeln(eb.definition); writeln;
2808 continue;
2809 end;
2811 if (pr.tokStr = 'TriggerData') then
2812 begin
2813 rec := TDynRecord.Create(pr);
2814 for f := 0 to High(rec.mTrigTypes) do
2815 begin
2816 if (findTrigFor(rec.mTrigTypes[f]) <> nil) then
2817 begin
2818 rec.Free();
2819 raise Exception.Create(Format('duplicate trigdata ''%s''', [rec.mTrigTypes[f]]));
2820 end;
2821 end;
2822 rec.mOwner := self;
2823 trigTypes.append(rec);
2824 //writeln(dr.definition); writeln;
2825 continue;
2826 end;
2828 rec := TDynRecord.Create(pr);
2829 //writeln(dr.definition); writeln;
2830 if (findRecType(rec.name) <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end;
2831 if (hdr <> nil) and StrEqu(rec.name, hdr.name) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end;
2832 rec.mOwner := self;
2833 if rec.mHeader then
2834 begin
2835 if (hdr <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate header record ''%s'' (previous is ''%s'')', [rec.name, hdr.name])); end;
2836 hdr := rec;
2837 end
2838 else
2839 begin
2840 recTypes.append(rec);
2841 end;
2842 end;
2844 // put header record to top
2845 if (hdr = nil) then raise Exception.Create('header definition not found in mapdef');
2846 recTypes.append(nil);
2847 for f := recTypes.count-1 downto 1 do recTypes[f] := recTypes[f-1];
2848 recTypes[0] := hdr;
2850 // setup header links and type links
2851 for rec in recTypes do linkRecord(rec);
2852 for rec in trigTypes do linkRecord(rec);
2854 // setup default values
2855 for rec in recTypes do fixRecordDefaults(rec);
2856 for rec in trigTypes do fixRecordDefaults(rec);
2857 end;
2860 // ////////////////////////////////////////////////////////////////////////// //
2861 function TDynMapDef.parseMap (pr: TTextParser): TDynRecord;
2862 var
2863 res: TDynRecord = nil;
2864 begin
2865 result := nil;
2866 try
2867 pr.expectId(headerType.name);
2868 res := headerType.clone();
2869 res.mHeaderRec := res;
2870 res.parseValue(pr);
2871 result := res;
2872 res := nil;
2873 finally
2874 res.Free();
2875 end;
2876 end;
2879 function TDynMapDef.parseBinMap (st: TStream): TDynRecord;
2880 var
2881 res: TDynRecord = nil;
2882 begin
2883 result := nil;
2884 try
2885 res := headerType.clone();
2886 res.mHeaderRec := res;
2887 res.parseBinValue(st);
2888 result := res;
2889 res := nil;
2890 finally
2891 res.Free();
2892 end;
2893 end;
2896 function TDynMapDef.pasdef (): AnsiString;
2897 var
2898 ebs: TDynEBS;
2899 rec: TDynRecord;
2900 fld: TDynField;
2901 needComma: Boolean;
2902 tn: AnsiString;
2903 begin
2904 result := '';
2905 result += '// ////////////////////////////////////////////////////////////////////////// //'#10;
2906 result += '// enums and bitsets'#10;
2907 for ebs in ebsTypes do result += #10+ebs.pasdef();
2908 result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10;
2909 result += '// records'#10'type'#10;
2910 for rec in recTypes do
2911 begin
2912 if (rec.mSize < 1) then continue;
2913 result += rec.pasdef();
2914 result += #10;
2915 end;
2916 result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10;
2917 result += '// triggerdata'#10'type'#10;
2918 result += ' TTriggerData = record'#10;
2919 result += ' case Byte of'#10;
2920 result += ' 0: (Default: Byte128);'#10;
2921 for rec in trigTypes do
2922 begin
2923 result += ' ';
2924 needComma := false;
2925 for tn in rec.mTrigTypes do
2926 begin
2927 if needComma then result += ', ' else needComma := true;
2928 result += tn;
2929 end;
2930 result += ': ('#10;
2931 for fld in rec.mFields do
2932 begin
2933 if fld.mInternal then continue;
2934 if (fld.mBinOfs < 0) then continue;
2935 result += ' '+fld.pasdef+#10;
2936 end;
2937 result += ' );'#10;
2938 end;
2939 result += ' end;'#10;
2940 end;
2943 function TDynMapDef.pasdefconst (): AnsiString;
2944 var
2945 ebs: TDynEBS;
2946 begin
2947 result := '';
2948 result += '// ////////////////////////////////////////////////////////////////////////// //'#10;
2949 result += '// enums and bitsets'#10;
2950 for ebs in ebsTypes do result += #10+ebs.pasdef();
2951 end;
2954 function TDynMapDef.getTrigTypeCount (): Integer; inline; begin result := trigTypes.count; end;
2955 function TDynMapDef.getTrigTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < trigTypes.count) then result := trigTypes[idx] else result := nil; end;
2958 end.