paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-02 13:19:49 +01:00
Code Issues Packages Projects Releases Wiki Activity

codetools: parsing advanced records

Browse Source 
git-svn-id: trunk@29359 -
This commit is contained in:
mattias 2011-02-03 20:38:14 +00:00
parent 0324c50205
commit 05be735961
10 changed files with 135 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/codetools/codecompletiontool.pas
View File

@ -4615,7 +4615,7 @@ function TCodeCompletionCodeTool.BuildUnitDefinitionGraph(out
end;
end;
ctnRecordType, ctnClassInterface, ctnDispinterface, ctnClass, ctnObject,
ctnClassInterface, ctnDispinterface, ctnClass, ctnObject, ctnRecordType,
ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
begin
ChildNode:=SubNode.FirstChild;

13
components/codetools/codetree.pas
View File

@ -158,12 +158,10 @@ const
[ctnClassPublic,ctnClassPublished,ctnClassPrivate,ctnClassProtected];
AllClassSections =
AllClassBaseSections+[ctnClassConst, ctnClassType, ctnClassVar, ctnClassClassVar];
AllClasses =
[ctnClass,ctnClassInterface,ctnDispinterface,ctnObject,
ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
ctnCPPClass];
AllClassInterfaces = [ctnClassInterface,ctnDispinterface,ctnObjCProtocol];
AllClassObjects = [ctnClass,ctnObject,ctnObjCClass,ctnObjCCategory,ctnCPPClass];
AllClassObjects = [ctnClass,ctnObject,ctnRecordType,
ctnObjCClass,ctnObjCCategory,ctnCPPClass];
AllClasses = AllClassObjects+AllClassObjects;
AllClassModifiers = [ctnClassAbstract, ctnClassSealed, ctnClassExternal];
AllDefinitionSections =
[ctnTypeSection,ctnVarSection,ctnConstSection,ctnResStrSection,
@ -175,7 +173,7 @@ const
AllPascalTypes =
AllClasses+
[ctnGenericType,ctnSpecialize,
ctnIdentifier,ctnOpenArrayType,ctnRangedArrayType,ctnRecordType,
ctnIdentifier,ctnOpenArrayType,ctnRangedArrayType,
ctnRecordCase,ctnRecordVariant,
ctnProcedureType,ctnSetType,ctnRangeType,ctnEnumerationType,
ctnEnumIdentifier,ctnLabelType,ctnTypeType,ctnFileType,ctnPointerType,
@ -184,8 +182,7 @@ const
ctnOnBlock,ctnOnIdentifier,ctnOnStatement];
AllFindContextDescs = AllIdentifierDefinitions + AllCodeSections + AllClasses +
[ctnProcedure];
AllPointContexts = AllClasses+AllSourceTypes+[ctnRecordType,
ctnEnumerationType,ctnInterface];
AllPointContexts = AllClasses+AllSourceTypes+[ctnEnumerationType,ctnInterface];
// CodeTreeNodeSubDescriptors

2
components/codetools/customcodetool.pas
View File

@ -582,7 +582,7 @@ begin
begin
if (SubDesc and ctnsNeedJITParsing)>0 then Result:=ctsUnparsed;
end;
ctnClass,ctnObject,ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
ctnClass,ctnObject,ctnRecordType,ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
ctnCPPClass,ctnClassInterface,ctnDispinterface:
begin
Result:='';

37
components/codetools/examples/scanexamples/recordsexample.pas
View File

@ -3,15 +3,18 @@ program RecordsExample;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords} // {$mode delphi} has it automatically
uses
Classes, SysUtils;
// advanced records
type
TRec1 = record
hWnd : HWND;
hWnd : integer;
private
F1: Integer;
F2: Byte;
public
type
{ type
TBar = Integer;
const
C: TBar = 1;
@ -26,30 +29,42 @@ type
var
F: Int;
const
DefaultF: Int = 1;
DefaultF: Int = 1;}
public
function GetF: Int;
procedure SetF(const Value: Int);
function GetF: integer;
procedure SetF(const Value: integer);
// full list of operators see in tests/test/terecs6.pp
class operator Inc(Rec: TRec1): TRec1;
public
case y: integer of
0: (a: integer);
1,2,3: (b: array[char] of char; c: char);
3: ( d: record
case byte of
10: (i: integer; );
11: (y: byte);
end; );
4: (e: integer;
case byte of
8: (f: integer)
);
end;
function TRec1.GetF: Int;
function TRec1.GetF: integer;
begin
Result := F;
Result := F1;
end;
procedure TRec1.SetF(const Value: Int);
procedure TRec1.SetF(const Value: integer);
begin
F := Value;
F1 := Value;
end;
class operator TRec1.Inc(Rec: TRec1): TRec1;
begin
Result.F := Rec.F + 1;
Result.F1 := Rec.F1 + 1;
end;
begin
end.

2
components/codetools/finddeclarationcache.pas
View File

@ -108,7 +108,7 @@ type
}
const
AllNodeCacheDescs =
AllClasses+[ctnProcedure, ctnRecordType, ctnWithStatement];
AllClasses+[ctnProcedure, ctnWithStatement];
type
TNodeCacheEntryFlag = (ncefSearchedInParents, ncefSearchedInAncestors);

22
components/codetools/finddeclarationtool.pas
View File

@ -1681,8 +1681,7 @@ begin
exit;
end;
if (not (Context.Node.Desc in (AllClasses+[ctnRecordType])))
then begin
if (not (Context.Node.Desc in AllClasses)) then begin
debugln(['TFindDeclarationTool.FindDeclarationOfPropertyPath failed Context=',Context.Node.DescAsString]);
exit;
end;
@ -2189,7 +2188,8 @@ begin
TypeNode:=NewTool.FindTypeNodeOfDefinition(NewNode);
if TypeNode<>nil then begin
case TypeNode.Desc of
ctnIdentifier, ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
ctnIdentifier, ctnClass, ctnClassInterface, ctnDispinterface,
ctnObject, ctnRecordType,
ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
begin
NewTool.MoveCursorToNodeStart(TypeNode);
@ -2309,7 +2309,7 @@ begin
Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChilds];
FindContext:=FindBaseTypeOfNode(Params,ANode);
if (FindContext.Node<>nil)
and ((FindContext.Node.Desc in ([ctnRecordType,ctnEnumerationType]+AllClasses)))
and ((FindContext.Node.Desc in ([ctnEnumerationType]+AllClasses)))
and (FindContext.Node.FirstChild<>nil)
then
Result:=true;
@ -4568,10 +4568,6 @@ begin
Result:=InNodeIdentifier(CurPos.StartPos);
end;
ctnBeginBlock,ctnClass,ctnObject,ctnObjCClass,ctnObjCCategory,ctnCPPClass:
if (Node.SubDesc and ctnsForwardDeclaration)>0 then
RaiseException('TFindDeclarationTool.CleanPosIsDeclarationIdentifier Node not expanded');
end;
end;
@ -5199,7 +5195,7 @@ begin
or (WithVarExpr.Context.Node=nil)
or (WithVarExpr.Context.Node=OldInput.ContextNode)
or (not (WithVarExpr.Context.Node.Desc
in (AllClasses+[ctnRecordType,ctnEnumerationType])))
in (AllClasses+[ctnEnumerationType])))
then begin
MoveCursorToCleanPos(WithVarNode.StartPos);
RaiseException(ctsExprTypeMustBeClassOrRecord);
@ -6839,7 +6835,7 @@ var
ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params,
ExprType.Context.Node.FirstChild);
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass,
ctnProperty, ctnGlobalProperty:
begin
@ -8384,7 +8380,7 @@ begin
// same context type
case ExprNode.Desc of
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
// check, if ExpressionType.Context is descend of TargetContext
if ContextIsDescendOf(ExpressionType.Context,
@ -9530,7 +9526,7 @@ begin
DebugLn(['TFindDeclarationTool.FindOperatorEnumerator ClassContext=',FindContextToString(ClassContext)]);
{$ENDIF}
case ClassContext.Node.Desc of
ctnClass,ctnObject,ctnClassInterface: ;
ctnClass,ctnObject,ctnRecordType,ctnClassInterface: ;
else
OperatorTool.MoveCursorToNodeStart(OperatorNode);
OperatorTool.RaiseException('operator enumerator result type is not object');
@ -9940,7 +9936,7 @@ begin
Result:=GetIdentifier(@FindContext.Tool.Src[ANode.StartPos]);
end;
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
if (FindContext.Node.Parent<>nil)
and (FindContext.Node.Parent.Desc in [ctnTypeDefinition,ctnGenericType])

2
components/codetools/findoverloads.pas
View File

@ -161,7 +161,7 @@ begin
while ParentCodeNode<>nil do begin
//DebugLn(['TDeclarationOverloadsGraph.AddContext ',ParentCodeNode.DescAsString]);
if ParentCodeNode.Desc in
AllSourceTypes+AllClasses+[ctnRecordType]
AllSourceTypes+AllClasses
then begin
//DebugLn(['TDeclarationOverloadsGraph.AddContext ADD parent']);
ParentGraphNode:=AddContext(Tool,ParentCodeNode);

27
components/codetools/identcompletiontool.pas
View File

@ -1598,8 +1598,9 @@ var
begin
Node:=Context.Node;
//debugln(['TIdentCompletionTool.GatherContextKeywords ',Node.DescAsString]);
case Node.Desc of
ctnClass,ctnObject,ctnObjCCategory,ctnObjCClass,
ctnClass,ctnObject,ctnRecordType,ctnObjCCategory,ctnObjCClass,
ctnClassPrivate,ctnClassProtected,ctnClassPublic,ctnClassPublished:
begin
Add('public');
@ -1609,8 +1610,13 @@ begin
Add('procedure');
Add('function');
Add('property');
Add('constructor');
Add('destructor');
if (Node.Desc=ctnClass) or (Node.Parent.Desc=ctnClass) then begin
Add('constructor');
Add('destructor');
end;
if (Node.Desc=ctnRecordType) or (Node.Parent.Desc=ctnRecordType) then begin
Add('case');
end;
if (Node.LastChild<>nil) and (CleanPos>Node.LastChild.StartPos)
and (Node.LastChild.EndPos>Node.LastChild.StartPos)
and (Node.LastChild.EndPos<Srclen) then begin
@ -1656,7 +1662,7 @@ begin
end;
ctnVarDefinition:
if Node.Parent.Desc in [ctnClass,ctnObject,ctnObjCCategory,ctnObjCClass]
if Node.Parent.Desc in [ctnClass,ctnObject,ctnRecordType,ctnObjCCategory,ctnObjCClass]
+AllClassBaseSections
then begin
Add('public');
@ -1666,8 +1672,13 @@ begin
Add('procedure');
Add('function');
Add('property');
Add('constructor');
Add('destructor');
if (Node.Desc=ctnClass) or (Node.Parent.Desc=ctnClass) then begin
Add('constructor');
Add('destructor');
end;
if (Node.Desc=ctnRecordType) or (Node.Parent.Desc=ctnRecordType) then begin
Add('case');
end;
end;
ctnProperty:
@ -2789,7 +2800,7 @@ var
ANode: TCodeTreeNode;
begin
Result:=false;
if GetDesc in (AllClasses+[ctnRecordType]) then begin
if GetDesc in AllClasses then begin
Result:=true;
exit;
end;
@ -2798,7 +2809,7 @@ begin
UpdateBaseContext;
if (BaseExprType.Desc=xtContext)
and (BaseExprType.Context.Node<>nil)
and (BaseExprType.Context.Node.Desc in (AllClasses+[ctnRecordType]))
and (BaseExprType.Context.Node.Desc in AllClasses)
then
Include(Flags,iliHasChilds);
Result:=true;

5
components/codetools/methodjumptool.pas
View File

@ -350,7 +350,8 @@ begin
{$ENDIF}
// first test if in a class
ClassNode:=CursorNode.GetNodeOfTypes([ctnClass,ctnClassInterface,
ctnDispinterface,ctnObject,ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
ctnDispinterface,ctnObject,ctnRecordType,
ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
ctnCPPClass]);
if ClassNode<>nil then begin
// cursor is in class/object/interface definition
@ -792,7 +793,7 @@ begin
cmp:=false;
end;
if cmp and (phpIgnoreMethods in Attr) then begin
if (ANode.GetNodeOfTypes([ctnClass,ctnObject,
if (ANode.GetNodeOfTypes([ctnClass,ctnObject,ctnRecordType,
ctnObjCClass,ctnObjCCategory,ctnCPPClass])<>nil)
or (ExtractClassNameOfProcNode(ANode)<>'')
then

102
components/codetools/pascalparsertool.pas
View File

@ -141,8 +141,8 @@ type
procedure ReadConst;
// types
procedure ReadEqualsType;
function KeyWordFuncClass: boolean;
function KeyWordFuncClassInterface: boolean;
function KeyWordFuncTypeClass: boolean;
function KeyWordFuncTypeClassInterface: boolean;
function KeyWordFuncTypePacked: boolean;
function KeyWordFuncTypeBitPacked: boolean;
function KeyWordFuncSpecialize: boolean;
@ -153,7 +153,7 @@ type
function KeyWordFuncTypeType: boolean;
function KeyWordFuncTypeFile: boolean;
function KeyWordFuncTypePointer: boolean;
function KeyWordFuncTypeRecord: boolean;
function KeyWordFuncTypeRecordOld: boolean;
function KeyWordFuncTypeRecordCase: boolean;
function KeyWordFuncTypeDefault: boolean;
// procedures/functions/methods
@ -399,34 +399,34 @@ begin
if CompareSrcIdentifiers('BITPACKED',p) then exit(KeyWordFuncTypeBitPacked);
'C':
case UpChars[p[1]] of
'L': if CompareSrcIdentifiers('CLASS',p) then exit(KeyWordFuncClass);
'P': if CompareSrcIdentifiers('CPPCLASS',p) then exit(KeyWordFuncClass);
'L': if CompareSrcIdentifiers('CLASS',p) then exit(KeyWordFuncTypeClass);
'P': if CompareSrcIdentifiers('CPPCLASS',p) then exit(KeyWordFuncTypeClass);
end;
'D':
if CompareSrcIdentifiers('DISPINTERFACE',p) then exit(KeyWordFuncClassInterface);
if CompareSrcIdentifiers('DISPINTERFACE',p) then exit(KeyWordFuncTypeClassInterface);
'F':
case UpChars[p[1]] of
'I': if CompareSrcIdentifiers('FILE',p) then exit(KeyWordFuncTypeFile);
'U': if CompareSrcIdentifiers('FUNCTION',p) then exit(KeyWordFuncTypeProc);
end;
'I':
if CompareSrcIdentifiers('INTERFACE',p) then exit(KeyWordFuncClassInterface);
if CompareSrcIdentifiers('INTERFACE',p) then exit(KeyWordFuncTypeClassInterface);
'L':
if CompareSrcIdentifiers('LABEL',p) then exit(KeyWordFuncTypeLabel);
'O':
if CompareSrcIdentifiers('OBJECT',p)
or CompareSrcIdentifiers('OBJCCLASS',p)
or CompareSrcIdentifiers('OBJCCATEGORY',p) then
exit(KeyWordFuncClass)
exit(KeyWordFuncTypeClass)
else if CompareSrcIdentifiers('OBJCPROTOCOL',p) then
exit(KeyWordFuncClassInterface);
exit(KeyWordFuncTypeClassInterface);
'P':
case UpChars[p[1]] of
'A': if CompareSrcIdentifiers('PACKED',p) then exit(KeyWordFuncTypePacked);
'R': if CompareSrcIdentifiers('PROCEDURE',p) then exit(KeyWordFuncTypeProc);
end;
'R':
if CompareSrcIdentifiers('RECORD',p) then exit(KeyWordFuncTypeRecord);
if CompareSrcIdentifiers('RECORD',p) then exit(KeyWordFuncTypeClass);
'S':
case UpChars[p[1]] of
'E': if CompareSrcIdentifiers('SET',p) then exit(KeyWordFuncTypeSet);
@ -441,7 +441,7 @@ end;
function TPascalParserTool.ParseInnerClass(StartPos, WordLen: integer
): boolean;
// KeyWordFunctions for parsing in a class/object
// KeyWordFunctions for parsing in a class/object/record
var
p: PChar;
begin
@ -450,6 +450,7 @@ begin
case UpChars[p^] of
'C':
case UpChars[p[1]] of
'A': if CompareSrcIdentifiers(p,'CASE') then exit(KeyWordFuncTypeRecordCase);
'L': if CompareSrcIdentifiers(p,'CLASS') then exit(KeyWordFuncClassClass);
'O': if CompareSrcIdentifiers(p,'CONSTRUCTOR') then exit(KeyWordFuncClassMethod)
else if CompareSrcIdentifiers(p,'CONST') then exit(KeyWordFuncClassConstSection);
@ -3614,11 +3615,8 @@ begin
Result:=true;
end;
function TPascalParserTool.KeyWordFuncClass: boolean;
// class, object
// this is a quick parser, which will only create one node for each class
// the nodes for the methods and properties are created in a second
// parsing phase (in KeyWordFuncClassMethod)
function TPascalParserTool.KeyWordFuncTypeClass: boolean;
// class, object, record
var
ClassAtomPos: TAtomPosition;
ContextDesc: Word;
@ -3626,23 +3624,13 @@ var
ClassDesc: TCodeTreeNodeDesc;
ClassNode: TCodeTreeNode;
begin
ContextDesc:=CurNode.Desc;
if not (ContextDesc in [ctnTypeDefinition,ctnGenericType,
ctnVarDefinition,ctnConstDefinition])
then
SaveRaiseExceptionFmt(ctsAnonymDefinitionsAreNotAllowed,['class']);
if CurNode.Parent.Desc<>ctnTypeSection then
SaveRaiseExceptionFmt(ctsNestedDefinitionsAreNotAllowed,['class']);
if LastUpAtomIs(0,'PACKED') or LastUpAtomIs(0,'BITPACKED') then begin
ClassAtomPos:=LastAtoms.GetValueAt(0);
end else begin
ClassAtomPos:=CurPos;
end;
// class or 'class of' start found
if UpAtomIs('CLASS') then
ClassDesc:=ctnClass
else if UpAtomIs('OBJECT') then
ClassDesc:=ctnObject
else if UpAtomIs('RECORD') then
ClassDesc:=ctnRecordType
else if UpAtomIs('OBJCCLASS') then
ClassDesc:=ctnObjCClass
else if UpAtomIs('OBJCCATEGORY') then
@ -3651,13 +3639,26 @@ begin
ClassDesc:=ctnCPPClass
else
RaiseStringExpectedButAtomFound('class');
ContextDesc:=CurNode.Desc;
if ClassDesc<>ctnRecordType then begin
if not (ContextDesc in [ctnTypeDefinition,ctnGenericType])
then
SaveRaiseExceptionFmt(ctsAnonymDefinitionsAreNotAllowed,[GetAtom]);
if CurNode.Parent.Desc<>ctnTypeSection then
SaveRaiseExceptionFmt(ctsNestedDefinitionsAreNotAllowed,[GetAtom]);
end;
if LastUpAtomIs(0,'PACKED') or LastUpAtomIs(0,'BITPACKED') then begin
ClassAtomPos:=LastAtoms.GetValueAt(0);
end else begin
ClassAtomPos:=CurPos;
end;
CreateChildNode;
ClassNode:=CurNode;
CurNode.Desc:=ClassDesc;
CurNode.StartPos:=ClassAtomPos.StartPos;
IsForward:=true;
ReadNextAtom;
if UpAtomIs('OF') then begin
if (ClassDesc=ctnClass) and UpAtomIs('OF') then begin
IsForward:=false;
CurNode.Desc:=ctnClassOfType;
ReadNextAtom;
@ -3691,7 +3692,7 @@ begin
ReadNextAtom;
end;
end
else if UpAtomIs('EXTERNAL') and (ClassDesc in [ctnObjCClass]) then
else if UpAtomIs('EXTERNAL') and (ClassDesc=ctnObjCClass) then
begin
CreateChildNode;
CurNode.Desc:=ctnClassExternal;
@ -3775,7 +3776,7 @@ begin
Result:=true;
end;
function TPascalParserTool.KeyWordFuncClassInterface: boolean;
function TPascalParserTool.KeyWordFuncTypeClassInterface: boolean;
// class interface, dispinterface
var
IntfAtomPos: TAtomPosition;
@ -4187,7 +4188,7 @@ begin
Result:=true;
end;
function TPascalParserTool.KeyWordFuncTypeRecord: boolean;
function TPascalParserTool.KeyWordFuncTypeRecordOld: boolean;
{ read variable type 'record'
examples:
@ -4256,10 +4257,45 @@ begin
end;
function TPascalParserTool.KeyWordFuncTypeRecordCase: boolean;
{ after parsing CurPos is on the atom behind the case
record
i: packed record
j: integer;
k: record end;
case y: integer of
0: (a: integer);
1,2,3: (b: array[char] of char; c: char);
3: ( d: record
case byte of
10: (i: integer; );
11: (y: byte);
end; );
4: (e: integer;
case z of
8: (f: integer)
);
end;
end;
}
procedure RaiseCaseOnlyAllowedInRecords;
begin
SaveRaiseException('Case only allowed in records');
end;
begin
if not UpAtomIs('CASE') then
SaveRaiseException('[TPascalParserTool.KeyWordFuncTypeRecordCase] '
+'internal error');
if (CurNode.Parent.Desc=ctnRecordVariant)
or ((CurNode.Parent.Desc in AllClassSections)
and (CurNode.Parent.Parent.Desc=ctnRecordType))
then begin
// ok
end else begin
RaiseCaseOnlyAllowedInRecords;
end;
CreateChildNode;
CurNode.Desc:=ctnRecordCase;
ReadNextAtom; // read ordinal type
@ -4335,7 +4371,7 @@ begin
ReadNextAtom;
until false;
ReadNextAtom;
if (CurPos.Flag in [cafEnd,cafRoundBracketClose]) then begin
if (CurPos.Flag in [cafEnd,cafRoundBracketClose,cafEdgedBracketClose]) then begin
CurNode.EndPos:=CurPos.StartPos;
EndChildNode; // close variant
break;