* Fix support for external classes, initial implementation of external properties

git-svn-id: trunk@35636 -

packages/fcl-passrc/src/pasresolver.pp

@@ -68,6 +68,7 @@ Works:
   - property with params
   - default property
   - visibility
+  - sealed
 - with..do
 - enums - TPasEnumType, TPasEnumValue
   - propagate to parent scopes
@@ -226,6 +227,7 @@ const
   nCantAccessPrivateMember = 3045;
   nMustBeInsideALoop = 3046;
   nExpectXArrayElementsButFoundY = 3047;
+  nCannotCreateADescendantOfTheSealedClass = 3048;
 
 // resourcestring patterns of messages
 resourcestring
@@ -276,6 +278,7 @@ resourcestring
   sCantAccessPrivateMember = 'Can''t access %s member %s';
   sMustBeInsideALoop = '%s must be inside a loop';
   sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s';
+  sCannotCreateADescendantOfTheSealedClass = 'Cannot create a decscendant of the sealed class "%s"';
 
 type
   TResolverBaseType = (
@@ -622,14 +625,20 @@ type
   TPasRecordScope = Class(TPasIdentifierScope)
   end;
 
+  TPasClassScopeFlag = (
+    pcsfAncestorResolved,
+    pcsfSealed
+    );
+  TPasClassScopeFlags = set of TPasClassScopeFlag;
+
   { TPasClassScope }
 
   TPasClassScope = Class(TPasIdentifierScope)
   public
-    AncestorResolved: boolean;
     AncestorScope: TPasClassScope;
     DirectAncestor: TPasType; // TPasClassType or TPasAliasType or TPasTypeAliasType
     DefaultProperty: TPasProperty;
+    Flags: TPasClassScopeFlags;
     function FindIdentifier(const Identifier: String): TPasIdentifier; override;
     procedure IterateElements(const aName: string; StartScope: TPasScope;
       const OnIterateElement: TIterateScopeElement; Data: Pointer;
@@ -3657,20 +3666,30 @@ procedure TPasResolver.FinishAncestors(aClass: TPasClassType);
 // before parsing the class elements
 var
   AncestorEl: TPasClassType;
-  ClassScope: TPasClassScope;
+  ClassScope, AncestorClassScope: TPasClassScope;
   DirectAncestor, AncestorType, El: TPasType;
+  i: Integer;
+  aModifier: String;
+  IsSealed: Boolean;
 begin
   if aClass.IsForward then
     exit;
   if aClass.ObjKind<>okClass then
     RaiseNotYetImplemented(20161010174638,aClass,ObjKindNames[aClass.ObjKind]);
 
+  IsSealed:=false;
+  for i:=0 to aClass.Modifiers.Count-1 do
+    begin
+    aModifier:=lowercase(aClass.Modifiers[i]);
+    case aModifier of
+    'sealed': IsSealed:=true;
+    else
+      RaiseMsg(20170320190619,nIllegalQualifier,sIllegalQualifier,[aClass.Modifiers[i]],aClass);
+    end;
+    end;
+
   DirectAncestor:=aClass.AncestorType;
-  AncestorType:=DirectAncestor;
-  while (AncestorType<>nil)
-      and ((AncestorType.ClassType=TPasAliasType) or (AncestorType.ClassType=TPasTypeAliasType))
-  do
-    AncestorType:=TPasAliasType(AncestorType).DestType;
+  AncestorType:=ResolveAliasType(DirectAncestor);
 
   if AncestorType=nil then
     begin
@@ -3691,6 +3710,8 @@ begin
     RaiseXExpectedButYFound(20170216151944,'class type',GetTypeDesc(AncestorType),aClass)
   else
     AncestorEl:=TPasClassType(AncestorType);
+
+  AncestorClassScope:=nil;
   if AncestorEl=nil then
     begin
     // root class TObject
@@ -3701,6 +3722,10 @@ begin
     if AncestorEl.IsForward then
       RaiseMsg(20170216151947,nCantUseForwardDeclarationAsAncestor,
         sCantUseForwardDeclarationAsAncestor,[AncestorEl.Name],aClass);
+    AncestorClassScope:=AncestorEl.CustomData as TPasClassScope;
+    if pcsfSealed in AncestorClassScope.Flags then
+      RaiseMsg(20170320191735,nCannotCreateADescendantOfTheSealedClass,
+        sCannotCreateADescendantOfTheSealedClass,[AncestorEl.Name],aClass);
     El:=AncestorEl;
     repeat
       if El=aClass then
@@ -3721,7 +3746,9 @@ begin
   PushScope(aClass,TPasClassScope);
   ClassScope:=TPasClassScope(TopScope);
   ClassScope.VisibilityContext:=aClass;
-  ClassScope.AncestorResolved:=true;
+  Include(ClassScope.Flags,pcsfAncestorResolved);
+  if IsSealed then
+    Include(ClassScope.Flags,pcsfSealed);
   ClassScope.DirectAncestor:=DirectAncestor;
   if AncestorEl<>nil then
     begin
@@ -9416,7 +9443,7 @@ begin
   else
     begin
     ClassScope:=ClassEl.CustomData as TPasClassScope;
-    if not ClassScope.AncestorResolved then
+    if not (pcsfAncestorResolved in ClassScope.Flags) then
       exit;
     if SkipAlias then
       begin
@@ -9445,7 +9472,8 @@ end;
 function TPasResolver.ResolveAliasType(aType: TPasType): TPasType;
 begin
   Result:=aType;
-  while Result is TPasAliasType do
+  while (Result<>nil)
+      and ((Result.ClassType=TPasAliasType) or (Result.ClassType=TPasTypeAliasType)) do
     Result:=TPasAliasType(Result).DestType;
 end;
 

packages/fcl-passrc/src/pastree.pp

@@ -620,6 +620,9 @@ type
     Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function IsPacked : Boolean;
     Function InterfaceGUID : string;
+    Function IsSealed : Boolean;
+    Function IsAbstract : Boolean;
+    Function HasModifier(const aModifier: String): Boolean;
   end;
 
 
@@ -2403,6 +2406,26 @@ begin
     Result:=''
 end;
 
+function TPasClassType.IsSealed: Boolean;
+begin
+  Result:=HasModifier('sealed');
+end;
+
+function TPasClassType.IsAbstract: Boolean;
+begin
+  Result:=HasModifier('abstract');
+end;
+
+function TPasClassType.HasModifier(const aModifier: String): Boolean;
+var
+  i: Integer;
+begin
+  for i:=0 to Modifiers.Count-1 do
+    if CompareText(aModifier,Modifiers[i])=0 then
+      exit(true);
+  Result:=false;
+end;
+
 function TPasClassType.IsPacked: Boolean;
 begin
   Result:=PackMode<>pmNone;

packages/fcl-passrc/src/pparser.pp

@@ -3139,6 +3139,31 @@ begin
       begin
       NextToken;
       VarMods:=[];
+      Mods:='';
+      {$IFDEF EnablePas2JSExternal}
+      if Parent.ClassType=TPasClassType then
+        begin
+        if CurToken=tkSemicolon then
+          begin
+          NextToken;
+          if (CurToken=tkIdentifier) and (CurTokenIsIdentifier('external')) then
+            begin
+            Include(VarMods,vmExternal);
+            Mods:=CurTokenText;
+            NextToken;
+            if not CurTokenIsIdentifier('name') then
+              ParseExcTokenError('name');
+            NextToken;
+            if not (CurToken in [tkString,tkIdentifier]) then
+              ParseExcTokenError(TokenInfos[tkString]);
+            Mods := Mods + ' ' + CurTokenText;
+            aExpName:=DoParseExpression(Parent);
+            end
+          else
+            UngetToken;
+          end;
+        end;
+      {$ENDIF}
       end;
     SaveComments(D);
 
@@ -5039,7 +5064,9 @@ begin
         SaveComments;
         ExpectIdentifier;
         AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility,false));
-        end;
+        end
+    else
+      CheckToken(tkIdentifier);
     end;
     NextToken;
     end;
@@ -5152,9 +5179,15 @@ begin
     AExternalNameSpace:=CurTokenString;
     ExpectIdentifier;
     If Not CurTokenIsIdentifier('Name')  then
-       ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName);
+      ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName);
     ExpectToken(tkString);
     AExternalName:=CurTokenString;
+    NextToken;
+    end
+  else
+    begin
+    AExternalNameSpace:='';
+    AExternalName:='';
     end;
   if (CurTokenIsIdentifier('Helper')) then
     begin
@@ -5162,7 +5195,7 @@ begin
       ParseExc(nParserHelperNotAllowed,SParserHelperNotAllowed,[ObjKindNames[AObjKind]]);
     Case AObjKind of
      okClass:
-        AObjKind:=okClassHelper;
+       AObjKind:=okClassHelper;
      okTypeHelper:
        begin
        ExpectToken(tkFor);
@@ -5176,8 +5209,10 @@ begin
   Result:=PCT;
   PCT.HelperForType:=FT;
   PCT.IsExternal:=(AExternalName<>'');
-  PCT.ExternalName:=AnsiDequotedStr(AExternalName,'''');
-  PCT.ExternalNameSpace:=AnsiDequotedStr(AExternalNameSpace,'''');
+  if AExternalName<>'' then
+    PCT.ExternalName:=AnsiDequotedStr(AExternalName,'''');
+  if AExternalNameSpace<>'' then
+    PCT.ExternalNameSpace:=AnsiDequotedStr(AExternalNameSpace,'''');
   ok:=false;
   try
     PCT.ObjKind := AObjKind;

packages/fcl-passrc/tests/tcclasstype.pas

@@ -1162,7 +1162,7 @@ end;
 procedure TTestClassType.TestPropertyRedeclareDefault;
 begin
   StartVisibility(visPublic);
-  AddMember('Property Something; default;');
+  AddMember('Property Something; default');
   ParseClass;
   AssertProperty(Property1,visPublic,'Something','','','','',0,True,False);
   AssertNull('No type',Property1.VarType);

packages/fcl-passrc/tests/tcresolver.pas

@@ -341,6 +341,10 @@ type
     Procedure TestClass_ReintroducePrivateVar;
     Procedure TestClass_ReintroduceProc;
     Procedure TestClass_UntypedParam_TypeCast;
+    Procedure TestClass_Sealed;
+    Procedure TestClass_SealedDescendFail;
+    Procedure TestClass_VarExternal;
+    Procedure TestClass_External;
     // Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
 
     // class of
@@ -1176,7 +1180,7 @@ begin
   for i:=0 to Resolver.Streams.Count-1 do
     begin
     GetSrc(i,SrcLines,SrcFilename);
-    IsSrc:=ExtractFilename(aFilename)=ExtractFileName(aFilename);
+    IsSrc:=ExtractFilename(SrcFilename)=ExtractFileName(aFilename);
     writeln('Testcode:-File="',SrcFilename,'"----------------------------------:');
     for j:=1 to SrcLines.Count do
       begin
@@ -5322,6 +5326,53 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_Sealed;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class sealed');
+  Add('  end;');
+  Add('begin');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClass_SealedDescendFail;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class sealed');
+  Add('  end;');
+  Add('  TNop = class(TObject)');
+  Add('  end;');
+  Add('begin');
+  CheckResolverException('Cannot create a decscendant of the sealed class "TObject"',
+    nCannotCreateADescendantOfTheSealedClass);
+end;
+
+procedure TTestResolver.TestClass_VarExternal;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class');
+  Add('    Id: longint; external name ''$Id'';');
+  Add('    Data: longint; external name ''$Data'';');
+  Add('  end;');
+  Add('begin');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClass_External;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('{$modeswitch externalclass}');
+  Add('  TObject = class external ''namespace'' name ''symbol''');
+  Add('    Id: longint;');
+  Add('  end;');
+  Add('begin');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClassOf;
 begin
   StartProgram(false);