paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 00:29:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* ObjCCategory

Browse Source 
git-svn-id: trunk@45514 -
This commit is contained in:
michael 2020-05-27 08:45:19 +00:00
parent 96cd0020a6
commit 8e0a97ca42
6 changed files with 83 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
packages/fcl-passrc/src/pastree.pp
View File

@ -764,12 +764,14 @@ type
okObject, okClass, okInterface,
// okGeneric removed in FPC 3.3.1 check instead GenericTemplateTypes<>nil
// okSpecialize removed in FPC 3.1.1
okClassHelper,okRecordHelper,okTypeHelper,
okDispInterface);
okClassHelper, okRecordHelper, okTypeHelper,
okDispInterface, okObjcClass, okObjcCategory,
okObjcProtocol);
const
okWithFields = [okObject, okClass];
okAllHelpers = [okClassHelper,okRecordHelper,okTypeHelper];
okWithClassFields = okWithFields+okAllHelpers;
okObjCClasses = [okObjcClass, okObjcCategory, okObjcProtocol];
type
@ -797,13 +799,13 @@ type
IsForward: Boolean;
IsExternal : Boolean;
IsShortDefinition: Boolean;//class(anchestor); without end
IsObjCClass : Boolean;
GUIDExpr : TPasExpr;
Modifiers: TStringList;
Interfaces : TFPList; // list of TPasType
ExternalNameSpace : String;
ExternalName : String;
InterfaceType: TPasClassInterfaceType;
Function IsObjCClass : Boolean;
Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function InterfaceGUID : string;
@ -1688,7 +1690,8 @@ const
ObjKindNames: array[TPasObjKind] of string = (
'object', 'class', 'interface',
'class helper','record helper','type helper',
'dispinterface');
'dispinterface', 'ObjcClass', 'ObjcCategory',
'ObjcProtocol');
InterfaceTypeNames: array[TPasClassInterfaceType] of string = (
'COM',
@ -3400,6 +3403,12 @@ begin
ForEachChildCall(aMethodCall,Arg,GUIDExpr,false);
end;
function TPasClassType.IsObjCClass: Boolean;
begin
Result:=ObjKind in okObjCClasses;
end;
function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
Var

49
packages/fcl-passrc/src/pparser.pp
View File

@ -1871,14 +1871,23 @@ function TPasParser.ParseType(Parent: TPasElement;
const NamePos: TPasSourcePos; const TypeName: String; Full: Boolean
): TPasType;
Type
TLocalClassType = (lctClass,lctObjcClass,lctObjcCategory,lctHelper);
Const
// These types are allowed only when full type declarations
FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkObjCClass,tkInterface,tkObjcProtocol,tkDispInterface,tkType];
// Parsing of these types already takes care of hints
NoHintTokens = [tkProcedure,tkFunction];
InterfaceKindTypes : Array[Boolean] of TPasObjKind = (okInterface,okObjcProtocol);
ClassKindTypes : Array[TLocalClassType] of TPasObjKind = (okClass,okObjCClass,okObjcCategory,okClassHelper);
var
PM: TPackMode;
CH, isHelper, isObjCClass, ok: Boolean;
CH, ok, isHelper : Boolean;
lClassType : TLocalClassType;
begin
Result := nil;
// NextToken and check pack mode
@ -1901,34 +1910,34 @@ begin
tkObjcProtocol,
tkInterface:
begin
isObjCClass:=(CurToken=tkObjcProtocol);
Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface,PM);
TPasClassType(Result).IsObjCClass:=isObjCClass;
Result := ParseClassDecl(Parent, NamePos, TypeName, InterfaceKindTypes[(CurToken=tkObjcProtocol)],PM);
end;
tkSpecialize:
Result:=ParseSimpleType(Parent,CurSourcePos,TypeName);
tkObjCClass,
tkobjccategory,
tkClass:
begin
isHelper:=false;
isObjCClass:=(CurToken=tkObjCClass);
NextToken;
if CurTokenIsIdentifier('Helper') then
begin
// class helper: atype end;
// class helper for atype end;
NextToken;
isHelper:=CurToken in [tkfor,tkBraceOpen];
UnGetToken;
end;
UngetToken;
if isHelper then
Result:=ParseClassDecl(Parent,NamePos,TypeName,okClassHelper, PM)
If (CurToken=tkObjCClass) then
lClassType:=lctObjcClass
else if (CurToken=tkobjccategory) then
lClassType:=lctObjcCategory
else
begin
Result:=ParseClassDecl(Parent, NamePos, TypeName, okClass, PM);
TPasClassType(Result).isObjCClass:=isObjCClass;
lClassType:=lctClass;
NextToken;
if CurTokenIsIdentifier('Helper') then
begin
// class helper: atype end;
// class helper for atype end;
NextToken;
if CurToken in [tkfor,tkBraceOpen] then
lClassType:=lctHelper;
UnGetToken;
end;
UngetToken;
end;
Result:=ParseClassDecl(Parent,NamePos,TypeName,ClassKindTypes[lClasstype], PM);
end;
tkType:
begin

2
packages/fcl-passrc/src/pscanner.pp
View File

@ -220,6 +220,7 @@ type
tkmod,
tknil,
tknot,
tkobjccategory,
tkobjcclass,
tkobjcprotocol,
tkobject,
@ -1006,6 +1007,7 @@ const
'mod',
'nil',
'not',
'objccategory',
'objcclass',
'objcprotocol',
'object',

31
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -10,7 +10,7 @@ uses
type
{ TTestClassType }
TClassDeclType = (cdtClass,cdtObjCClass,cdtObjCCategory);
TTestClassType = Class(TBaseTestTypeParser)
Private
FDecl : TStrings;
@ -30,7 +30,7 @@ type
function GetP2: TPasProperty;
function GetT(AIndex : Integer) : TPasType;
protected
Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = ''; UseObjcClass : Boolean = False);
Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = ''; aClassType : TClassDeclType = cdtClass);
Procedure StartExternalClass (AParent : String; AExternalName,AExternalNameSpace : String );
Procedure StartClassHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False);
@ -70,6 +70,7 @@ type
procedure TestEmptyEnd;
procedure TestEmptyEndNoParent;
procedure TestEmptyObjC;
procedure TestEmptyObjCCategory;
Procedure TestOneInterface;
Procedure TestTwoInterfaces;
procedure TestOneSpecializedClass;
@ -254,7 +255,7 @@ begin
Result:=TPasConst(Members[AIndex]);
end;
procedure TTestClassType.StartClass(AncestorName: String; InterfaceList: String = ''; UseObjcClass: Boolean = false);
procedure TTestClassType.StartClass(AncestorName: String; InterfaceList: String = ''; aClassType : TClassDeclType = cdtClass);
Var
S : String;
@ -262,13 +263,20 @@ begin
if FStarted then
Fail('TTestClassType.StartClass already started');
FStarted:=True;
if UseObjcClass then
case aClassType of
cdtObjCClass:
begin
FDecl.Add('{$modeswitch objectivec1}');
S:='TMyClass = ObjCClass';
end
end;
cdtObjCCategory:
begin
FDecl.Add('{$modeswitch objectivec1}');
S:='TMyClass = ObjCCategory(aParent)';
end;
else
S:='TMyClass = Class';
end;
if (AncestorName<>'') then
begin
S:=S+'('+AncestorName;
@ -533,12 +541,21 @@ end;
procedure TTestClassType.TestEmptyObjC;
begin
StartClass('','',True);
StartClass('','',cdtObjCClass);
ParseClass;
AssertEquals('No members',0,TheClass.Members.Count);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
end;
procedure TTestClassType.TestEmptyObjCCategory;
begin
StartClass('','',cdtObjCCategory);
ParseClass;
AssertEquals('No members',0,TheClass.Members.Count);
AssertEquals('Is interface',okObjcCategory,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
end;
procedure TTestClassType.TestOneInterface;
begin
StartClass('TObject','ISomething');
@ -1906,7 +1923,7 @@ begin
StartInterface('','',False,True);
EndClass();
ParseClass;
AssertEquals('Is interface',okInterface,TheClass.ObjKind);
AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
AssertEquals('No members',0,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);

13
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -201,6 +201,8 @@ type
procedure TestObjCClass2;
procedure TestObjCProtocol;
procedure TestObjCProtocol2;
procedure TestObjCCategory;
procedure TestObjCCategory2;
procedure TestTab;
Procedure TestEscapedKeyWord;
Procedure TestTokenSeries;
@ -1382,6 +1384,17 @@ begin
TestTokens([tkComment,tkWhitespace,tkidentifier],'{$mode fpc} objcprotocol');
end;
procedure TTestScanner.TestObjCCategory;
begin
TestToken(tkObjCCategory,'objccategory');
end;
procedure TTestScanner.TestObjCCategory2;
begin
TestTokens([tkComment,tkWhitespace,tkidentifier],'{$mode fpc} objccategory');
end;
procedure TTestScanner.TestTab;

4
packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -24,13 +24,13 @@
</PublishOptions>
<RunParams>
<local>
<CommandLineParams Value="--suite=TTestStatementParser.TestCaseIfElseNoSemicolon"/>
<CommandLineParams Value="--suite=TTestScanner.TestObjCClass2"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="--suite=TTestStatementParser.TestCaseIfElseNoSemicolon"/>
<CommandLineParams Value="--suite=TTestScanner.TestObjCClass2"/>
</local>
</Mode0>
</Modes>