* Start ObjCClass support

git-svn-id: trunk@45507 -

packages/fcl-passrc/src/pastree.pp

@@ -796,6 +796,7 @@ type
     IsForward: Boolean;
     IsExternal : Boolean;
     IsShortDefinition: Boolean;//class(anchestor); without end
+    IsObjCClass : Boolean;
     GUIDExpr : TPasExpr;
     Modifiers: TStringList;
     Interfaces : TFPList; // list of TPasType

packages/fcl-passrc/src/pparser.pp

@@ -1463,7 +1463,7 @@ begin
   if (Result<>pmNone) then
      begin
      NextToken;
-     if Not (CurToken in [tkArray, tkRecord, tkObject, tkClass, tkSet]) then
+     if Not (CurToken in [tkArray, tkRecord, tkObject, tkClass, tkObjCClass, tkSet]) then
        ParseExcTokenError('SET, ARRAY, RECORD, OBJECT or CLASS');
      end;
 end;
@@ -1873,12 +1873,12 @@ function TPasParser.ParseType(Parent: TPasElement;
 
 Const
   // These types are allowed only when full type declarations
-  FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkInterface,tkDispInterface,tkType];
+  FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkObjCClass,tkInterface,tkObjcProtocol,tkDispInterface,tkType];
   // Parsing of these types already takes care of hints
   NoHintTokens = [tkProcedure,tkFunction];
 var
   PM: TPackMode;
-  CH, isHelper, ok: Boolean;
+  CH, isHelper, isObjCClass, ok: Boolean;
 begin
   Result := nil;
   // NextToken and check pack mode
@@ -1898,13 +1898,20 @@ begin
       tkObject: Result := ParseClassDecl(Parent, NamePos, TypeName, okObject,PM);
       tkDispInterface:
         Result := ParseClassDecl(Parent, NamePos, TypeName, okDispInterface,PM);
+      tkObjcProtocol,
       tkInterface:
+        begin
+        isObjCClass:=(CurToken=tkObjcProtocol);
         Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface,PM);
+        TPasClassType(Result).IsObjCClass:=isObjCClass;
+        end;
       tkSpecialize:
         Result:=ParseSimpleType(Parent,CurSourcePos,TypeName);
+      tkObjCClass,
       tkClass:
         begin
         isHelper:=false;
+        isObjCClass:=(CurToken=tkObjCClass);
         NextToken;
         if CurTokenIsIdentifier('Helper') then
           begin
@@ -1918,7 +1925,10 @@ begin
         if isHelper then
           Result:=ParseClassDecl(Parent,NamePos,TypeName,okClassHelper, PM)
         else
+          begin
           Result:=ParseClassDecl(Parent, NamePos, TypeName, okClass, PM);
+          TPasClassType(Result).isObjCClass:=isObjCClass;
+          end;
         end;
       tkType:
         begin
@@ -6815,7 +6825,7 @@ begin
         end;
       tkDestructor:
         ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
-      tkGeneric,tkSelf, // Counts as field name
+      tkabsolute,tkGeneric,tkSelf, // Counts as field name
       tkIdentifier :
         begin
         If AllowVisibility and CheckVisibility(CurTokenString,v) then

packages/fcl-passrc/src/pscanner.pp

@@ -220,6 +220,8 @@ type
     tkmod,
     tknil,
     tknot,
+    tkobjcclass,
+    tkobjcprotocol,
     tkobject,
     tkof,
     tkoperator,
@@ -1004,6 +1006,8 @@ const
     'mod',
     'nil',
     'not',
+    'objcclass',
+    'objcprotocol',
     'object',
     'of',
     'operator',
@@ -3651,24 +3655,34 @@ begin
   P:=Trim(UpperCase(Param));
   Case P of
   'FPC','DEFAULT':
+    begin
     SetMode(msFpc,FPCModeSwitches,false,bsFPCMode);
+    SetNonToken(tkobjcclass);
+    SetNonToken(tkobjcprotocol);
+    end;
   'OBJFPC':
     begin
     SetMode(msObjfpc,OBJFPCModeSwitches,true,bsObjFPCMode);
     UnsetNonToken(tkgeneric);
     UnsetNonToken(tkspecialize);
+    SetNonToken(tkobjcclass);
+    SetNonToken(tkobjcprotocol);
     end;
   'DELPHI':
     begin
     SetMode(msDelphi,DelphiModeSwitches,true,bsDelphiMode,[bsPointerMath]);
     SetNonToken(tkgeneric);
     SetNonToken(tkspecialize);
+    SetNonToken(tkobjcclass);
+    SetNonToken(tkobjcprotocol);
     end;
   'DELPHIUNICODE':
     begin
     SetMode(msDelphiUnicode,DelphiUnicodeModeSwitches,true,bsDelphiUnicodeMode,[bsPointerMath]);
     SetNonToken(tkgeneric);
     SetNonToken(tkspecialize);
+    SetNonToken(tkobjcclass);
+    SetNonToken(tkobjcprotocol);
     end;
   'TP':
     SetMode(msTP7,TPModeSwitches,false);
@@ -4893,6 +4907,16 @@ begin
     UnDefine(LetterSwitchNames['H'],true);
     Exclude(FCurrentBoolSwitches,bsLongStrings);
     end;
+  if ([msObjectiveC1,msObjectiveC2] * FCurrentModeSwitches) = [] then
+    begin
+    SetNonToken(tkobjcclass);
+    SetNonToken(tkobjcprotocol);
+    end
+  else
+    begin
+    UnSetNonToken(tkobjcclass);
+    UnSetNonToken(tkobjcprotocol);
+    end
 end;
 
 procedure TPascalScanner.SetCurrentValueSwitch(V: TValueSwitch;

packages/fcl-passrc/tests/tcclasstype.pas

@@ -5,7 +5,7 @@ unit tcclasstype;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, pscanner,pparser, pastree, testregistry, tctypeparser;
+  Classes, SysUtils, fpcunit, pscanner, pparser, pastree, testregistry, tctypeparser;
 
 type
 
@@ -30,10 +30,10 @@ type
     function GetP2: TPasProperty;
     function GetT(AIndex : Integer) : TPasType;
   protected
-    Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = '');
+    Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = ''; UseObjcClass : Boolean = False);
     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);
+    Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False);
     Procedure StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
     Procedure StartVisibility(A : TPasMemberVisibility);
     Procedure EndClass(AEnd : String = 'end');
@@ -69,6 +69,7 @@ type
     procedure TestEmptyDeprecated;
     procedure TestEmptyEnd;
     procedure TestEmptyEndNoParent;
+    procedure TestEmptyObjC;
     Procedure TestOneInterface;
     Procedure TestTwoInterfaces;
     procedure TestOneSpecializedClass;
@@ -167,6 +168,7 @@ type
     procedure TestClassHelperParentedEmpty;
     procedure TestClassHelperOneMethod;
     procedure TestInterfaceEmpty;
+    procedure TestObjcProtocolEmpty;
     procedure TestInterfaceDisp;
     procedure TestInterfaceParentedEmpty;
     procedure TestInterfaceOneMethod;
@@ -252,7 +254,7 @@ begin
   Result:=TPasConst(Members[AIndex]);
 end;
 
-procedure TTestClassType.StartClass(AncestorName: String; InterfaceList: String);
+procedure TTestClassType.StartClass(AncestorName: String; InterfaceList: String = ''; UseObjcClass: Boolean = false);
 
 Var
   S : String;
@@ -260,7 +262,13 @@ begin
   if FStarted then
     Fail('TTestClassType.StartClass already started');
   FStarted:=True;
-  S:='TMyClass = Class';
+  if UseObjcClass then
+    begin
+    FDecl.Add('{$modeswitch objectivec1}');
+    S:='TMyClass = ObjCClass';
+    end
+  else
+    S:='TMyClass = Class';
   if (AncestorName<>'') then
     begin
     S:=S+'('+AncestorName;
@@ -304,12 +312,17 @@ begin
 end;
 
 procedure TTestClassType.StartInterface(AParent: String; UUID: String;
-  Disp: Boolean = False);
+  Disp: Boolean = False; UseObjcClass : Boolean = False);
 Var
   S : String;
 begin
   FStarted:=True;
-  if Disp then
+  if UseObjCClass then
+    begin
+    FDecl.Add('{$modeswitch objectivec1}');
+    S:='TMyClass = objcprotocol'
+    end
+  else if Disp then
     S:='TMyClass = DispInterface'
   else
     S:='TMyClass = Interface';
@@ -518,6 +531,14 @@ begin
   AssertEquals('No members',0,TheClass.Members.Count);
 end;
 
+procedure TTestClassType.TestEmptyObjC;
+begin
+  StartClass('','',True);
+  ParseClass;
+  AssertEquals('No members',0,TheClass.Members.Count);
+  AssertTrue('Is objectivec',TheClass.IsObjCClass);
+end;
+
 procedure TTestClassType.TestOneInterface;
 begin
   StartClass('TObject','ISomething');
@@ -1880,6 +1901,17 @@ begin
   AssertNull('No UUID',TheClass.GUIDExpr);
 end;
 
+procedure TTestClassType.TestObjcProtocolEmpty;
+begin
+  StartInterface('','',False,True);
+  EndClass();
+  ParseClass;
+  AssertEquals('Is interface',okInterface,TheClass.ObjKind);
+  AssertTrue('Is objectivec',TheClass.IsObjCClass);
+  AssertEquals('No members',0,TheClass.Members.Count);
+  AssertNull('No UUID',TheClass.GUIDExpr);
+end;
+
 procedure TTestClassType.TestInterfaceDisp;
 
 begin

packages/fcl-passrc/tests/tcscanner.pas

@@ -197,6 +197,10 @@ type
     procedure TestWith;
     procedure TestXor;
     procedure TestLineEnding;
+    procedure TestObjCClass;
+    procedure TestObjCClass2;
+    procedure TestObjCProtocol;
+    procedure TestObjCProtocol2;
     procedure TestTab;
     Procedure TestEscapedKeyWord;
     Procedure TestTokenSeries;
@@ -1358,6 +1362,26 @@ begin
   TestToken(tkLineEnding,#10);
 end;
 
+procedure TTestScanner.TestObjCClass;
+begin
+  TestToken(tkObjCClass,'objcclass');
+end;
+
+procedure TTestScanner.TestObjCClass2;
+begin
+  TestTokens([tkComment,tkWhitespace,tkidentifier],'{$mode fpc} objcclass');
+end;
+
+procedure TTestScanner.TestObjCProtocol;
+begin
+  TestToken(tkObjCProtocol,'objcprotocol');
+end;
+
+procedure TTestScanner.TestObjCProtocol2;
+begin
+  TestTokens([tkComment,tkWhitespace,tkidentifier],'{$mode fpc} objcprotocol');
+end;
+
 
 procedure TTestScanner.TestTab;