* Added support for external classes

git-svn-id: trunk@35635 -

packages/fcl-passrc/src/pastree.pp

@@ -606,12 +606,15 @@ type
     AncestorType: TPasType;     // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
     HelperForType: TPasType;     // TPasClassType or TPasUnresolvedTypeRef
     IsForward: Boolean;
+    IsExternal : Boolean;
     IsShortDefinition: Boolean;//class(anchestor); without end
     GUIDExpr : TPasExpr;
     Members: TFPList;     // list of TPasElement
     Modifiers: TStringList;
     Interfaces : TFPList; // list of TPasElement
     GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
+    ExternalNameSpace : String;
+    ExternalName : String;
     Procedure SetGenericTemplates(AList : TFPList);
     Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;

packages/fcl-passrc/src/pparser.pp

@@ -75,6 +75,7 @@ const
   nParserOnlyOneVariableCanBeInitialized = 2048;
   nParserExpectedTypeButGot = 2049;
   nParserPropertyArgumentsCanNotHaveDefaultValues = 2050;
+  nParserExpectedExternalClassName = 2051;
 
 // resourcestring patterns of messages
 resourcestring
@@ -128,6 +129,7 @@ resourcestring
   SParserOnlyOneVariableCanBeInitialized = 'Only one variable can be initialized';
   SParserExpectedTypeButGot = 'Expected type, but got %s';
   SParserPropertyArgumentsCanNotHaveDefaultValues = 'Property arguments can not have default values';
+  SParserExpectedExternalClassName = 'Expected external class name';
 
 type
   TPasScopeType = (
@@ -5129,7 +5131,8 @@ function TPasParser.ParseClassDecl(Parent: TPasElement;
 Var
   ok: Boolean;
   FT : TPasType;
-
+  AExternalNameSpace,AExternalName : String;
+  PCT:TPasClassType;
 begin
   NextToken;
   FT:=Nil;
@@ -5143,6 +5146,16 @@ begin
     Engine.FinishScope(stTypeDef,Result);
     exit;
     end;
+  if ((AobjKind in [okClass,OKInterface]) and (msExternalClass in CurrentModeswitches) and  CurTokenIsIdentifier('external')) then
+    begin
+    ExpectToken(tkString);
+    AExternalNameSpace:=CurTokenString;
+    ExpectIdentifier;
+    If Not CurTokenIsIdentifier('Name')  then
+       ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName);
+    ExpectToken(tkString);
+    AExternalName:=CurTokenString;
+    end;
   if (CurTokenIsIdentifier('Helper')) then
     begin
     if Not (AObjKind in [okClass,okTypeHelper,okRecordHelper]) then
@@ -5158,16 +5171,20 @@ begin
     end;
     NextToken;
     end;
-  Result := TPasClassType(CreateElement(TPasClassType, AClassName,
+  PCT := TPasClassType(CreateElement(TPasClassType, AClassName,
     Parent, NamePos));
-  TPasClassType(Result).HelperForType:=FT;
+  Result:=PCT;
+  PCT.HelperForType:=FT;
+  PCT.IsExternal:=(AExternalName<>'');
+  PCT.ExternalName:=AnsiDequotedStr(AExternalName,'''');
+  PCT.ExternalNameSpace:=AnsiDequotedStr(AExternalNameSpace,'''');
   ok:=false;
   try
-    TPasClassType(Result).ObjKind := AObjKind;
-    TPasClassType(Result).PackMode:=PackMode;
+    PCT.ObjKind := AObjKind;
+    PCT.PackMode:=PackMode;
     if Assigned(GenericArgs) then
-      TPasClassType(Result).SetGenericTemplates(GenericArgs);
-    DoParseClassType(TPasClassType(Result));
+      PCT.SetGenericTemplates(GenericArgs);
+    DoParseClassType(PCT);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;
   finally

packages/fcl-passrc/src/pscanner.pp

@@ -237,7 +237,8 @@ type
     msBlocks,              { support for http://en.wikipedia.org/wiki/Blocks_(C_language_extension) }
     msISOLikeIO,           { I/O as it required by an ISO compatible compiler }
     msISOLikeProgramsPara, { program parameters as it required by an ISO compatible compiler }
-    msISOLikeMod           { mod operation as it is required by an iso compatible compiler }
+    msISOLikeMod,          { mod operation as it is required by an iso compatible compiler }
+    msExternalClass        { Allow external class definitions }
   );
   TModeSwitches = Set of TModeSwitch;
 
@@ -659,7 +660,8 @@ const
     'CBLOCKS',
     'ISOIO',
     'ISOPROGRAMPARAS',
-    'ISOMOD'
+    'ISOMOD',
+    'EXTERNALCLASS'
     );
 
 const

packages/fcl-passrc/tests/tcclasstype.pas

@@ -5,7 +5,7 @@ unit tcclasstype;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, pparser, pastree, testregistry, tctypeparser;
+  Classes, SysUtils, fpcunit, pscanner,pparser, pastree, testregistry, tctypeparser;
 
 type
 
@@ -30,6 +30,7 @@ type
     function GetT(AIndex : Integer) : TPasType;
   protected
     Procedure StartClass (AParent : String = 'TObject'; InterfaceList : String = '');
+    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 StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
@@ -141,6 +142,10 @@ type
     Procedure TestPropertyReadFromRecordField;
     procedure TestPropertyReadFromArrayField;
     procedure TestPropertyReadWriteFromRecordField;
+    Procedure TestExternalClass;
+    Procedure TestExternalClassNoNameSpace;
+    Procedure TestExternalClassNoNameKeyWord;
+    Procedure TestExternalClassNoName;
     Procedure TestLocalSimpleType;
     Procedure TestLocalSimpleTypes;
     Procedure TestLocalSimpleConst;
@@ -252,6 +257,21 @@ begin
   FParent:=AParent;
 end;
 
+procedure TTestClassType.StartExternalClass(AParent: String; AExternalName,
+  AExternalNameSpace: String);
+
+Var
+  S : String;
+
+begin
+  FStarted:=True;
+  S:=Format('TMyClass = Class external ''%s'' name ''%s'' ',[AExternalNameSpace,AExternalName]);
+  if (AParent<>'') then
+    S:=S+'('+AParent+')';
+  FDecl.Add(S);
+  FParent:=AParent;
+end;
+
 procedure TTestClassType.StartClassHelper(ForType: String; AParent: String);
 Var
   S : String;
@@ -1494,6 +1514,42 @@ begin
   Assertequals('Default value','',Property1.DefaultValue);
 end;
 
+procedure TTestClassType.TestExternalClass;
+begin
+  StartExternalClass('','myname','mynamespace');
+  Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
+  ParseClass;
+  AssertTrue('External class ',TheClass.IsExternal);
+  AssertEquals('External name space','mynamespace',TheClass.ExternalNameSpace);
+  AssertEquals('External name ','myname',TheClass.ExternalName);
+end;
+
+procedure TTestClassType.TestExternalClassNoNameSpace;
+begin
+  FStarted:=True;
+  Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
+  FDecl.add('TMyClass = Class external name ''me'' ');
+  AssertException('No namespace raises error',EParserError,@ParseClass);
+end;
+
+procedure TTestClassType.TestExternalClassNoNameKeyWord;
+begin
+  FStarted:=True;
+  Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
+  FDecl.add('TMyClass = Class external ''name'' ''me'' ');
+  AssertException('No name keyword raises error',EParserError,@ParseClass);
+
+end;
+
+procedure TTestClassType.TestExternalClassNoName;
+begin
+  FStarted:=True;
+  Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
+  FDecl.add('TMyClass = Class external ''name'' name ');
+  AssertException('No name  raises error',EParserError,@ParseClass);
+
+end;
+
 procedure TTestClassType.TestLocalSimpleType;
 begin
   StartVisibility(visPublic);

packages/fcl-passrc/tests/testpassrc.lpi

@@ -27,7 +27,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestScanner.TestSelf"/>
+        <CommandLineParams Value="--suite=TTestGenerics.TestInlineSpecializationInProcedure"/>
       </local>
     </RunParams>
     <RequiredPackages Count="1">