From f35e711024ca3bbac3101054a7503b6abedc7437 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 20 Jul 2019 20:13:29 +0000 Subject: [PATCH] fcl-passrc: fixed parsing generic array type git-svn-id: trunk@42472 - --- packages/fcl-passrc/src/pastree.pp | 87 +++++++++++++++--- packages/fcl-passrc/src/pparser.pp | 138 ++++++++++++++--------------- 2 files changed, 142 insertions(+), 83 deletions(-) diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 30a0a413ab..5728e22305 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -606,6 +606,10 @@ type { TPasArrayType } TPasArrayType = class(TPasType) + private + procedure ClearChildReferences(El: TPasElement; arg: pointer); + protected + procedure SetParent(const AValue: TPasElement); override; public destructor Destroy; override; function ElementTypeName: string; override; @@ -617,9 +621,11 @@ type Ranges: TPasExprArray; // only valid if Parser po_arrayrangeexpr enabled PackMode : TPackMode; ElType: TPasType; - Function IsGenericArray : Boolean; - Function IsPacked : Boolean; + GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType, can be nil + function IsGenericArray : Boolean; + function IsPacked : Boolean; procedure AddRange(Range: TPasExpr); + procedure SetGenericTemplates(AList: TFPList); virtual; end; { TPasFileType } @@ -1734,6 +1740,7 @@ const = ('cvar', 'external', 'public', 'export', 'class', 'static'); procedure ReleaseAndNil(var El: TPasElement {$IFDEF CheckPasTreeRefCount}; const Id: string{$ENDIF}); overload; +procedure ReleaseGenericTemplateTypes(var GenericTemplateTypes: TFPList{$IFDEF CheckPasTreeRefCount}; const Id: string{$ENDIF}); function GenericTemplateTypesAsString(List: TFPList): string; {$IFDEF HasPTDumpStack} @@ -1755,6 +1762,21 @@ begin El:=nil; end; +procedure ReleaseGenericTemplateTypes(var GenericTemplateTypes: TFPList{$IFDEF CheckPasTreeRefCount}; const Id: string{$ENDIF}); +var + i: Integer; + El: TPasElement; +begin + if GenericTemplateTypes=nil then exit; + for i := 0 to GenericTemplateTypes.Count - 1 do + begin + El:=TPasElement(GenericTemplateTypes[i]); + El.Parent:=nil; + El.Release{$IFDEF CheckPasTreeRefCount}(Id){$ENDIF}; + end; + FreeAndNil(GenericTemplateTypes); +end; + function GenericTemplateTypesAsString(List: TFPList): string; var i, j: Integer; @@ -3056,11 +3078,28 @@ begin inherited Destroy; end; +procedure TPasArrayType.ClearChildReferences(El: TPasElement; arg: pointer); +begin + El.ClearTypeReferences(Self); + if arg=nil then ; +end; + +procedure TPasArrayType.SetParent(const AValue: TPasElement); +begin + if (AValue=nil) and (Parent<>nil) then + begin + // parent is cleared + // -> clear all child references to this array (releasing loops) + ForEachCall(@ClearChildReferences,nil); + end; + inherited SetParent(AValue); +end; destructor TPasArrayType.Destroy; var i: Integer; begin + ReleaseGenericTemplateTypes(GenericTemplateTypes{$IFDEF CheckPasTreeRefCount},'TPasArrayType'{$ENDIF}); for i:=0 to length(Ranges)-1 do Ranges[i].Release{$IFDEF CheckPasTreeRefCount}('TPasArrayType.Ranges'){$ENDIF}; ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF}); @@ -3073,7 +3112,6 @@ begin inherited Destroy; end; - constructor TPasEnumType.Create(const AName: string; AParent: TPasElement); begin inherited Create(AName, AParent); @@ -4032,29 +4070,39 @@ end; function TPasArrayType.GetDeclaration (full : boolean) : string; begin Result:='Array'; + if Full then + begin + if GenericTemplateTypes<>nil then + Result:=Result+GenericTemplateTypesAsString(GenericTemplateTypes)+' = '+Result + else + Result:=Result+' = '+Result; + end; If (IndexRange<>'') then Result:=Result+'['+IndexRange+']'; Result:=Result+' of '; If IsPacked then - Result := 'packed '+Result; // 12/04/04 Dave - Added + Result := 'packed '+Result; // 12/04/04 Dave - Added If Assigned(Eltype) then Result:=Result+ElType.Name else Result:=Result+'const'; - If Full Then - Result:=FixTypeDecl(Result); end; procedure TPasArrayType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); +var + i: Integer; begin inherited ForEachCall(aMethodCall, Arg); + if GenericTemplateTypes<>nil then + for i:=0 to GenericTemplateTypes.Count-1 do + ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false); ForEachChildCall(aMethodCall,Arg,ElType,true); end; function TPasArrayType.IsGenericArray: Boolean; begin - Result:=ElType is TPasGenericTemplateType; + Result:=GenericTemplateTypes<>nil; end; function TPasArrayType.IsPacked: Boolean; @@ -4071,6 +4119,22 @@ begin Ranges[i]:=Range; end; +procedure TPasArrayType.SetGenericTemplates(AList: TFPList); +var + I: Integer; + El: TPasElement; +begin + if GenericTemplateTypes=nil then + GenericTemplateTypes:=TFPList.Create; + For I:=0 to AList.Count-1 do + begin + El:=TPasElement(AList[i]); + El.Parent:=Self; + GenericTemplateTypes.Add(El); + end; + AList.Clear; +end; + function TPasFileType.GetDeclaration (full : boolean) : string; begin Result:='File'; @@ -4198,13 +4262,8 @@ begin end; FreeAndNil(Members); - for i := 0 to GenericTemplateTypes.Count - 1 do - begin - El:=TPasElement(GenericTemplateTypes[i]); - El.Parent:=nil; - El.Release{$IFDEF CheckPasTreeRefCount}('TPasMembersType.GenericTemplateTypes'){$ENDIF}; - end; - FreeAndNil(GenericTemplateTypes); + ReleaseGenericTemplateTypes(GenericTemplateTypes + {$IFDEF CheckPasTreeRefCount},'TPasMembersType.GenericTemplateTypes'{$ENDIF}); inherited Destroy; end; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index e77b2c052f..a62b69eb1b 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -312,7 +312,7 @@ type Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif};SkipSourceInfo : Boolean = False);overload; function GetProcTypeFromToken(tk: TToken; IsClass: Boolean=False ): TProcType; procedure ParseAsmBlock(AsmBlock: TPasImplAsmStatement); virtual; - procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken; AllowMethods : Boolean); + procedure ParseRecordMembers(ARec: TPasRecordType; AEndToken: TToken; AllowMethods : Boolean); procedure ParseRecordVariantParts(ARec: TPasRecordType; AEndToken: TToken); function GetProcedureClass(ProcType : TProcType): TPTreeElement; procedure ParseClassFields(AType: TPasClassType; const AVisibility: TPasMemberVisibility; IsClassField : Boolean); @@ -366,6 +366,7 @@ type function ParseExprOperand(AParent : TPasElement): TPasExpr; function ParseExpIdent(AParent : TPasElement): TPasExpr; deprecated 'use ParseExprOperand instead'; // since fpc 3.3.1 procedure DoParseClassType(AType: TPasClassType); + procedure DoParseArrayType(ArrType: TPasArrayType); function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil; AllowEqual : Boolean = True): TPasExpr; function DoParseConstValueExpression(AParent: TPasElement): TPasExpr; function CheckPackMode: TPackMode; @@ -1957,67 +1958,13 @@ function TPasParser.ParseArrayType(Parent: TPasElement; ): TPasArrayType; Var - S : String; ok: Boolean; - RangeExpr: TPasExpr; - begin Result := TPasArrayType(CreateElement(TPasArrayType, TypeName, Parent, NamePos)); ok:=false; try Result.PackMode:=PackMode; - NextToken; - S:=''; - case CurToken of - tkSquaredBraceOpen: - begin - // static array - if Parent is TPasArgument then - ParseExcTokenError('of'); - repeat - NextToken; - if po_arrayrangeexpr in Options then - begin - RangeExpr:=DoParseExpression(Result); - Result.AddRange(RangeExpr); - end - else if CurToken<>tkSquaredBraceClose then - S:=S+CurTokenText; - if CurToken=tkSquaredBraceClose then - break - else if CurToken=tkComma then - continue - else if po_arrayrangeexpr in Options then - ParseExcTokenError(']'); - until false; - Result.IndexRange:=S; - ExpectToken(tkOf); - Result.ElType := ParseType(Result,CurSourcePos); - end; - tkOf: - begin - NextToken; - if CurToken = tkConst then - // array of const - begin - if not (Parent is TPasArgument) then - ParseExcExpectedIdentifier; - end - else - begin - if (CurToken=tkarray) and (Parent is TPasArgument) then - ParseExcExpectedIdentifier; - UngetToken; - Result.ElType := ParseType(Result,CurSourcePos); - end; - end - else - ParseExc(nParserArrayTypeSyntaxError,SParserArrayTypeSyntaxError); - end; - // TPasProcedureType parsing has eaten the semicolon; - // We know it was a local definition if the array def (result) is the parent - if (Result.ElType is TPasProcedureType) and (Result.ElType.Parent=Result) then - UnGetToken; + DoParseArrayType(Result); Engine.FinishScope(stTypeDef,Result); ok:=true; finally @@ -3669,7 +3616,7 @@ begin Declarations.Classes.Add(RecordEl); RecordEl.SetGenericTemplates(List); NextToken; - ParseRecordFieldList(RecordEl,tkend, + ParseRecordMembers(RecordEl,tkend, (msAdvancedRecords in Scanner.CurrentModeSwitches) and not (Declarations is TProcedureBody) and (RecordEl.Name<>'')); @@ -3678,18 +3625,12 @@ begin end; tkArray: begin - if List.Count<>1 then - ParseExc(nParserGenericArray1Element,sParserGenericArray1Element); - ArrEl:=TPasArrayType(ParseArrayType(Declarations,NamePos,TypeName,pmNone)); + ArrEl := TPasArrayType(CreateElement(TPasArrayType, TypeName, Declarations, NamePos)); Declarations.Declarations.Add(ArrEl); Declarations.Types.Add(ArrEl); + ArrEl.SetGenericTemplates(List); + DoParseArrayType(ArrEl); CheckHint(ArrEl,True); - {$IFDEF VerbosePasResolver} - ParseExcTokenError('20190619145000'); - {$ENDIF} - ArrEl.ElType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; - ArrEl.ElType:=TPasGenericTemplateType(List[0]); - List.Clear; Engine.FinishScope(stTypeDef,ArrEl); end; else @@ -6516,7 +6457,7 @@ begin NextToken; M:=TPasRecordType(CreateElement(TPasRecordType,'',V)); V.Members:=M; - ParseRecordFieldList(M,tkBraceClose,False); + ParseRecordMembers(M,tkBraceClose,False); // Current token is closing ), so we eat that NextToken; // If there is a semicolon, we eat that too. @@ -6564,7 +6505,7 @@ begin end; // Starts on first token after Record or (. Ends on AEndToken -procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType; +procedure TPasParser.ParseRecordMembers(ARec: TPasRecordType; AEndToken: TToken; AllowMethods: Boolean); var isClass : Boolean; @@ -6756,7 +6697,7 @@ begin try Result.PackMode:=PackMode; NextToken; - ParseRecordFieldList(Result,tkEnd, + ParseRecordMembers(Result,tkEnd, (msAdvancedRecords in Scanner.CurrentModeSwitches) and not (Parent is TProcedureBody)); Engine.FinishScope(stTypeDef,Result); ok:=true; @@ -7172,6 +7113,65 @@ begin end; end; +procedure TPasParser.DoParseArrayType(ArrType: TPasArrayType); +var + S: String; + RangeExpr: TPasExpr; +begin + NextToken; + S:=''; + case CurToken of + tkSquaredBraceOpen: + begin + // static array + if ArrType.Parent is TPasArgument then + ParseExcTokenError('of'); + repeat + NextToken; + if po_arrayrangeexpr in Options then + begin + RangeExpr:=DoParseExpression(ArrType); + ArrType.AddRange(RangeExpr); + end + else if CurToken<>tkSquaredBraceClose then + S:=S+CurTokenText; + if CurToken=tkSquaredBraceClose then + break + else if CurToken=tkComma then + continue + else if po_arrayrangeexpr in Options then + ParseExcTokenError(']'); + until false; + ArrType.IndexRange:=S; + ExpectToken(tkOf); + ArrType.ElType := ParseType(ArrType,CurSourcePos); + end; + tkOf: + begin + NextToken; + if CurToken = tkConst then + // array of const + begin + if not (ArrType.Parent is TPasArgument) then + ParseExcExpectedIdentifier; + end + else + begin + if (CurToken=tkarray) and (ArrType.Parent is TPasArgument) then + ParseExcExpectedIdentifier; + UngetToken; + ArrType.ElType := ParseType(ArrType,CurSourcePos); + end; + end + else + ParseExc(nParserArrayTypeSyntaxError,SParserArrayTypeSyntaxError); + end; + // TPasProcedureType parsing has eaten the semicolon; + // We know it was a local definition if the array def (ArrType) is the parent + if (ArrType.ElType is TPasProcedureType) and (ArrType.ElType.Parent=ArrType) then + UnGetToken; +end; + function TPasParser.ParseClassDecl(Parent: TPasElement; const NamePos: TPasSourcePos; const AClassName: String; AObjKind: TPasObjKind; PackMode: TPackMode; GenericArgs: TFPList): TPasType;