* ObjCCategory

git-svn-id: trunk@45514 -

packages/fcl-passrc/src/pastree.pp

@@ -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

packages/fcl-passrc/src/pparser.pp

@@ -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

packages/fcl-passrc/src/pscanner.pp

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

packages/fcl-passrc/tests/tcclasstype.pas

@@ -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);

packages/fcl-passrc/tests/tcscanner.pas

@@ -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;
 

packages/fcl-passrc/tests/testpassrc.lpi

@@ -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>