diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index db1a5d70f6..0e76b989b6 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -1041,19 +1041,28 @@ type procedure WriteIdentifiers(Prefix: string); override; end; - { TPasDotRecordScope - used for aRecord.subidentifier } - - TPasDotRecordScope = Class(TPasDotIdentifierScope) - end; - { TPasDotEnumTypeScope - used for EnumType.EnumValue } TPasDotEnumTypeScope = Class(TPasDotIdentifierScope) end; + { TPasDotClassOrRecordScope } + + TPasDotClassOrRecordScope = Class(TPasDotIdentifierScope) + end; + + { TPasDotRecordScope - used for aRecord.subidentifier } + + TPasDotRecordScope = Class(TPasDotClassOrRecordScope) + private + function GetRecordScope: TPasRecordScope; + public + property RecordScope: TPasRecordScope read GetRecordScope; + end; + { TPasDotClassScope - used for aClass.subidentifier } - TPasDotClassScope = Class(TPasDotIdentifierScope) + TPasDotClassScope = Class(TPasDotClassOrRecordScope) private FClassScope: TPasClassScope; procedure SetClassScope(AValue: TPasClassScope); @@ -1418,7 +1427,8 @@ type procedure FinishUsesClause; virtual; procedure FinishSection(Section: TPasSection); virtual; procedure FinishInterfaceSection(Section: TPasSection); virtual; - procedure FinishTypeSection(El: TPasDeclarations); virtual; + procedure FinishTypeSection(El: TPasElement); virtual; + procedure FinishTypeSectionEl(El: TPasType); virtual; procedure FinishTypeDef(El: TPasType); virtual; procedure FinishEnumType(El: TPasEnumType); virtual; procedure FinishSetType(El: TPasSetType); virtual; @@ -3107,6 +3117,13 @@ begin AncestorScope.WriteIdentifiers(Prefix+'AS '); end; +{ TPasDotRecordScope } + +function TPasDotRecordScope.GetRecordScope: TPasRecordScope; +begin + Result:=TPasRecordScope(IdentifierScope); +end; + { TPasDotClassScope } procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope); @@ -4794,7 +4811,35 @@ begin if Section=nil then ; end; -procedure TPasResolver.FinishTypeSection(El: TPasDeclarations); +procedure TPasResolver.FinishTypeSection(El: TPasElement); +var + i: Integer; + Decl: TPasElement; +begin + // resolve pending forwards + if El is TPasDeclarations then + begin + for i:=0 to TPasDeclarations(El).Declarations.Count-1 do + begin + Decl:=TPasElement(TPasDeclarations(El).Declarations[i]); + if Decl is TPasType then + FinishTypeSectionEl(TPasType(Decl)); + end; + end + else if El is TPasMembersType then + begin + for i:=0 to TPasMembersType(El).Members.Count-1 do + begin + Decl:=TPasElement(TPasMembersType(El).Members[i]); + if Decl is TPasType then + FinishTypeSectionEl(TPasType(Decl)); + end; + end + else + RaiseNotYetImplemented(20181226105933,El); +end; + +procedure TPasResolver.FinishTypeSectionEl(El: TPasType); function ReplaceDestType(Decl: TPasType; var DestType: TPasType; const DestName: string; MustExist: boolean; ErrorEl: TPasElement @@ -4839,81 +4884,74 @@ procedure TPasResolver.FinishTypeSection(El: TPasDeclarations); end; var - i: Integer; - Decl: TPasElement; + C: TClass; ClassOfEl: TPasClassOfType; + TypeEl: TPasType; UnresolvedEl: TUnresolvedPendingRef; OldClassType: TPasClassType; - TypeEl: TPasType; - C: TClass; PtrType: TPasPointerType; begin - // resolve pending forwards - for i:=0 to El.Declarations.Count-1 do + C:=El.ClassType; + if C.InheritsFrom(TPasClassType) then begin - Decl:=TPasElement(El.Declarations[i]); - C:=Decl.ClassType; - if C.InheritsFrom(TPasClassType) then + if TPasClassType(El).IsForward and (TPasClassType(El).CustomData=nil) then + RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El); + end + else if (C=TPasClassOfType) then + begin + ClassOfEl:=TPasClassOfType(El); + TypeEl:=ResolveAliasType(ClassOfEl.DestType); + if (TypeEl.ClassType=TUnresolvedPendingRef) then begin - if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then - RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl); + // forward class-of -> resolve now + UnresolvedEl:=TUnresolvedPendingRef(TypeEl); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"'); + {$ENDIF} + ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl + {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); end - else if (C=TPasClassOfType) then + else if TypeEl.ClassType=TPasClassType then begin - ClassOfEl:=TPasClassOfType(Decl); - TypeEl:=ResolveAliasType(ClassOfEl.DestType); - if (TypeEl.ClassType=TUnresolvedPendingRef) then - begin - // forward class-of -> resolve now - UnresolvedEl:=TUnresolvedPendingRef(TypeEl); - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"'); - {$ENDIF} - ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl - {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); - end - else if TypeEl.ClassType=TPasClassType then - begin - // class-of has found a type - // another later in the same type section has priority -> check - OldClassType:=TypeEl as TPasClassType; - if OldClassType.Parent=ClassOfEl.Parent then - continue; // class in same type section -> ok - // class not in same type section -> check - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"'); - {$ENDIF} - ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl - {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); - end; + // class-of has found a type + // another later in the same type section has priority -> check + OldClassType:=TypeEl as TPasClassType; + if OldClassType.Parent=ClassOfEl.Parent then + exit; // class in same type section -> ok + // class not in same type section -> check + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"'); + {$ENDIF} + ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl + {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); + end; + end + else if C=TPasPointerType then + begin + PtrType:=TPasPointerType(El); + TypeEl:=ResolveAliasType(PtrType.DestType); + if (TypeEl.ClassType=TUnresolvedPendingRef) then + begin + // forward pointer -> resolve now + UnresolvedEl:=TUnresolvedPendingRef(TypeEl); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"'); + {$ENDIF} + ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl + {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF}); end - else if C=TPasPointerType then + else begin - PtrType:=TPasPointerType(Decl); - TypeEl:=ResolveAliasType(PtrType.DestType); - if (TypeEl.ClassType=TUnresolvedPendingRef) then - begin - // forward pointer -> resolve now - UnresolvedEl:=TUnresolvedPendingRef(TypeEl); - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"'); - {$ENDIF} - ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl - {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF}); - end - else - begin - // pointer-of has found a type - // another later in the same type section has priority -> check - if TypeEl.Parent=Decl.Parent then - continue; // class in same type section -> ok - // dest not in same type section -> check - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"'); - {$ENDIF} - ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType - {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF}); - end; + // pointer-of has found a type + // another later in the same type section has priority -> check + if TypeEl.Parent=PtrType.Parent then + exit; // class in same type section -> ok + // dest not in same type section -> check + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"'); + {$ENDIF} + ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType + {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF}); end; end; end; @@ -5782,8 +5820,11 @@ begin SelfArg:=TPasArgument.Create('Self',DeclProc); ImplProcScope.SelfArg:=SelfArg; {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} - SelfArg.Access:=argConst; SelfArg.ArgType:=ClassRecType; + if ClassRecType is TPasRecordType then + SelfArg.Access:=argDefault + else + SelfArg.Access:=argConst; ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); end; @@ -14761,6 +14802,25 @@ procedure TPasResolver.CheckFoundElement( const FindData: TPRFindData; Ref: TResolvedReference); // check visibility rules // Call this method after finding an element by searching the scopes. + + function IsFieldInheritingConst(aRef: TResolvedReference): boolean; + // returns true of aRef is a TPasVariable that inherits its const from parent. + // For example + // type TRecord = record + // a: word; // inherits const + // const b: word = 3; // does not inherit const + // class var c: word; // does not inherit const + // end; + // procedure DoIt(const r:TRecord) + var + El: TPasElement; + begin + El:=aRef.Declaration; + Result:=(El.ClassType=TPasVariable) + and (TPasVariable(El).VarModifiers*[vmClass, vmStatic]=[]); + //writeln('IsFieldInheritingConst ',GetObjName(El),' ',Result,' vmClass=',vmClass in TPasVariable(El).VarModifiers); + end; + var Proc: TPasProcedure; Context: TPasElement; @@ -14784,7 +14844,8 @@ begin if Ref<>nil then begin Include(Ref.Flags,rrfDotScope); - if TPasDotIdentifierScope(StartScope).ConstParent then + if TPasDotIdentifierScope(StartScope).ConstParent + and IsFieldInheritingConst(Ref) then Include(Ref.Flags,rrfConstInherited); end; end @@ -14795,7 +14856,8 @@ begin if Ref<>nil then begin Include(Ref.Flags,rrfDotScope); - if wesfConstParent in TPasWithExprScope(StartScope).Flags then + if (wesfConstParent in TPasWithExprScope(StartScope).Flags) + and IsFieldInheritingConst(Ref) then Include(Ref.Flags,rrfConstInherited); end; end @@ -14838,21 +14900,21 @@ begin and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then begin // found member in external class instance - C:=FindData.Found.ClassType; - if (C=TPasProcedure) or (C=TPasFunction) then - // ok - else if (C=TPasConst) then - // ok - else if C.InheritsFrom(TPasVariable) - and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then - // ok - else - begin - RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX, - sExternalClassInstanceCannotAccessStaticX, - [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name], - FindData.ErrorPosEl); - end; + C:=FindData.Found.ClassType; + if (C=TPasProcedure) or (C=TPasFunction) then + // ok + else if (C=TPasConst) then + // ok + else if C.InheritsFrom(TPasVariable) + and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then + // ok + else + begin + RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX, + sExternalClassInstanceCannotAccessStaticX, + [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name], + FindData.ErrorPosEl); + end; end; if (FindData.Found is TPasProcedure) then @@ -14877,7 +14939,7 @@ begin end; // constructor: NewInstance or normal call - // it is a NewInstance iff the scope is a class, e.g. TObject.Create + // it is a NewInstance iff the scope is a class/record, e.g. TObject.Create if (Proc.ClassType=TPasConstructor) and OnlyTypeMembers and (Ref<>nil) then @@ -14887,8 +14949,8 @@ begin if Ref.Context<>nil then RaiseInternalError(20170131141936); Ref.Context:=TResolvedRefCtxConstructor.Create; - if StartScope is TPasDotClassScope then - ClassRecScope:=TPasDotClassScope(StartScope).ClassScope + if StartScope is TPasDotClassOrRecordScope then + ClassRecScope:=TPasClassOrRecordScope(TPasDotClassOrRecordScope(StartScope).IdentifierScope) else if (StartScope is TPasWithExprScope) and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope) @@ -15030,7 +15092,7 @@ begin case ScopeType of stModule: FinishModule(El as TPasModule); stUsesClause: FinishUsesClause; - stTypeSection: FinishTypeSection(El as TPasDeclarations); + stTypeSection: FinishTypeSection(El); stTypeDef: FinishTypeDef(El as TPasType); stResourceString: FinishResourcestring(El as TPasResString); stProcedure: FinishProcedure(El as TPasProcedure); diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 3f660db4b5..689143e6bb 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -81,7 +81,7 @@ const nErrRecordConstantsNotAllowed = 2035; nErrRecordMethodsNotAllowed = 2036; nErrRecordPropertiesNotAllowed = 2037; - // free , was nErrRecordVisibilityNotAllowed = 2038; + nErrRecordTypesNotAllowed = 2038; nParserTypeNotAllowedHere = 2039; nParserNotAnOperand = 2040; nParserArrayPropertiesCannotHaveDefaultValue = 2041; @@ -142,7 +142,7 @@ resourcestring SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.'; SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.'; SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.'; - // free, was SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.'; + SErrRecordTypesNotAllowed = 'Record types not allowed at this location.'; SParserTypeNotAllowedHere = 'Type "%s" not allowed here'; SParserNotAnOperand = 'Not an operand: (%d : %s)'; SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value'; @@ -297,8 +297,8 @@ type function GetVariableValueAndLocation(Parent : TPasElement; Out Value: TPasExpr; Out AbsoluteExpr: TPasExpr; Out Location: String): Boolean; procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier); procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier); - procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility); - procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility); + procedure ParseMembersLocalConsts(AType: TPasMembersType; AVisibility: TPasMemberVisibility); + procedure ParseMembersLocalTypes(AType: TPasMembersType; AVisibility: TPasMemberVisibility); procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean); procedure SetOptions(AValue: TPOptions); procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch; @@ -1252,7 +1252,10 @@ begin end else if Parent is TPasRecordType then begin - if PM in [pmVirtual,pmPublic,pmForward] then exit(false); + if not (PM in [pmOverload, + pmInline, pmAssembler, pmPublic, + pmExternal, + pmNoReturn, pmFar, pmFinal]) then exit(false); end; Parent:=Parent.Parent; end; @@ -1310,7 +1313,7 @@ begin end; end; Until Not Found; - UnGetToken; + UngetToken; If Assigned(Element) then Element.Hints:=Result; if ExpectSemiColon then @@ -2829,7 +2832,7 @@ begin end; // Return the parent of a function declaration. This is AParent, -// except when AParent is a class, and the function is overloaded. +// except when AParent is a class/record and the function is overloaded. // Then the parent is the overload object. function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement; var @@ -2838,15 +2841,14 @@ var begin Result:=AParent; - If (not (po_nooverloadedprocs in Options)) and (AParent is TPasClassType) then + If (not (po_nooverloadedprocs in Options)) and (AParent is TPasMembersType) then begin - OverloadedProc:=CheckOverLoadList(TPasClassType(AParent).Members,AName,Member); + OverloadedProc:=CheckOverLoadList(TPasMembersType(AParent).Members,AName,Member); If (OverloadedProc<>Nil) then Result:=OverloadedProc; end; end; - procedure TPasParser.ParseMain(var Module: TPasModule); begin Module:=nil; @@ -3397,7 +3399,7 @@ begin SetBlock(declThreadVar); tkProperty: SetBlock(declProperty); - tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator: + tkProcedure, tkFunction, tkConstructor, tkDestructor, tkOperator: begin SetBlock(declNone); SaveComments; @@ -3409,7 +3411,7 @@ begin SetBlock(declNone); SaveComments; NextToken; - If CurToken in [tkprocedure,tkFunction,tkConstructor, tkDestructor] then + If CurToken in [tkprocedure,tkFunction,tkConstructor,tkDestructor] then begin pt:=GetProcTypeFromToken(CurToken,True); AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt)); @@ -3554,7 +3556,8 @@ begin Declarations.Classes.Add(RecordEl); RecordEl.SetGenericTemplates(List); NextToken; - ParseRecordFieldList(RecordEl,tkend,true); + ParseRecordFieldList(RecordEl,tkend, + msAdvancedRecords in Scanner.CurrentModeSwitches); CheckHint(RecordEl,True); Engine.FinishScope(stTypeDef,RecordEl); end; @@ -3794,7 +3797,7 @@ var begin SaveComments; Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent)); - if Parent is TPasClassType then + if Parent is TPasMembersType then Include(Result.VarModifiers,vmClass); ok:=false; try @@ -3874,7 +3877,7 @@ begin else CheckToken(tkEqual); UngetToken; - CheckHint(Result,True); + CheckHint(Result,not (Parent is TPasMembersType)); ok:=true; finally if not ok then @@ -4355,7 +4358,7 @@ begin // Note: external members are allowed for non external classes too ExternalStruct:=(msExternalClass in CurrentModeSwitches) - and ((Parent is TPasClassType) or (Parent is TPasRecordType)); + and (Parent is TPasMembersType); H:=H+CheckHint(Nil,False); if Full or ExternalStruct then @@ -4750,7 +4753,7 @@ begin NextToken; If not CurTokenIsIdentifier('name') then begin - if P.Parent is TPasClassType then + if P.Parent is TPasMembersType then begin // public section starts UngetToken; @@ -4903,7 +4906,7 @@ begin ResultEl:=TPasFunctionType(Element).ResultEl; ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); end - // In Delphi mode, the implementation in the implementation section can be + // In Delphi mode, the signature in the implementation section can be // without result as it was declared // We actually check if the function exists in the interface section. else if (not IsAnonymous) @@ -6150,7 +6153,6 @@ var PC : TPTreeElement; Ot : TOperatorType; IsTokenBased , ok: Boolean; - begin case ProcType of ptOperator,ptClassOperator: @@ -6293,11 +6295,10 @@ procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType; Var VariantName : String; - v : TPasmemberVisibility; + v : TPasMemberVisibility; Proc: TPasProcedure; ProcType: TProcType; Prop : TPasProperty; - Cons : TPasConst; isClass : Boolean; NamePos: TPasSourcePos; OldCount, i: Integer; @@ -6308,15 +6309,19 @@ begin begin SaveComments; Case CurToken of + tkType: + begin + if Not AllowMethods then + ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed); + ExpectToken(tkIdentifier); + ParseMembersLocalTypes(ARec,v); + end; tkConst: begin if Not AllowMethods then ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed); ExpectToken(tkIdentifier); - Cons:=ParseConstDecl(ARec); - Cons.Visibility:=v; - ARec.members.Add(Cons); - Engine.FinishScope(stDeclaration,Cons); + ParseMembersLocalConsts(ARec,v); end; tkVar: begin @@ -6365,6 +6370,8 @@ begin else ARec.Members.Add(Proc); end; + tkDestructor: + ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed); tkGeneric, // Counts as field name tkIdentifier : begin @@ -6549,40 +6556,46 @@ begin end; end; -procedure TPasParser.ParseClassLocalTypes(AType: TPasClassType; AVisibility : TPasMemberVisibility); +procedure TPasParser.ParseMembersLocalTypes(AType: TPasMembersType; + AVisibility: TPasMemberVisibility); Var T : TPasType; Done : Boolean; begin -// Writeln('Parsing local types'); + // Writeln('Parsing local types'); Repeat T:=ParseTypeDecl(AType); T.Visibility:=AVisibility; AType.Members.Add(t); -// Writeln(CurtokenString,' ',TokenInfos[Curtoken]); + // Writeln(CurtokenString,' ',TokenInfos[Curtoken]); NextToken; - Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility); + Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility); if Done then UngetToken; Until Done; + Engine.FinishScope(stTypeSection,AType); end; -procedure TPasParser.ParseClassLocalConsts(AType: TPasClassType; AVisibility : TPasMemberVisibility); +procedure TPasParser.ParseMembersLocalConsts(AType: TPasMembersType; + AVisibility: TPasMemberVisibility); Var C : TPasConst; Done : Boolean; begin -// Writeln('Parsing local consts'); + // Writeln('Parsing local consts'); Repeat C:=ParseConstDecl(AType); C.Visibility:=AVisibility; AType.Members.Add(C); Engine.FinishScope(stDeclaration,C); -// Writeln(CurtokenString,' ',TokenInfos[Curtoken]); + //Writeln('TPasParser.ParseMembersLocalConsts ',CurtokenString,' ',TokenInfos[CurToken]); NextToken; - Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility); + if CurToken<>tkSemicolon then + exit; + NextToken; + Done:=(CurToken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility); if Done then UngetToken; Until Done; @@ -6658,9 +6671,9 @@ begin SaveComments; Case CurSection of stType: - ParseClassLocalTypes(AType,CurVisibility); + ParseMembersLocalTypes(AType,CurVisibility); stConst : - ParseClassLocalConsts(AType,CurVisibility); + ParseMembersLocalConsts(AType,CurVisibility); stNone, stVar, stClassVar: diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index fc5e0638f8..c6f444a529 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -489,17 +489,12 @@ type // advanced record Procedure TestAdvRecord; Procedure TestAdvRecord_Private; - Procedure TestAdvRecord_StrictPrivate; // ToDo - // ToDo: public, private, strict private - // ToDo: TestAdvRecordPublishedFail - // ToDo: TestAdvRecord_VirtualFail - // ToDo: TestAdvRecord_OverrideFail - // ToDo: constructor, destructor + Procedure TestAdvRecord_StrictPrivate; + Procedure TestAdvRecord_VarConst; + Procedure TestAdvRecord_LocalForwardType; + // ToDo: constructor // ToDo: class function/procedure // ToDo: nested record type - // ToDo: const - // todo: var - // todo: class var // todo: property // todo: class property // todo: TestRecordAsFuncResult @@ -515,6 +510,7 @@ type Procedure TestClassForwardAsAncestorFail; Procedure TestClassForwardNotResolved; Procedure TestClassForwardDuplicateFail; + // ToDo: local forward sub class Procedure TestClass_Method; Procedure TestClass_ConstructorMissingDotFail; Procedure TestClass_MethodImplDuplicateFail; @@ -7859,7 +7855,6 @@ end; procedure TTestResolver.TestAdvRecord_StrictPrivate; begin - exit; StartProgram(false); Add([ '{$modeswitch advancedrecords}', @@ -7872,7 +7867,65 @@ begin ' r: TRec;', 'begin', ' r.a:=r.a;']); - CheckResolverException('aaa',123); + CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember); +end; + +procedure TTestResolver.TestAdvRecord_VarConst; +begin + StartProgram(false); + Add([ + '{$modeswitch advancedrecords}', + 'type', + ' TRec = record', + ' type TInt = word;', + ' const', + ' C1 = 3;', + ' C2: TInt = 4;', + ' var', + ' V1: TInt;', + ' V2: TInt;', + ' class var', + ' VC: TInt;', + ' CA: array[1..C1] of TInt;', + ' procedure DoIt;', + ' end;', + 'procedure TRec.DoIt;', + 'begin', + ' C2:=Self.C2;', + ' V1:=VC;', + ' Self.V1:=Self.VC;', + ' VC:=V1;', + ' Self.VC:=Self.V1;', + 'end;', + 'var', + ' r: TRec;', + 'begin', + ' trec.C2:=trec.C2;', + ' r.V1:=r.VC;', + ' r.V1:=trec.VC;', + ' r.VC:=r.V1;', + ' trec.VC:=trec.c1;', + '']); + ParseProgram; +end; + +procedure TTestResolver.TestAdvRecord_LocalForwardType; +begin + StartProgram(false); + Add([ + '{$modeswitch advancedrecords}', + 'type', + ' TRec = record', + ' type', + ' PInt = ^TInt;', + ' TInt = word;', + ' var i: PInt;', + ' end;', + 'var', + ' r: TRec;', + 'begin', + '']); + ParseProgram; end; procedure TTestResolver.TestClass; diff --git a/packages/fcl-passrc/tests/tctypeparser.pas b/packages/fcl-passrc/tests/tctypeparser.pas index 08f5578e07..1c1fa874db 100644 --- a/packages/fcl-passrc/tests/tctypeparser.pas +++ b/packages/fcl-passrc/tests/tctypeparser.pas @@ -197,7 +197,7 @@ type Procedure DoParseRecord; Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False); procedure AssertVariantSelector(AName, AType: string); - procedure AssertConst1(Hints: TPasMemberHints); + procedure AssertConst1(Hints: TPasMemberHints; Index: integer = 1); procedure AssertField1(Hints: TPasMemberHints); procedure AssertField2(Hints: TPasMemberHints); procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False); @@ -257,7 +257,6 @@ type Procedure TestOnePlatformField; Procedure TestOnePlatformFieldDeprecated; Procedure TestOnePlatformFieldPlatform; - Procedure TestOneConstOneField; Procedure TestOneGenericField; Procedure TestTwoFields; procedure TestTwoFieldProtected; @@ -351,10 +350,16 @@ type Procedure TestVariantNestedVariantBothDeprecatedPlatform; Procedure TestOperatorField; Procedure TestPropertyFail; + Procedure TestAdvRec_TwoConst; Procedure TestAdvRec_Property; Procedure TestAdvRec_PropertyImplementsFail; Procedure TestAdvRec_PropertyNoTypeFail; Procedure TestAdvRec_ForwardFail; + Procedure TestAdvRec_PublishedFail; + Procedure TestAdvRec_ProcVirtualFail; + Procedure TestAdvRec_ProcOverrideFail; + Procedure TestAdvRec_ProcMessageFail; + Procedure TestAdvRec_DestructorFail; end; { TTestProcedureTypeParser } @@ -1365,15 +1370,15 @@ begin end; end; -procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints); +procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints; + Index: integer); begin if Hints=[] then ; - AssertEquals('Member 1 type',TPasConst,TObject(TheRecord.Members[0]).ClassType); - AssertEquals('Const 1 name','x',Const1.Name); - AssertNotNull('Have 1 const expr',Const1.Expr); + AssertEquals('Member '+IntToStr(Index+1)+' type',TPasConst,TObject(TheRecord.Members[Index]).ClassType); + AssertEquals('Const '+IntToStr(Index+1)+' name','x',Const1.Name); + AssertNotNull('Have '+IntToStr(Index+1)+' const expr',Const1.Expr); end; - procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String); begin TestFields([],AHint); @@ -1386,7 +1391,6 @@ begin AssertVariant1(Hints,['0']); end; - procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; VariantLabels: array of string); @@ -1902,15 +1906,6 @@ begin AssertOneIntegerField([hplatform]); end; -procedure TTestRecordTypeParser.TestOneConstOneField; -begin - Scanner.Options:=[po_Delphi]; - TestFields(['public','Const x =123;','y : integer'],'',False); - AssertConst1([]); - AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility); - AssertField2([]); -end; - procedure TTestRecordTypeParser.TestOneGenericField; begin TestFields(['Generic : Integer;'],'',False); @@ -2532,6 +2527,21 @@ begin ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed); end; +procedure TTestRecordTypeParser.TestAdvRec_TwoConst; +var + aConst: TPasConst; +begin + Scanner.Options:=[po_Delphi]; + TestFields(['public','Const x =123;','y : integer = 456'],'',False); + AssertEquals('Two Const',2,TheRecord.Members.Count); + AssertConst1([]); + AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility); + AssertEquals('Member 2 type',TPasConst,TObject(TheRecord.Members[1]).ClassType); + aConst:=TPasConst(TheRecord.Members[1]); + AssertEquals('Const 2 name','y',aConst.Name); + AssertNotNull('Have 2 const expr',aConst.Expr); +end; + procedure TTestRecordTypeParser.TestAdvRec_Property; begin StartRecord(true); @@ -2560,6 +2570,42 @@ begin ParseRecordFail('Syntax error in type',nParserTypeSyntaxError); end; +procedure TTestRecordTypeParser.TestAdvRec_PublishedFail; +begin + StartRecord(true); + AddMember('published'); + AddMember('A: word;'); + ParseRecordFail(SParserInvalidRecordVisibility,nParserInvalidRecordVisibility); +end; + +procedure TTestRecordTypeParser.TestAdvRec_ProcVirtualFail; +begin + StartRecord(true); + AddMember('procedure DoIt; virtual;'); + ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon); +end; + +procedure TTestRecordTypeParser.TestAdvRec_ProcOverrideFail; +begin + StartRecord(true); + AddMember('procedure DoIt; override;'); + ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon); +end; + +procedure TTestRecordTypeParser.TestAdvRec_ProcMessageFail; +begin + StartRecord(true); + AddMember('procedure DoIt; message 2;'); + ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon); +end; + +procedure TTestRecordTypeParser.TestAdvRec_DestructorFail; +begin + StartRecord(true); + AddMember('destructor Free;'); + ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed); +end; + { TBaseTestTypeParser } Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;