1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 TLFMTree - a tree structure for LFM files.
25 }
26 unit LFMTrees;
27
28 {$mode objfpc}{$H+}
29
30 interface
31
32 uses
33 Classes, SysUtils, TypInfo, Laz_AVL_Tree,
34 // LazUtils
35 LazUtilities,
36 // Codetools
37 FileProcs, BasicCodeTools, CodeCache;
38
39 type
40 { TLFMTreeNode }
41
42 TLFMNodeType = (
43 lfmnObject,
44 lfmnProperty,
45 lfmnValue,
46 lfmnEnum
47 );
48
49 TLFMTree = class;
50
51 TLFMTreeNode = class
52 public
53 TheType: TLFMNodeType;
54 StartPos: integer;
55 EndPos: integer;
56 Parent: TLFMTreeNode;
57 FirstChild: TLFMTreeNode;
58 LastChild: TLFMTreeNode;
59 PrevSibling: TLFMTreeNode;
60 NextSibling: TLFMTreeNode;
61 Tree: TLFMTree;
62 constructor CreateVirtual; virtual;
63 destructor Destroy; override;
64 procedure Unbind;
65 procedure AddChild(ANode: TLFMTreeNode);
GetIdentifiernull66 function GetIdentifier: string;
67 procedure FindIdentifier(out IdentStart, IdentEnd: integer);
GetPathnull68 function GetPath: string;
Nextnull69 function Next(SkipChildren: Boolean = False): TLFMTreeNode;
70 end;
71
72 TLFMTreeNodeClass = class of TLFMTreeNode;
73
74
75 { TLFMObjectNode - a LFM object }
76
77 TLFMObjectNode = class(TLFMTreeNode)
78 public
79 IsInherited: boolean;
80 IsInline: boolean;
81 ChildPos: Integer;
82 Name: string;
83 NamePosition: integer;
84 TypeName: string;
85 TypeNamePosition: integer;
86 AncestorTool: TObject; // TFindDeclarationTool
87 AncestorNode: TObject; // TCodeTreeNode
88 AncestorContextValid: boolean;
89 constructor CreateVirtual; override;
90 end;
91
92 { TLFMNameParts }
93
94 TLFMNameParts = class
95 private
96 FCount: integer;
97 FNames: ^String;
98 FNamePositions: ^integer;
GetNamePositionsnull99 function GetNamePositions(Index: integer): integer;
GetNamesnull100 function GetNames(Index: integer): string;
101 public
102 destructor Destroy; override;
103 procedure Clear;
104 procedure Add(const Name: string; NamePosition: integer);
105 property Count: integer read FCount;
106 property Names[Index: integer]: string read GetNames;
107 property NamePositions[Index: integer]: integer read GetNamePositions;
108 end;
109
110 { TLFMPropertyNode - a LFM property }
111
112 TLFMPropertyNode = class(TLFMTreeNode)
113 public
114 CompleteName: string;
115 NameParts: TLFMNameParts;
116 constructor CreateVirtual; override;
117 destructor Destroy; override;
118 procedure Clear;
119 procedure Add(const Name: string; NamePosition: integer);
120 end;
121
122
123 { TLFMValueNode - a LFM value }
124
125 TLFMValueType = (
126 lfmvNone,
127 lfmvInteger,
128 lfmvFloat,
129 lfmvString,
130 lfmvSymbol,
131 lfmvSet,
132 lfmvList,
133 lfmvCollection,
134 lfmvBinary
135 );
136
137 TLFMValueNode = class(TLFMTreeNode)
138 public
139 ValueType: TLFMValueType;
140 constructor CreateVirtual; override;
ReadStringnull141 function ReadString: string;
142 end;
143
144
145 { TLFMValueNodeSymbol - a LFM value of type symbol }
146
147 TLFMSymbolType = (
148 lfmsNone,
149 lfmsTrue,
150 lfmsFalse,
151 lfmsNil,
152 lfmsIdentifier
153 );
154
155 TLFMValueNodeSymbol = class(TLFMValueNode)
156 public
157 SymbolType: TLFMSymbolType;
158 constructor CreateVirtual; override;
159 end;
160
161
162 { TLFMValueNodeSet - a LFM value of type set }
163
164 TLFMValueNodeSet = class(TLFMValueNode)
165 public
166 constructor CreateVirtual; override;
167 end;
168
169
170 { TLFMValueNodeList - a list of LFM values }
171
172 TLFMValueNodeList = class(TLFMValueNode)
173 public
174 constructor CreateVirtual; override;
175 end;
176
177
178 { TLFMValueNodeCollection - a LFM collection }
179
180 TLFMValueNodeCollection = class(TLFMValueNode)
181 public
182 constructor CreateVirtual; override;
183 end;
184
185
186 { TLFMValueNodeBinary - LFM binary data }
187
188 TLFMValueNodeBinary = class(TLFMValueNode)
189 public
190 constructor CreateVirtual; override;
191 end;
192
193
194 { TLFMEnumNode - an enum of a value of type set}
195
196 TLFMEnumNode = class(TLFMTreeNode)
197 public
198 constructor CreateVirtual; override;
199 end;
200
201
202 { TLFMError }
203
204 TLFMErrorType = (
205 lfmeNoError,
206 lfmeParseError,
207 lfmeMissingRoot,
208 lfmeIdentifierNotFound,
209 lfmeIdentifierNotPublished,
210 lfmeIdentifierMissingInCode,
211 lfmeObjectNameMissing,
212 lfmeObjectIncompatible,
213 lfmePropertyNameMissing,
214 lfmePropertyHasNoSubProperties,
215 lfmeEndNotFound
216 );
217 TLFMErrorTypes = set of TLFMErrorType;
218
219 TLFMError = class
220 public
221 Tree: TLFMTree;
222 Node: TLFMTreeNode;
223 NextError: TLFMError;
224 PrevError: TLFMError;
225 ErrorType: TLFMErrorType;
226 ErrorMessage: string;
227 Source: TCodeBuffer;
228 Position: integer;
229 Caret: TPoint;
230 constructor Create;
231 procedure Clear;
232 destructor Destroy; override;
AsStringnull233 function AsString: string;
234 procedure AddToTree(ATree: TLFMTree);
235 procedure Unbind;
FindParentErrornull236 function FindParentError: TLFMError;
FindContextNodenull237 function FindContextNode: TLFMTreeNode;
IsMissingObjectTypenull238 function IsMissingObjectType: boolean;
GetNodePathnull239 function GetNodePath: string;
240 end;
241
242 TLFMTrees = class;
243
244 { TLFMTree }
245
246 TLFMTree = class
247 protected
248 Parser: TParser;
249 TokenStart: LongInt;
NextTokennull250 function NextToken: Char;
251 procedure ProcessValue;
252 procedure ProcessProperty;
253 procedure ProcessObject;
254 procedure CreateChildNode(NodeClass: TLFMTreeNodeClass);
255 procedure CloseChildNode;
256 public
257 Root: TLFMTreeNode;
258 CurNode: TLFMTreeNode;
259 LFMBuffer: TCodeBuffer;
260 LFMBufferChangeStep: integer;
261 FirstError: TLFMError;
262 LastError: TLFMError;
263 Trees: TLFMTrees;
264 constructor Create(TheTrees: TLFMTrees; aLFMBuf: TCodeBuffer);
265 constructor Create;
266 destructor Destroy; override;
267 procedure Clear;
268 procedure ClearErrors;
Parsenull269 function Parse(LFMBuf: TCodeBuffer = nil): boolean;
ParseIfNeedednull270 function ParseIfNeeded: boolean;
UpdateNeedednull271 function UpdateNeeded: boolean;
PositionToCaretnull272 function PositionToCaret(p: integer): TPoint;
273 procedure AddError(ErrorType: TLFMErrorType; LFMNode: TLFMTreeNode;
274 const ErrorMessage: string; ErrorPosition: integer);
FindErrorAtLinenull275 function FindErrorAtLine(Line: integer): TLFMError;
FindErrorAtNodenull276 function FindErrorAtNode(Node: TLFMTreeNode): TLFMError;
FindErrornull277 function FindError(ErrorTypes: TLFMErrorTypes): TLFMError;
FirstErrorAsStringnull278 function FirstErrorAsString: string;
279
FindPropertynull280 function FindProperty(PropertyPath: string;
281 ContextNode: TLFMTreeNode): TLFMPropertyNode;
282
283 procedure WriteDebugReport;
284 end;
285
286 { TLFMTrees }
287
288 TLFMTrees = class
289 private
290 FItems: TAVLTree;// tree of TLFMTree sorted for LFMBuffer
291 FClearing: Boolean;
292 public
293 constructor Create;
294 destructor Destroy; override;
295 procedure Clear;
GetLFMTreenull296 function GetLFMTree(LFMBuffer: TCodeBuffer;
297 CreateIfNotExists: boolean): TLFMTree;
298 end;
299
300 TInstancePropInfo = record
301 Instance: TPersistent;
302 PropInfo: PPropInfo;
303 end;
304 PInstancePropInfo = ^TInstancePropInfo;
305
306 const
307 LFMErrorTypeNames: array[TLFMErrorType] of string = (
308 'NoError',
309 'ParseError',
310 'MissingRoot',
311 'IdentifierNotFound',
312 'IdentifierNotPublished',
313 'IdentifierMissingInCode',
314 'ObjectNameMissing',
315 'ObjectIncompatible',
316 'PropertyNameMissing',
317 'PropertyHasNoSubProperties',
318 'EndNotFound'
319 );
320
321 TLFMValueTypeNames: array[TLFMValueType] of string = (
322 'None',
323 'Integer',
324 'Float',
325 'String',
326 'Symbol',
327 'Set',
328 'List',
329 'Collection',
330 'Binary'
331 );
332
333 procedure FreeListOfPInstancePropInfo(List: TFPList);
CompareLFMTreesByLFMBuffernull334 function CompareLFMTreesByLFMBuffer(Data1, Data2: Pointer): integer;
CompareLFMBufWithTreenull335 function CompareLFMBufWithTree(Buf, Tree: Pointer): integer;
336
337 var
338 DefaultLFMTrees: TLFMTrees = nil;
339
340 implementation
341
342
343 procedure FreeListOfPInstancePropInfo(List: TFPList);
344 var
345 i: Integer;
346 p: PInstancePropInfo;
347 begin
348 if List=nil then exit;
349 for i:=0 to List.Count-1 do begin
350 p:=PInstancePropInfo(List[i]);
351 Dispose(p);
352 end;
353 List.Free;
354 end;
355
CompareLFMTreesByLFMBuffernull356 function CompareLFMTreesByLFMBuffer(Data1, Data2: Pointer): integer;
357 begin
358 Result:=ComparePointers(TLFMTree(Data1).LFMBuffer,TLFMTree(Data2).LFMBuffer);
359 end;
360
CompareLFMBufWithTreenull361 function CompareLFMBufWithTree(Buf, Tree: Pointer): integer;
362 begin
363 Result:=ComparePointers(Buf,TLFMTree(Tree).LFMBuffer);
364 end;
365
366
367 { TLFMTree }
368
369 constructor TLFMTree.Create;
370 begin
371 end;
372
373 destructor TLFMTree.Destroy;
374 begin
375 Clear;
376 if (Trees<>nil) and (not Trees.FClearing) then Trees.FItems.Remove(Self);
377 inherited Destroy;
378 end;
379
380 procedure TLFMTree.Clear;
381 begin
382 // do not set LFMBuffer to nil
383 TokenStart:=0;
384 CurNode:=nil;
385 ClearErrors;
386 while Root<>nil do Root.Free;
387 end;
388
389 procedure TLFMTree.ClearErrors;
390 begin
391 while FirstError<>nil do FirstError.Free;
392 end;
393
Parsenull394 function TLFMTree.Parse(LFMBuf: TCodeBuffer = nil): boolean;
395 var
396 LFMStream: TMemoryStream;
397 Src: String;
398 begin
399 Result:=false;
400 Clear;
401 if LFMBuf<>LFMBuffer then begin
402 DebugLn(['TLFMTree.Parse New=',LFMBuf.Filename]);
403 DebugLn(['TLFMTree.Parse Old=',LFMBuffer.Filename]);
404 if Trees<>nil then
405 raise Exception.Create('TLFMTree.Parse: changing LFMBuffer in Tree is not allowed');
406 LFMBuffer:=LFMBuf;
407 end;
408 LFMBufferChangeStep:=LFMBuffer.ChangeStep;
409
410 LFMStream:=TMemoryStream.Create;
411 Src:=LFMBuffer.Source;
412 if Src<>'' then begin
413 LFMStream.Write(Src[1],length(Src));
414 LFMStream.Position:=0;
415 end;
416 Parser := TParser.Create(LFMStream);
417 try
418 try
419 repeat
420 ProcessObject;
421 until (not Parser.TokenSymbolIs('OBJECT'))
422 and (not Parser.TokenSymbolIs('INHERITED'))
423 and (not Parser.TokenSymbolIs('INLINE'));
424 Result:=true;
425 except
426 on E: EParserError do begin
427 AddError(lfmeParseError,CurNode,E.Message,Parser.SourcePos);
428 end;
429 end;
430 finally
431 Parser.Free;
432 Parser:=nil;
433 LFMStream.Free;
434 end;
435 end;
436
TLFMTree.ParseIfNeedednull437 function TLFMTree.ParseIfNeeded: boolean;
438 begin
439 if not UpdateNeeded then exit(true);
440 Result:=Parse(LFMBuffer);
441 end;
442
UpdateNeedednull443 function TLFMTree.UpdateNeeded: boolean;
444 begin
445 Result:=(LFMBuffer=nil) or (LFMBuffer.ChangeStep<>LFMBufferChangeStep)
446 or (FirstError<>nil);
447 end;
448
TLFMTree.PositionToCaretnull449 function TLFMTree.PositionToCaret(p: integer): TPoint;
450 begin
451 Result:=Point(0,0);
452 LFMBuffer.AbsoluteToLineCol(p,Result.Y,Result.X);
453 end;
454
455 procedure TLFMTree.AddError(ErrorType: TLFMErrorType;
456 LFMNode: TLFMTreeNode; const ErrorMessage: string; ErrorPosition: integer);
457 var
458 NewError: TLFMError;
459 begin
460 NewError:=TLFMError.Create;
461 NewError.Node:=LFMNode;
462 NewError.ErrorType:=ErrorType;
463 NewError.ErrorMessage:=ErrorMessage;
464 NewError.Source:=LFMBuffer;
465 NewError.Position:=ErrorPosition;
466 NewError.Caret:=PositionToCaret(NewError.Position);
467 //DebugLn('TLFMTree.AddError ',NewError.AsString, ' NodePath=',NewError.GetNodePath);
468 NewError.AddToTree(Self);
469 end;
470
FindErrorAtLinenull471 function TLFMTree.FindErrorAtLine(Line: integer): TLFMError;
472 begin
473 Result:=FirstError;
474 while Result<>nil do begin
475 if (Result.Caret.Y=Line) and (Line>=1) then exit;
476 Result:=Result.NextError;
477 end;
478 end;
479
FindErrorAtNodenull480 function TLFMTree.FindErrorAtNode(Node: TLFMTreeNode): TLFMError;
481 begin
482 Result:=FirstError;
483 while Result<>nil do begin
484 if (Result.Node=Node) and (Node<>nil) then exit;
485 Result:=Result.NextError;
486 end;
487 end;
488
FindErrornull489 function TLFMTree.FindError(ErrorTypes: TLFMErrorTypes): TLFMError;
490 begin
491 Result:=FirstError;
492 while (Result<>nil) and (not (Result.ErrorType in ErrorTypes)) do
493 Result:=Result.NextError;
494 end;
495
TLFMTree.FirstErrorAsStringnull496 function TLFMTree.FirstErrorAsString: string;
497 begin
498 Result:='';
499 if FirstError<>nil then Result:=FirstError.ErrorMessage;
500 end;
501
TLFMTree.FindPropertynull502 function TLFMTree.FindProperty(PropertyPath: string; ContextNode: TLFMTreeNode
503 ): TLFMPropertyNode;
504 var
505 Node: TLFMTreeNode;
506 ObjNode: TLFMObjectNode;
507 p: LongInt;
508 FirstPart: String;
509 RestParts: String;
510 begin
511 if ContextNode=nil then
512 Node:=Root
513 else
514 Node:=ContextNode.FirstChild;
515 p:=System.Pos('.',PropertyPath);
516 FirstPart:=copy(PropertyPath,1,p-1);
517 RestParts:=copy(PropertyPath,p+1,length(PropertyPath));
518 while Node<>nil do begin
519 if Node is TLFMPropertyNode then begin
520 Result:=TLFMPropertyNode(Node);
521 if SysUtils.CompareText(Result.CompleteName,PropertyPath)=0 then
522 exit;
523 end else if (Node is TLFMObjectNode)
524 and (RestParts<>'') then begin
525 ObjNode:=TLFMObjectNode(Node);
526 if CompareIdentifierPtrs(Pointer(ObjNode.Name),Pointer(FirstPart))=0 then
527 begin
528 Result:=FindProperty(RestParts,ObjNode);
529 exit;
530 end;
531 end;
532 Node:=Node.NextSibling;
533 end;
534 Result:=nil;
535 end;
536
537 procedure TLFMTree.WriteDebugReport;
538 var
539 Src: string;
540
541 procedure WriteNode(const Prefix: string; Node: TLFMTreeNode);
542 var
543 Child: TLFMTreeNode;
544 EndPos: LongInt;
545 begin
546 if Node=nil then exit;
547 Child:=Node.FirstChild;
548 EndPos:=Node.EndPos;
549 if (Child<>nil) and (EndPos>Child.StartPos) then
550 EndPos:=Child.StartPos;
551 DebugLn([Prefix,dbgstr(copy(Src,Node.StartPos,EndPos-Node.StartPos))]);
552 while Child<>nil do begin
553 WriteNode(Prefix+' ',Child);
554 Child:=Child.NextSibling;
555 end;
556 end;
557
558 begin
559 if LFMBuffer=nil then begin
560 DebugLn(['TLFMTree.WriteDebugReport LFMBuffer=nil']);
561 end;
562 DebugLn(['TLFMTree.WriteDebugReport ',LFMBuffer.Filename]);
563 Src:=LFMBuffer.Source;
564 WriteNode('',Root);
565 end;
566
NextTokennull567 function TLFMTree.NextToken: Char;
568 begin
569 TokenStart:=Parser.SourcePos+1;
570 while (TokenStart<=LFMBuffer.SourceLength)
571 and (LFMBuffer.Source[TokenStart] in [' ',#9,#10,#13]) do
572 inc(TokenStart);
573 Result:=Parser.NextToken;
574 end;
575
576 procedure TLFMTree.ProcessValue;
577 var
578 s: String;
579 MemStream: TMemoryStream;
580 SymbolNode: TLFMValueNodeSymbol;
581 begin
582 case Parser.Token of
583
584 toInteger:
585 begin
586 CreateChildNode(TLFMValueNode);
587 TLFMValueNode(CurNode).ValueType:=lfmvInteger;
588 NextToken;
589 CloseChildNode;
590 end;
591
592 toFloat:
593 begin
594 CreateChildNode(TLFMValueNode);
595 TLFMValueNode(CurNode).ValueType:=lfmvFloat;
596 NextToken;
597 CloseChildNode;
598 end;
599
600 Classes.toString, toWString:
601 begin
602 CreateChildNode(TLFMValueNode);
603 TLFMValueNode(CurNode).ValueType:=lfmvString;
604 while NextToken = '+' do begin
605 NextToken; // Get next string fragment
606 if not (Parser.Token in [Classes.toString,toWString]) then
607 Parser.CheckToken(Classes.toString);
608 end;
609 CloseChildNode;
610 end;
611
612 toSymbol:
613 begin
614 CreateChildNode(TLFMValueNodeSymbol);
615 SymbolNode:=TLFMValueNodeSymbol(CurNode);
616 if SymbolNode=nil then ;
617 s := Parser.TokenString;
618 if SysUtils.CompareText(s, 'End') = 0 then
619 SymbolNode.SymbolType:=lfmsNone
620 else if SysUtils.CompareText(s, 'True') = 0 then
621 SymbolNode.SymbolType:=lfmsTrue
622 else if SysUtils.CompareText(s, 'False') = 0 then
623 SymbolNode.SymbolType:=lfmsFalse
624 else if SysUtils.CompareText(s, 'nil') = 0 then
625 SymbolNode.SymbolType:=lfmsNil
626 else
627 begin
628 SymbolNode.SymbolType:=lfmsIdentifier;
629 Parser.TokenComponentIdent;
630 end;
631 if SymbolNode.SymbolType<>lfmsNone then
632 NextToken;
633 CloseChildNode;
634 end;
635
636 // Set
637 '[':
638 begin
639 CreateChildNode(TLFMValueNodeSet);
640 NextToken;
641 if Parser.Token <> ']' then
642 while True do
643 begin
644 CreateChildNode(TLFMEnumNode);
645 Parser.CheckToken(toSymbol);
646 CloseChildNode;
647 NextToken;
648 if Parser.Token = ']' then
649 break;
650 Parser.CheckToken(',');
651 NextToken;
652 end;
653 NextToken;
654 CloseChildNode;
655 end;
656
657 // List
658 '(':
659 begin
660 CreateChildNode(TLFMValueNodeList);
661 NextToken;
662 while Parser.Token <> ')' do
663 ProcessValue;
664 NextToken;
665 CloseChildNode;
666 end;
667
668 // Collection
669 '<':
670 begin
671 CreateChildNode(TLFMValueNodeCollection);
672 NextToken;
673 while Parser.Token <> '>' do
674 begin
675 Parser.CheckTokenSymbol('item');
676 NextToken;
677 CreateChildNode(TLFMValueNodeList);
678 while not Parser.TokenSymbolIs('end') do
679 ProcessProperty;
680 NextToken; // Skip 'end'
681 CloseChildNode;
682 end;
683 NextToken;
684 CloseChildNode;
685 end;
686
687 // Binary data
688 '{':
689 begin
690 CreateChildNode(TLFMValueNodeBinary);
691 MemStream := TMemoryStream.Create;
692 try
693 Parser.HexToBinary(MemStream);
694 finally
695 MemStream.Free;
696 end;
697 NextToken;
698 CloseChildNode;
699 end;
700
701 else
702 Parser.Error('invalid property');
703 end;
704 end;
705
706 procedure TLFMTree.ProcessProperty;
707 var
708 PropertyNode: TLFMPropertyNode;
709 begin
710 CreateChildNode(TLFMPropertyNode);
711 PropertyNode:=TLFMPropertyNode(CurNode);
712 if PropertyNode=nil then ;
713 // Get name of property
714 Parser.CheckToken(toSymbol);
715 PropertyNode.Add(Parser.TokenString,TokenStart);
716 while True do begin
717 NextToken;
718 if Parser.Token <> '.' then break;
719 NextToken;
720 Parser.CheckToken(toSymbol);
721 PropertyNode.Add(Parser.TokenString,TokenStart);
722 end;
723 Parser.CheckToken('=');
724 NextToken;
725 ProcessValue;
726 CloseChildNode;
727 end;
728
729 procedure TLFMTree.ProcessObject;
730 var
731 ObjectNode: TLFMObjectNode;
732 ObjectStartLine: LongInt;
733 begin
734 CreateChildNode(TLFMObjectNode);
735 ObjectNode:=TLFMObjectNode(CurNode);
736 if Parser.TokenSymbolIs('OBJECT') then
737 ObjectNode.IsInherited := False
738 else if Parser.TokenSymbolIs('INHERITED') then
739 ObjectNode.IsInherited := True
740 else begin
741 Parser.CheckTokenSymbol('INLINE');
742 ObjectNode.IsInline := True;
743 end;
744 NextToken;
745 Parser.CheckToken(toSymbol);
746 if not Parser.TokenSymbolIs('END') then begin
747 ObjectStartLine:=Parser.SourceLine;
748 ObjectNode.Name := '';
749 ObjectNode.TypeName := Parser.TokenString;
750 ObjectNode.TypeNamePosition:=TokenStart;
751 ObjectNode.ChildPos := -1;
752 NextToken;
753 if Parser.Token = ':' then begin
754 NextToken;
755 Parser.CheckToken(toSymbol);
756 ObjectNode.Name := ObjectNode.TypeName;
757 ObjectNode.NamePosition:=ObjectNode.TypeNamePosition;
758 ObjectNode.TypeName := Parser.TokenString;
759 ObjectNode.TypeNamePosition:=TokenStart;
760 NextToken;
761 if parser.Token = '[' then begin
762 NextToken;
763 ObjectNode.ChildPos := parser.TokenInt;
764 NextToken;
765 parser.CheckToken(']');
766 NextToken;
767 end;
768 end;
769
770 // read property list
771 while not (Parser.TokenSymbolIs('END')
772 or Parser.TokenSymbolIs('OBJECT')
773 or Parser.TokenSymbolIs('INHERITED')
774 or Parser.TokenSymbolIs('INLINE')) do
775 ProcessProperty;
776
777 // read child objects
778 while not Parser.TokenSymbolIs('END') do begin
779 if Parser.Token=toEOF then begin
780 Parser.Error('END not found for'
781 +' object='+ObjectNode.Name+':'+ObjectNode.TypeName
782 +' starting at line '+IntToStr(ObjectStartLine));
783 end;
784 ProcessObject;
785 end;
786 end;
787 NextToken; // Skip 'END' token
788
789 CloseChildNode;
790 end;
791
792 procedure TLFMTree.CreateChildNode(NodeClass: TLFMTreeNodeClass);
793 var
794 NewNode: TLFMTreeNode;
795 begin
796 NewNode:=NodeClass.CreateVirtual;
797 NewNode.Tree:=Self;
798 NewNode.StartPos:=TokenStart;
799 NewNode.EndPos:=0;
800 if CurNode<>nil then begin
801 CurNode.AddChild(NewNode);
802 end else begin
803 Root:=NewNode;
804 end;
805 CurNode:=NewNode;
806 end;
807
808 procedure TLFMTree.CloseChildNode;
809 begin
810 if CurNode.EndPos<1 then
811 CurNode.EndPos:=TokenStart;
812 CurNode:=CurNode.Parent;
813 end;
814
815 constructor TLFMTree.Create(TheTrees: TLFMTrees; aLFMBuf: TCodeBuffer);
816 begin
817 if (TheTrees=nil)
818 or (aLFMBuf=nil) then
819 raise Exception.Create('TLFMTree.Create need tree and buffer');
820 Trees:=TheTrees;
821 Trees.FItems.Add(Self);
822 LFMBuffer:=aLFMBuf;
823 LFMBufferChangeStep:=LFMBuffer.ChangeStep;
824 if LFMBufferChangeStep=Low(LFMBufferChangeStep) then
825 LFMBufferChangeStep:=High(LFMBufferChangeStep)
826 else
827 dec(LFMBufferChangeStep);
828 end;
829
830 { TLFMTreeNode }
831
832 constructor TLFMTreeNode.CreateVirtual;
833 begin
834
835 end;
836
837 destructor TLFMTreeNode.Destroy;
838 begin
839 while FirstChild<>nil do FirstChild.Free;
840 Unbind;
841 inherited Destroy;
842 end;
843
844 procedure TLFMTreeNode.Unbind;
845 begin
846 if Parent<>nil then begin
847 if Parent.FirstChild=Self then Parent.FirstChild:=NextSibling;
848 if Parent.LastChild=Self then Parent.LastChild:=PrevSibling;
849 Parent:=nil;
850 end;
851 if Tree<>nil then begin
852 if Tree.Root=Self then Tree.Root:=NextSibling;
853 Tree:=nil;
854 end;
855 if NextSibling<>nil then NextSibling.PrevSibling:=PrevSibling;
856 if PrevSibling<>nil then PrevSibling.NextSibling:=NextSibling;
857 NextSibling:=nil;
858 PrevSibling:=nil;
859 end;
860
861 procedure TLFMTreeNode.AddChild(ANode: TLFMTreeNode);
862 begin
863 if ANode=nil then exit;
864 ANode.Unbind;
865 ANode.Parent:=Self;
866 ANode.Tree:=Tree;
867 ANode.PrevSibling:=LastChild;
868 LastChild:=ANode;
869 if FirstChild=nil then FirstChild:=ANode;
870 if ANode.PrevSibling<>nil then
871 ANode.PrevSibling.NextSibling:=ANode;
872 end;
873
GetIdentifiernull874 function TLFMTreeNode.GetIdentifier: string;
875 var
876 IdentStart, IdentEnd: integer;
877 begin
878 Result:='';
879 if (Tree=nil) or (Tree.LFMBuffer=nil) or (StartPos<1) then exit;
880 FindIdentifier(IdentStart,IdentEnd);
881 if IdentStart<1 then exit;
882 Result:=copy(Tree.LFMBuffer.Source,IdentStart,IdentEnd-IdentStart);
883 end;
884
885 procedure TLFMTreeNode.FindIdentifier(out IdentStart, IdentEnd: integer);
886 var
887 Src: String;
888 SrcLen: Integer;
889 begin
890 IdentStart:=-1;
891 IdentEnd:=-1;
892 if (Tree=nil) or (Tree.LFMBuffer=nil) or (StartPos<1) then exit;
893 Src:=Tree.LFMBuffer.Source;
894 SrcLen:=length(Src);
895 IdentStart:=StartPos;
896 while (IdentStart<=SrcLen) and (Src[IdentStart] in [#0..#32]) do
897 inc(IdentStart);
898 IdentEnd:=IdentStart;
899 while (IdentEnd<=SrcLen)
900 and (Src[IdentEnd] in ['A'..'Z','a'..'z','0'..'9','_','.']) do
901 inc(IdentEnd);
902
903 if TheType=lfmnObject then begin
904 // skip object/inherited/inline
905 IdentStart:=IdentEnd;
906 while (IdentStart<=SrcLen) and (Src[IdentStart] in [#0..#32]) do
907 inc(IdentStart);
908 IdentEnd:=IdentStart;
909 while (IdentEnd<=SrcLen)
910 and (Src[IdentEnd] in ['A'..'Z','a'..'z','0'..'9','_','.']) do
911 inc(IdentEnd);
912 end;
913 //debugln('TLFMTreeNode.FindIdentifier ',copy(Src,IdentStart,IdentEnd-IdentStart),' ',DbgStr(copy(Src,StartPos,20)));
914
915 if IdentEnd<=IdentStart then begin
916 IdentStart:=-1;
917 IdentEnd:=-1;
918 end;
919 end;
920
GetPathnull921 function TLFMTreeNode.GetPath: string;
922 var
923 ANode: TLFMTreeNode;
924 PrependStr: String;
925 begin
926 Result:='';
927 ANode:=Self;
928 while ANode<>nil do begin
929 PrependStr:=ANode.GetIdentifier;
930 {PrependStr:=PrependStr+'('+dbgs(ANode.StartPos)+','+dbgs(ANode.EndPos)+')';
931 if (ANode.Tree<>nil) then begin
932 if (ANode.Tree.LFMBuffer<>nil) then begin
933 PrependStr:=PrependStr+'"'+DbgStr(copy(ANode.Tree.LFMBuffer.Source,ANode.StartPos,20))+'"';
934 end else begin
935 PrependStr:=PrependStr+'noLFMBuf';
936 end;
937 end else begin
938 PrependStr:=PrependStr+'noTree';
939 end;}
940 if PrependStr<>'' then begin
941 if Result<>'' then
942 Result:='/'+Result;
943 Result:=PrependStr+Result;
944 end;
945 ANode:=ANode.Parent;
946 end;
947 end;
948
Nextnull949 function TLFMTreeNode.Next(SkipChildren: Boolean = False): TLFMTreeNode;
950 begin
951 if not SkipChildren and (FirstChild <> nil) then
952 Result := FirstChild
953 else
954 begin
955 Result := Self;
956 while Result <> nil do
957 begin
958 if Result.NextSibling <> nil then
959 begin
960 Result := Result.NextSibling;
961 Exit;
962 end;
963 Result := Result.Parent;
964 end;
965 end;
966 end;
967
968 { TLFMObjectNode }
969
970 constructor TLFMObjectNode.CreateVirtual;
971 begin
972 TheType:=lfmnObject;
973 end;
974
975 { TLFMPropertyNode }
976
977 constructor TLFMPropertyNode.CreateVirtual;
978 begin
979 TheType:=lfmnProperty;
980 end;
981
982 destructor TLFMPropertyNode.Destroy;
983 begin
984 Clear;
985 inherited Destroy;
986 end;
987
988 procedure TLFMPropertyNode.Clear;
989 begin
990 CompleteName:='';
991 NameParts.Free;
992 NameParts:=nil;
993 end;
994
995 procedure TLFMPropertyNode.Add(const Name: string; NamePosition: integer);
996 begin
997 if NameParts=nil then NameParts:=TLFMNameParts.Create;
998 NameParts.Add(Name,NamePosition);
999 if CompleteName<>'' then
1000 CompleteName:=CompleteName+'.'+Name
1001 else
1002 CompleteName:=Name;
1003 end;
1004
1005 { TLFMValueNode }
1006
1007 constructor TLFMValueNode.CreateVirtual;
1008 begin
1009 TheType:=lfmnValue;
1010 ValueType:=lfmvNone;
1011 end;
1012
ReadStringnull1013 function TLFMValueNode.ReadString: string;
1014 var
1015 p: LongInt;
1016 Src: String;
1017 i: integer;
1018 AtomStart: LongInt;
1019 begin
1020 Result:='';
1021 if ValueType<>lfmvString then exit;
1022 p:=StartPos;
1023 AtomStart:=p;
1024 Src:=Tree.LFMBuffer.Source;
1025 repeat
1026 ReadRawNextPascalAtom(Src,p,AtomStart);
1027 if AtomStart>length(Src) then exit;
1028 if Src[AtomStart]='''' then begin
1029 Result:=Result+copy(Src,AtomStart+1,p-AtomStart-2)
1030 end else if Src[AtomStart]='+' then begin
1031 // skip
1032 end else if Src[AtomStart]='#' then begin
1033 i:=StrToIntDef(copy(Src,AtomStart+1,p-AtomStart-1),-1);
1034 if (i<0) or (i>255) then exit;
1035 Result:=Result+chr(i);
1036 end else
1037 exit;
1038 until false;
1039 end;
1040
1041 { TLFMValueNodeSymbol }
1042
1043 constructor TLFMValueNodeSymbol.CreateVirtual;
1044 begin
1045 inherited CreateVirtual;
1046 ValueType:=lfmvSymbol;
1047 SymbolType:=lfmsIdentifier;
1048 end;
1049
1050 { TLFMValueNodeSet }
1051
1052 constructor TLFMValueNodeSet.CreateVirtual;
1053 begin
1054 inherited CreateVirtual;
1055 ValueType:=lfmvSet;
1056 end;
1057
1058 { TLFMEnumNode }
1059
1060 constructor TLFMEnumNode.CreateVirtual;
1061 begin
1062 TheType:=lfmnEnum;
1063 end;
1064
1065 { TLFMValueNodeList }
1066
1067 constructor TLFMValueNodeList.CreateVirtual;
1068 begin
1069 inherited CreateVirtual;
1070 ValueType:=lfmvList;
1071 end;
1072
1073 { TLFMValueNodeCollection }
1074
1075 constructor TLFMValueNodeCollection.CreateVirtual;
1076 begin
1077 inherited CreateVirtual;
1078 ValueType:=lfmvCollection;
1079 end;
1080
1081 { TLFMValueNodeBinary }
1082
1083 constructor TLFMValueNodeBinary.CreateVirtual;
1084 begin
1085 inherited CreateVirtual;
1086 ValueType:=lfmvBinary;
1087 end;
1088
1089 { TLFMError }
1090
1091 constructor TLFMError.Create;
1092 begin
1093 Clear;
1094 end;
1095
1096 procedure TLFMError.Clear;
1097 begin
1098 ErrorType:=lfmeNoError;
1099 Source:=nil;
1100 end;
1101
1102 destructor TLFMError.Destroy;
1103 begin
1104 Unbind;
1105 inherited Destroy;
1106 end;
1107
AsStringnull1108 function TLFMError.AsString: string;
1109 begin
1110 Result:=LFMErrorTypeNames[ErrorType]+': '+ErrorMessage;
1111 if Source<>nil then begin
1112 Result:=Result+'. '+ExtractFileName(Source.Filename);
1113 Result:=Result+' ('+IntToStr(Caret.Y)+','+IntToStr(Caret.X)+')';
1114 end;
1115 end;
1116
1117 procedure TLFMError.AddToTree(ATree: TLFMTree);
1118 begin
1119 if Tree=ATree then exit;
1120 Unbind;
1121 if ATree=nil then exit;
1122 Tree:=ATree;
1123 PrevError:=Tree.LastError;
1124 Tree.LastError:=Self;
1125 if PrevError<>nil then PrevError.NextError:=Self;
1126 if Tree.FirstError=nil then Tree.FirstError:=Self;
1127 end;
1128
1129 procedure TLFMError.Unbind;
1130 begin
1131 if Tree<>nil then begin
1132 if Tree.FirstError=Self then Tree.FirstError:=NextError;
1133 if Tree.LastError=Self then Tree.LastError:=PrevError;
1134 Tree:=nil;
1135 end;
1136 if NextError<>nil then NextError.PrevError:=PrevError;
1137 if PrevError<>nil then PrevError.NextError:=NextError;
1138 PrevError:=nil;
1139 NextError:=nil;
1140 end;
1141
FindParentErrornull1142 function TLFMError.FindParentError: TLFMError;
1143 var
1144 CurNode: TLFMTreeNode;
1145 begin
1146 Result:=nil;
1147 if (Node=nil) or (Tree=nil) then exit;
1148 CurNode:=Node.Parent;
1149 while CurNode<>nil do begin
1150 Result:=Tree.FindErrorAtNode(CurNode);
1151 if Result<>nil then exit;
1152 CurNode:=CurNode.Parent;
1153 end;
1154 end;
1155
FindContextNodenull1156 function TLFMError.FindContextNode: TLFMTreeNode;
1157 begin
1158 Result:=Node;
1159 while (Result<>nil)
1160 and (not (Result.TheType in [lfmnProperty,lfmnObject])) do
1161 Result:=Result.Parent;
1162 end;
1163
TLFMError.IsMissingObjectTypenull1164 function TLFMError.IsMissingObjectType: boolean;
1165 begin
1166 Result:=(ErrorType in [lfmeIdentifierNotFound,lfmeMissingRoot])
1167 and (Node is TLFMObjectNode)
1168 and (TLFMObjectNode(Node).TypeName<>'')
1169 and (TLFMObjectNode(Node).TypeNamePosition=Position);
1170 end;
1171
TLFMError.GetNodePathnull1172 function TLFMError.GetNodePath: string;
1173 begin
1174 if Node<>nil then
1175 Result:=Node.GetPath
1176 else
1177 Result:='';
1178 end;
1179
1180 { TLFMNameParts }
1181
GetNamePositionsnull1182 function TLFMNameParts.GetNamePositions(Index: integer): integer;
1183 begin
1184 Result:=FNamePositions[Index];
1185 end;
1186
GetNamesnull1187 function TLFMNameParts.GetNames(Index: integer): string;
1188 begin
1189 Result:=FNames[Index];
1190 end;
1191
1192 destructor TLFMNameParts.Destroy;
1193 begin
1194 Clear;
1195 inherited Destroy;
1196 end;
1197
1198 procedure TLFMNameParts.Clear;
1199 var
1200 i: Integer;
1201 begin
1202 ReAllocMem(FNamePositions,0);
1203 for i:=0 to FCount-1 do FNames[i]:='';
1204 ReAllocMem(FNames,0);
1205 end;
1206
1207 procedure TLFMNameParts.Add(const Name: string; NamePosition: integer);
1208 var
1209 p: PPChar;
1210 begin
1211 inc(FCount);
1212 ReAllocMem(FNamePositions,SizeOf(Integer)*FCount);
1213 FNamePositions[FCount-1]:=NamePosition;
1214 ReAllocMem(FNames,SizeOf(PChar)*FCount);
1215 p:=PPChar(FNames);
1216 p[FCount-1]:=nil;
1217 FNames[FCount-1]:=Name;
1218 end;
1219
1220 { TLFMTrees }
1221
1222 constructor TLFMTrees.Create;
1223 begin
1224 FItems:=TAVLTree.Create(@CompareLFMTreesByLFMBuffer);
1225 end;
1226
1227 destructor TLFMTrees.Destroy;
1228 begin
1229 Clear;
1230 FreeAndNil(FItems);
1231 inherited Destroy;
1232 end;
1233
1234 procedure TLFMTrees.Clear;
1235 begin
1236 FClearing:=true;
1237 FItems.FreeAndClear;
1238 FClearing:=false;
1239 end;
1240
GetLFMTreenull1241 function TLFMTrees.GetLFMTree(LFMBuffer: TCodeBuffer; CreateIfNotExists: boolean
1242 ): TLFMTree;
1243 var
1244 AVLNode: TAVLTreeNode;
1245 begin
1246 AVLNode:=FItems.FindKey(LFMBuffer,@CompareLFMBufWithTree);
1247 if AVLNode<>nil then
1248 Result:=TLFMTree(AVLNode.Data)
1249 else if CreateIfNotExists then
1250 Result:=TLFMTree.Create(Self,LFMBuffer)
1251 else
1252 Result:=nil;
1253 end;
1254
1255 finalization
1256 FreeAndNil(DefaultLFMTrees);
1257
1258 end.
1259
1260