diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 508609bb2c..037e35ab0f 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/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; diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index dd3e4bbb77..760ba81bf3 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 5c55a4cabc..47cbf84147 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/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; diff --git a/packages/fcl-passrc/tests/tcclasstype.pas b/packages/fcl-passrc/tests/tcclasstype.pas index 5000f27d71..daffbab131 100644 --- a/packages/fcl-passrc/tests/tcclasstype.pas +++ b/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); diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index b3a0a5d928..6a12b886ef 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/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);