diff --git a/packages/fcl-passrc/src/passrcutil.pp b/packages/fcl-passrc/src/passrcutil.pp index 7964e6db5d..c1de9dabd2 100644 --- a/packages/fcl-passrc/src/passrcutil.pp +++ b/packages/fcl-passrc/src/passrcutil.pp @@ -171,8 +171,6 @@ procedure TPasSrcAnalysis.GetClassMembers(AClass: TPasClassType; List: TStrings; Var I : Integer; E : TPasElement; - V : TPasVariant; - begin For I:=0 to AClass.Members.Count-1 do begin diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 59df48c9d3..5cfa02cde1 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -134,7 +134,7 @@ type procedure Accept(Visitor: TPassTreeVisitor); override; property RefCount: LongWord read FRefCount; property Name: string read FName write FName; - property Parent: TPasElement read FParent; + property Parent: TPasElement read FParent Write FParent; Property Hints : TPasMemberHints Read FHints Write FHints; Property CustomData : TObject Read FData Write FData; Property HintMessage : String Read FHintMessage Write FHintMessage; @@ -158,7 +158,7 @@ type TPasExpr = class(TPasElement) Kind : TPasExprKind; - OpCode : TexprOpcode; + OpCode : TExprOpCode; constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TexprOpcode); virtual; overload; end; @@ -428,6 +428,7 @@ type IndexRange : string; PackMode : TPackMode; ElType: TPasType; + Function IsGenericArray : Boolean; Function IsPacked : Boolean; end; @@ -512,7 +513,7 @@ type Function IsAdvancedRecord : Boolean; end; - TPasGenericTemplateType = Class(TPasElement); + TPasGenericTemplateType = Class(TPasType); TPasObjKind = (okObject, okClass, okInterface, okGeneric, okSpecialize, okClassHelper,okRecordHelper,okTypeHelper); @@ -613,9 +614,9 @@ type { TPasUnresolvedUnitRef } TPasUnresolvedUnitRef = Class(TPasUnresolvedSymbolRef) - function ElementTypeName: string; override; - Public + public FileName : string; + function ElementTypeName: string; override; end; { TPasStringType } @@ -629,7 +630,6 @@ type { TPasTypeRef } TPasTypeRef = class(TPasUnresolvedTypeRef) - public public RefType: TPasType; end; @@ -656,6 +656,7 @@ type { TPasExportSymbol } TPasExportSymbol = class(TPasElement) + public ExportName : TPasExpr; Exportindex : TPasExpr; Destructor Destroy; override; @@ -666,7 +667,6 @@ type { TPasConst } TPasConst = class(TPasVariable) - public public function ElementTypeName: string; override; end; @@ -674,7 +674,7 @@ type { TPasProperty } TPasProperty = class(TPasVariable) - Public + public FResolvedType : TPasType; public constructor Create(const AName: string; AParent: TPasElement); override; @@ -863,7 +863,6 @@ Type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; public - Labels: TFPList; Body: TPasImplBlock; end; @@ -2561,6 +2560,11 @@ begin end; end; +function TPasArrayType.IsGenericArray: Boolean; +begin + Result:=elType is TPasGenericTemplateType; +end; + function TPasArrayType.IsPacked: Boolean; begin Result:=PackMode=pmPacked; @@ -3527,7 +3531,7 @@ end; { TBinaryExpr } -function TBinaryExpr.GetDeclaration(Full : Boolean):AnsiString; +function TBinaryExpr.GetDeclaration(full: Boolean): string; function OpLevel(op: TPasExpr): Integer; begin case op.OpCode of @@ -3574,14 +3578,18 @@ constructor TBinaryExpr.Create(AParent : TPasElement; xleft,xright:TPasExpr; AOp begin inherited Create(AParent,pekBinary, AOpCode); left:=xleft; + left.Parent:=Self; right:=xright; + right.Parent:=Self; end; constructor TBinaryExpr.CreateRange(AParent : TPasElement; xleft,xright:TPasExpr); begin inherited Create(AParent,pekRange, eopNone); left:=xleft; + left.Parent:=Self; right:=xright; + right.Parent:=Self; end; destructor TBinaryExpr.Destroy; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 4d9b6d75d7..c62b6320f1 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -68,6 +68,10 @@ const nParserArrayPropertiesCannotHaveDefaultValue = 2041; nParserDefaultPropertyMustBeArray = 2042; nParserUnknownProcedureType = 2043; + nParserGenericArray1Element = 2044; + nParserGenericClassOrArray = 2045; + nParserDuplicateIdentifier = 2046; + // resourcestring patterns of messages resourcestring @@ -114,6 +118,9 @@ resourcestring SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value'; SParserDefaultPropertyMustBeArray = 'The default property must be an array property'; SParserUnknownProcedureType = 'Unknown procedure type "%d"'; + SParserGenericArray1Element = 'Generic arrays can have only 1 template element'; + SParserGenericClassOrArray = 'Generic can only be used with classes or arrays'; + SParserDuplicateIdentifier = 'Duplicate identifier "%s"'; type TPasParserLogHandler = Procedure (Sender : TObject; Const Msg : String) of object; @@ -237,8 +244,19 @@ type Function TokenToExprOp (AToken : TToken) : TExprOpCode; function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement): TPasElement;overload; function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement;overload; + function CreatePrimitiveExpr(AParent: TPasElement; AKind: TPasExprKind; const AValue: String): TPrimitiveExpr; + function CreateBoolConstExpr(AParent: TPasElement; AKind: TPasExprKind; const ABoolValue : Boolean): TBoolConstExpr; + function CreateBinaryExpr(AParent : TPasElement; xleft, xright: TPasExpr; AOpCode: TExprOpCode): TBinaryExpr; + procedure AddToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr; + Element: TPasExpr; AOpCode: TExprOpCode); + function CreateUnaryExpr(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr; + function CreateArrayValues(AParent : TPasElement): TArrayValues; function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; UseParentAsResultParent: Boolean): TPasFunctionType; + function CreateInheritedExpr(AParent : TPasElement): TInheritedExpr; + function CreateSelfExpr(AParent : TPasElement): TSelfExpr; + function CreateNilExpr(AParent : TPasElement): TNilExpr; + function CreateRecordValues(AParent : TPasElement): TRecordValues; Function IsCurTokenHint(out AHint : TPasMemberHint) : Boolean; overload; Function IsCurTokenHint: Boolean; overload; Function TokenIsCallingConvention(S : String; out CC : TCallingConvention) : Boolean; virtual; @@ -250,6 +268,8 @@ type function DoParseExpression(Aparent : TPaselement;InitExpr: TPasExpr=nil): TPasExpr; function DoParseConstValueExpression(AParent : TPasElement): TPasExpr; function CheckPackMode: TPackMode; + function CheckUseUnit(ASection: TPasSection; AUnitName : string): TPasElement; + procedure CheckImplicitUsedUnits(ASection: TPasSection); // Overload handling procedure AddProcOrFunction(Decs: TPasDeclarations; AProc: TPasProcedure); function CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement; @@ -300,6 +320,7 @@ type procedure ParseUnit(var Module: TPasModule); procedure ParseProgram(var Module: TPasModule; SkipHeader : Boolean = False); procedure ParseLibrary(var Module: TPasModule); + procedure ParseOptionalUsesList(ASection: TPasSection); procedure ParseUsesList(ASection: TPasSection); procedure ParseInterface; procedure ParseImplementation; @@ -594,6 +615,7 @@ end; function TPasTreeContainer.FindModule(const AName: String): TPasModule; begin + if AName='' then ; Result := nil; end; @@ -1019,7 +1041,7 @@ function TPasParser.ParseAliasType(Parent: TPasElement; const TypeName: String begin Result := TPasTypeAliasType(CreateElement(TPasTypeAliasType, TypeName, Parent)); try - Result.DestType := ParseType(nil,''); + Result.DestType := ParseType(Result,''); except FreeAndNil(Result); raise; @@ -1032,7 +1054,7 @@ function TPasParser.ParsePointerType(Parent: TPasElement; const TypeName: String begin Result := TPasPointerType(CreateElement(TPasPointerType, TypeName, Parent)); Try - TPasPointerType(Result).DestType := ParseType(nil); + TPasPointerType(Result).DestType := ParseType(Result); except FreeAndNil(Result); Raise; @@ -1201,7 +1223,7 @@ begin until CurToken = tkSquaredBraceClose; Result.IndexRange:=S; ExpectToken(tkOf); - Result.ElType := ParseType(nil); + Result.ElType := ParseType(Result); end; tkOf: begin @@ -1210,7 +1232,7 @@ begin else begin UngetToken; - Result.ElType := ParseType(nil); + Result.ElType := ParseType(Result); end end else @@ -1230,7 +1252,7 @@ begin Result:=TPasFileType(CreateElement(TPasFileType, TypeName, Parent)); NextToken; If CurToken=tkOf then - Result.ElType := ParseType(nil) + Result.ElType := ParseType(Result) else ungettoken; end; @@ -1260,8 +1282,9 @@ begin PClose:=tkBraceClose; end; - params:=TParamsExpr.Create(AParent,paramskind); + params:=TParamsExpr(CreateElement(TParamsExpr,'',AParent)); try + params.Kind:=paramskind; NextToken; if not isEndOfExp then begin repeat @@ -1326,55 +1349,55 @@ end; function TPasParser.ParseExpIdent(AParent : TPasElement):TPasExpr; var - x : TPasExpr; + Last , Expr: TPasExpr; prm : TParamsExpr; - u : TUnaryExpr; b : TBinaryExpr; optk : TToken; + ok: Boolean; begin Result:=nil; case CurToken of - tkString: x:=TPrimitiveExpr.Create(AParent,pekString, CurTokenString); - tkChar: x:=TPrimitiveExpr.Create(AParent,pekString, CurTokenText); - tkNumber: x:=TPrimitiveExpr.Create(AParent,pekNumber, CurTokenString); - tkIdentifier: x:=TPrimitiveExpr.Create(AParent,pekIdent, CurTokenText); - tkfalse, tktrue: x:=TBoolConstExpr.Create(Aparent,pekBoolConst, CurToken=tktrue); - tknil: x:=TNilExpr.Create(Aparent); - tkSquaredBraceOpen: x:=ParseParams(AParent,pekSet); + tkString: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString); + tkChar: Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText); + tkNumber: Last:=CreatePrimitiveExpr(AParent,pekNumber, CurTokenString); + tkIdentifier: Last:=CreatePrimitiveExpr(AParent,pekIdent, CurTokenText); + tkfalse, tktrue: Last:=CreateBoolConstExpr(Aparent,pekBoolConst, CurToken=tktrue); + tknil: Last:=CreateNilExpr(AParent); + tkSquaredBraceOpen: Last:=ParseParams(AParent,pekSet); tkinherited: begin //inherited; inherited function - x:=TInheritedExpr.Create(AParent); + Last:=CreateInheritedExpr(AParent); NextToken; if (CurToken=tkIdentifier) then begin - b:=TBinaryExpr.Create(AParent,x, DoParseExpression(AParent), eopNone); + b:=CreateBinaryExpr(AParent,Last, DoParseExpression(AParent), eopNone); if not Assigned(b.right) then begin B.Free; Exit; // error end; - x:=b; + Last:=b; UngetToken; end else UngetToken; end; tkself: begin - //x:=TPrimitiveExpr.Create(AParent,pekString, CurTokenText); //function(self); - x:=TSelfExpr.Create(AParent); + //Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText); //function(self); + Last:=CreateSelfExpr(AParent); NextToken; if CurToken = tkDot then begin // self.Write(EscapeText(AText)); optk:=CurToken; NextToken; - b:=TBinaryExpr.Create(AParent,x, ParseExpIdent(AParent), TokenToExprOp(optk)); + b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk)); if not Assigned(b.right) then begin B.Free; Exit; // error end; - x:=b; + Last:=b; end; UngetToken; end; @@ -1385,7 +1408,7 @@ begin UngetToken; ParseExcExpectedIdentifier; end; - x:=TPrimitiveExpr.Create(AParent,pekString, '@'+CurTokenText); + Last:=CreatePrimitiveExpr(AParent,pekString, '@'+CurTokenText); end; tkCaret: begin // ^A..^_ characters. See #16341 @@ -1394,23 +1417,27 @@ begin UngetToken; ParseExcExpectedIdentifier; end; - x:=TPrimitiveExpr.Create(AParent,pekString, '^'+CurTokenText); + Last:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText); end; else ParseExcExpectedIdentifier; end; - if x.Kind<>pekSet then NextToken; + Result:=Last; + if Last.Kind<>pekSet then NextToken; + + ok:=false; try - if x.Kind=pekIdent then + if Last.Kind=pekIdent then begin while CurToken in [tkDot] do begin NextToken; if CurToken=tkIdentifier then begin - b:=TBinaryExpr.Create(AParent,x, TPrimitiveExpr.Create(AParent,pekIdent, CurTokenText), eopSubIdent); + AddToBinaryExprChain(Result,Last, + CreatePrimitiveExpr(AParent,pekIdent, CurTokenText), eopSubIdent); NextToken; end else @@ -1418,7 +1445,6 @@ begin UngetToken; ParseExcExpectedIdentifier; end; - x:=b; end; while CurToken in [tkBraceOpen, tkSquaredBraceOpen, tkCaret] do case CurToken of @@ -1426,20 +1452,22 @@ begin begin prm:=ParseParams(AParent,pekFuncParams); if not Assigned(prm) then Exit; - prm.Value:=x; - x:=prm; + prm.Value:=Last; + Result:=prm; + Last:=prm; end; tkSquaredBraceOpen: begin prm:=ParseParams(AParent,pekArrayParams); if not Assigned(prm) then Exit; - prm.Value:=x; - x:=prm; + prm.Value:=Last; + Result:=prm; + Last:=prm; end; tkCaret: begin - u:=TUnaryExpr.Create(AParent,x, TokenToExprOp(CurToken)); - x:=u; + Result:=CreateUnaryExpr(AParent,Result,TokenToExprOp(CurToken)); + Last:=Result; NextToken; end; end; @@ -1448,19 +1476,16 @@ begin begin optk:=CurToken; NextToken; - b:=TBinaryExpr.Create(AParent,x, ParseExpIdent(AParent), TokenToExprOp(optk)); - if not Assigned(b.right) then - begin - b.free; + Expr:=ParseExpIdent(AParent); + if Expr=nil then Exit; // error - end; - x:=b; + AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk)); end; end; - - Result:=x; + ok:=true; finally - if not Assigned(Result) then x.Free; + if not ok then + FreeAndNil(Result); end; end; @@ -1537,9 +1562,12 @@ const xright:=PopExp; xleft:=PopExp; if t=tkDotDot then - bin := TBinaryExpr.CreateRange(AParent,xleft, xright) + begin + bin:=CreateBinaryExpr(Aparent,xleft,xright,eopNone); + bin.Kind:=pekRange; + end else - bin := TBinaryExpr.Create(AParent,xleft, xright, TokenToExprOp(t)); + bin:=CreateBinaryExpr(AParent,xleft,xright,TokenToExprOp(t)); expstack.Add(bin); end; @@ -1590,7 +1618,7 @@ begin begin NextToken; // DumpCurToken('Here 2'); - x:=TBinaryExpr.Create(AParent,x, ParseExpIdent(AParent), TokenToExprOp(tkDot)); + x:=CreateBinaryExpr(AParent,x, ParseExpIdent(AParent), TokenToExprOp(tkDot)); // DumpCurToken('Here 3'); end; @@ -1609,11 +1637,11 @@ begin x:=popexp; if (tempop=tkMinus) and (X.Kind=pekRange) then begin - TBinaryExpr(x).Left:=TUnaryExpr.Create(x, TBinaryExpr(X).left, eopSubtract); + TBinaryExpr(x).Left:=CreateUnaryExpr(x, TBinaryExpr(X).left, eopSubtract); expstack.Add(x); end else - expstack.Add( TUnaryExpr.Create(AParent, x, TokenToExprOp(tempop) )); + expstack.Add(CreateUnaryExpr(AParent, x, TokenToExprOp(tempop) )); end; end else @@ -1697,7 +1725,7 @@ begin case CurToken of tkComma: // array of values (a,b,c); begin - a:=TArrayValues.Create(AParent); + a:=CreateArrayValues(AParent); a.AddValues(x); repeat NextToken; @@ -1711,7 +1739,7 @@ begin begin n:=GetExprIdent(x); x.Free; - r:=TRecordValues.Create(AParent); + r:=CreateRecordValues(AParent); NextToken; x:=DoParseConstValueExpression(AParent); r.AddField(n, x); @@ -1757,7 +1785,7 @@ begin Result:=TPasOverloadedProc(OldMember) else begin - Result:=TPasOverloadedProc.Create(AName, OldMember.Parent); + Result:=TPasOverloadedProc(CreateElement(TPasOverloadedProc, AName, OldMember.Parent)); Result.Visibility:=OldMember.Visibility; Result.Overloads.Add(OldMember); Result.SourceFilename:=OldMember.SourceFilename; @@ -1915,6 +1943,7 @@ begin end; Section := TProgramSection(CreateElement(TProgramSection, '', CurModule)); PP.ProgramSection := Section; + ParseOptionalUsesList(Section); ParseDeclarations(Section); finally FCurModule:=nil; @@ -1942,12 +1971,25 @@ begin ParseExcTokenError(';'); Section := TLibrarySection(CreateElement(TLibrarySection, '', CurModule)); PP.LibrarySection := Section; + ParseOptionalUsesList(Section); ParseDeclarations(Section); finally FCurModule:=nil; end; end; +procedure TPasParser.ParseOptionalUsesList(ASection: TPasSection); +// checks if next token is Uses keyword and read uses list +begin + NextToken; + if CurToken=tkuses then + ParseUsesList(ASection) + else begin + CheckImplicitUsedUnits(ASection); + UngetToken; + end; +end; + // Starts after the "interface" token procedure TPasParser.ParseInterface; var @@ -1955,6 +1997,7 @@ var begin Section := TInterfaceSection(CreateElement(TInterfaceSection, '', CurModule)); CurModule.InterfaceSection := Section; + ParseOptionalUsesList(Section); ParseDeclarations(Section); end; @@ -1965,6 +2008,7 @@ var begin Section := TImplementationSection(CreateElement(TImplementationSection, '', CurModule)); CurModule.ImplementationSection := Section; + ParseOptionalUsesList(Section); ParseDeclarations(Section); end; @@ -2064,6 +2108,7 @@ var ResStrEl: TPasResString; TypeEl: TPasType; ClassEl: TPasClassType; + ArrEl : TPasArrayType; List: TFPList; i,j: Integer; VarEl: TPasVariable; @@ -2112,8 +2157,10 @@ begin break; end; tkUses: - if Declarations is TPasSection then - ParseUsesList(TPasSection(Declarations)) + if Declarations.ClassType=TInterfaceSection then + ParseExcTokenError(TokenInfos[tkimplementation]) + else if Declarations is TPasSection then + ParseExcTokenError(TokenInfos[tkend]) else ParseExcSyntaxError; tkConst: @@ -2255,21 +2302,44 @@ begin if CurBlock <> declType then ParseExcSyntaxError; TypeName := ExpectIdentifier; - ClassEl := TPasClassType(Engine.CreateElement(TPasClassType,TypeName,Declarations, Scanner.CurFilename, Scanner.CurRow)); - ClassEl.ObjKind:=okGeneric; + List:=TFPList.Create; try - ReadGenericArguments(ClassEl.GenericTemplateTypes,ClassEl); - Except + ReadGenericArguments(List,Nil); + ExpectToken(tkEqual); + NextToken; + Case CurToken of + tkClass : + begin + ClassEl := TPasClassType(Engine.CreateElement(TPasClassType,TypeName,Declarations, Scanner.CurFilename, Scanner.CurRow)); + ClassEl.ObjKind:=okGeneric; + For I:=0 to List.Count-1 do + begin + TPasElement(List[i]).Parent:=ClassEl; + ClassEl.GenericTemplateTypes.Add(List[i]); + end; + NextToken; + DoParseClassType(ClassEl); + Declarations.Declarations.Add(ClassEl); + Declarations.Classes.Add(ClassEl); + CheckHint(classel,True); + end; + tkArray: + begin + if List.Count<>1 then + ParseExc(nParserGenericArray1Element,sParserGenericArray1Element); + ArrEl:=TPasArrayType(ParseArrayType(Declarations,TypeName,pmNone)); + CheckHint(ArrEl,True); + ArrEl.ElType.Release; + ArrEl.elType:=TPasGenericTemplateType(List[0]); + Declarations.Declarations.Add(ArrEl); + Declarations.Types.Add(ArrEl); + end; + else + ParseExc(nParserGenericClassOrArray,SParserGenericClassOrArray); + end; + finally List.Free; - Raise; end; - ExpectToken(tkEqual); - ExpectToken(tkClass); - NextToken; - DoParseClassType(ClassEl); - Declarations.Declarations.Add(ClassEl); - Declarations.Classes.Add(ClassEl); - CheckHint(classel,True); end; tkbegin: begin @@ -2298,34 +2368,57 @@ begin end; end; -// Starts after the "uses" token -procedure TPasParser.ParseUsesList(ASection: TPasSection); +function TPasParser.CheckUseUnit(ASection: TPasSection; AUnitName: string + ): TPasElement; - function CheckUnit(AUnitName : string):TPasElement; + procedure CheckDuplicateInUsesList(AUnitName : string; UsesList: TFPList); + var + i: Integer; begin - result := Engine.FindModule(AUnitName); // should we resolve module here when "IN" filename is not known yet? - if Assigned(result) then - result.AddRef - else - Result := TPasType(CreateElement(TPasUnresolvedUnitRef, AUnitName, - ASection)); - ASection.UsesList.Add(Result); + if UsesList=nil then exit; + for i:=0 to UsesList.Count-1 do + if CompareText(AUnitName,TPasModule(UsesList[i]).Name)=0 then + ParseExc(nParserDuplicateIdentifier,SParserDuplicateIdentifier,[AUnitName]); end; +begin + if CompareText(AUnitName,CurModule.Name)=0 then + ParseExc(nParserDuplicateIdentifier,SParserDuplicateIdentifier,[AUnitName]); + CheckDuplicateInUsesList(AUnitName,ASection.UsesList); + if ASection.ClassType=TImplementationSection then + CheckDuplicateInUsesList(AUnitName,CurModule.InterfaceSection.UsesList); + + result := Engine.FindModule(AUnitName); // should we resolve module here when "IN" filename is not known yet? + if Assigned(result) then + result.AddRef + else + Result := TPasUnresolvedUnitRef(CreateElement(TPasUnresolvedUnitRef, + AUnitName, ASection)); + ASection.UsesList.Add(Result); +end; + +procedure TPasParser.CheckImplicitUsedUnits(ASection: TPasSection); var - AUnitName: String; - Element: TPasElement; i: Integer; begin - If not (Asection.ClassType=TImplementationSection) Then // interface,program,library,package + If not (ASection.ClassType=TImplementationSection) Then // interface,program,library,package begin // load implicit units, like 'System' for i:=0 to ImplicitUses.Count-1 do - CheckUnit(ImplicitUses[i]); + CheckUseUnit(ASection,ImplicitUses[i]); end; +end; + +// Starts after the "uses" token +procedure TPasParser.ParseUsesList(ASection: TPasSection); +var + AUnitName: String; + Element: TPasElement; +begin + CheckImplicitUsedUnits(ASection); Repeat - AUnitName := ExpectIdentifier; + AUnitName := ExpectIdentifier; NextToken; while CurToken = tkDot do begin @@ -2333,7 +2426,7 @@ begin AUnitName := AUnitName + '.' + CurTokenString; NextToken; end; - Element := CheckUnit(AUnitName); + Element := CheckUseUnit(ASection,AUnitName); if (CurToken=tkin) then begin ExpectToken(tkString); @@ -2357,7 +2450,7 @@ begin try NextToken; if CurToken = tkColon then - Result.VarType := ParseType(nil) + Result.VarType := ParseType(Result) else UngetToken; ExpectToken(tkEqual); @@ -2468,7 +2561,7 @@ begin Result := TPasClassType(Engine.CreateElement(TPasClassType, TypeName, Parent, Scanner.CurFilename, Scanner.CurRow)); try Result.ObjKind := okSpecialize; - Result.AncestorType := ParseType(nil); + Result.AncestorType := ParseType(Result); Result.IsShortDefinition:=True; ReadGenericArguments(TPasClassType(Result).GenericTemplateTypes,Result); except @@ -2619,10 +2712,7 @@ begin if CurToken=tkComma then ExpectIdentifier; Until (CurToken=tkColon); - If Full then - VarType := ParseComplexType(Nil) - else - VarType := ParseComplexType(Parent); + VarType := ParseComplexType(Parent); Value:=Nil; H:=CheckHint(Nil,False); If Full then @@ -2638,13 +2728,14 @@ begin // Writeln(VarNames[i], AVisibility); VarEl:=TPasVariable(CreateElement(TPasVariable,VarNames[i],Parent,AVisibility)); VarEl.VarType := VarType; + VarType.Parent := VarEl; // Procedure declaration eats the hints. if Assigned(VarType) and (VarType is TPasprocedureType) then VarEl.Hints:=VarType.Hints else VarEl.Hints:=H; - Varel.Modifiers:=Mods; - Varel.VarModifiers:=VarMods; + VarEl.Modifiers:=Mods; + VarEl.VarModifiers:=VarMods; if (i=0) then VarEl.Expr:=Value; VarEl.AbsoluteLocation:=Loc; @@ -2737,7 +2828,7 @@ end; procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: TToken); var ArgNames: TStringList; - IsUntyped: Boolean; + IsUntyped, ok: Boolean; Name : String; Value : TPasExpr; i: Integer; @@ -2795,6 +2886,7 @@ begin if not IsUntyped then begin ArgType := ParseType(nil); + ok:=false; try NextToken; if CurToken = tkEqual then @@ -2809,9 +2901,10 @@ begin // After this, we're on ), which must be unget. end; UngetToken; - except - FreeAndNil(ArgType); - Raise; + ok:=true; + finally + if not ok then + FreeAndNil(ArgType); end; end; @@ -2820,8 +2913,12 @@ begin Arg := TPasArgument(CreateElement(TPasArgument, ArgNames[i], Parent)); Arg.Access := Access; Arg.ArgType := ArgType; - if (i > 0) and Assigned(ArgType) then - ArgType.AddRef; + if Assigned(ArgType) then + begin + ArgType.Parent := Arg; + if (i > 0) then + ArgType.AddRef; + end; Arg.ValueExpr := Value; Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed. Args.Add(Arg); @@ -3712,7 +3809,7 @@ begin ParseExcSyntaxError; end; else - left:=DoParseExpression(nil); + left:=DoParseExpression(Parent); case CurToken of tkAssign, tkAssignPlus, @@ -3723,8 +3820,10 @@ begin // assign statement Ak:=TokenToAssignKind(CurToken); NextToken; - right:=DoParseExpression(nil); // this may solve TPasImplWhileDo.AddElement BUG + right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG el:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock)); + left.Parent:=el; + right.Parent:=el; TPasImplAssign(el).left:=Left; TPasImplAssign(el).right:=Right; TPasImplAssign(el).Kind:=ak; @@ -4253,7 +4352,7 @@ begin Atype.IsForward:=(CurToken=tkSemiColon); if (CurToken=tkBraceOpen) then begin - AType.AncestorType := ParseType(nil); + AType.AncestorType := ParseType(AType); while True do begin NextToken; @@ -4261,7 +4360,7 @@ begin break; UngetToken; ExpectToken(tkComma); - Element:=ParseType(Nil); // search interface. + Element:=ParseType(AType); // search interface. if assigned(element) then AType.Interfaces.add(element); end; @@ -4272,7 +4371,7 @@ begin begin if (CurToken<>tkFor) then ParseExcTokenError(TokenInfos[tkFor]); - AType.HelperForType:=ParseType(Nil); + AType.HelperForType:=ParseType(AType); NextToken; end; if (AType.IsShortDefinition or AType.IsForward) then @@ -4350,6 +4449,96 @@ begin Scanner.CurFilename, Scanner.CurRow); end; +function TPasParser.CreatePrimitiveExpr(AParent: TPasElement; + AKind: TPasExprKind; const AValue: String): TPrimitiveExpr; +begin + Result:=TPrimitiveExpr(CreateElement(TPrimitiveExpr,'',AParent)); + Result.Kind:=AKind; + Result.Value:=AValue; +end; + +function TPasParser.CreateBoolConstExpr(AParent: TPasElement; + AKind: TPasExprKind; const ABoolValue: Boolean): TBoolConstExpr; +begin + Result:=TBoolConstExpr(CreateElement(TBoolConstExpr,'',AParent)); + Result.Kind:=AKind; + Result.Value:=ABoolValue; +end; + +function TPasParser.CreateBinaryExpr(AParent: TPasElement; xleft, + xright: TPasExpr; AOpCode: TExprOpCode): TBinaryExpr; +begin + Result:=TBinaryExpr(CreateElement(TBinaryExpr,'',AParent)); + Result.OpCode:=AOpCode; + Result.Kind:=pekBinary; + if xleft<>nil then + begin + Result.left:=xleft; + xleft.Parent:=Result; + end; + if xright<>nil then + begin + Result.right:=xright; + xright.Parent:=Result; + end; +end; + +procedure TPasParser.AddToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr; + Element: TPasExpr; AOpCode: TExprOpCode); + + procedure RaiseInternal; + begin + raise Exception.Create('TBinaryExpr.AddToChain: internal error'); + end; + +var + Last: TBinaryExpr; +begin + if Element=nil then + exit + else if ChainFirst=nil then + begin + // empty chain => simply add element, no need to create TBinaryExpr + if (ChainLast<>nil) then + RaiseInternal; + ChainFirst:=Element; + ChainLast:=Element; + end + else if ChainLast is TBinaryExpr then + begin + // add a new TBinaryExpr at the end of the chain + Last:=TBinaryExpr(ChainLast); + if (Last.left=nil) or (Last.right=nil) then + // chain not yet full => inconsistency + RaiseInternal; + Last.right:=CreateBinaryExpr(Last,Last.right,Element,AOpCode); + ChainLast:=Last; + end + else + begin + // one element => create a TBinaryExpr with two elements + if ChainFirst<>ChainLast then + RaiseInternal; + ChainLast:=CreateBinaryExpr(ChainLast.Parent,ChainLast,Element,AOpCode); + ChainFirst:=ChainLast; + end; +end; + +function TPasParser.CreateUnaryExpr(AParent: TPasElement; AOperand: TPasExpr; + AOpCode: TExprOpCode): TUnaryExpr; +begin + Result:=TUnaryExpr(CreateElement(TUnaryExpr,'',AParent)); + Result.Kind:=pekUnary; + Result.Operand:=AOperand; + Result.OpCode:=AOpCode; +end; + +function TPasParser.CreateArrayValues(AParent: TPasElement): TArrayValues; +begin + Result:=TArrayValues(CreateElement(TArrayValues,'',AParent)); + Result.Kind:=pekListOfExp; +end; + function TPasParser.CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; UseParentAsResultParent: Boolean): TPasFunctionType; begin @@ -4358,8 +4547,28 @@ begin Scanner.CurFilename,Scanner.CurRow); end; +function TPasParser.CreateInheritedExpr(AParent: TPasElement): TInheritedExpr; +begin + Result:=TInheritedExpr(CreateElement(TInheritedExpr,'',AParent)); + Result.Kind:=pekInherited; +end; +function TPasParser.CreateSelfExpr(AParent: TPasElement): TSelfExpr; +begin + Result:=TSelfExpr(CreateElement(TSelfExpr,'Self',AParent)); + Result.Kind:=pekSelf; +end; -initialization +function TPasParser.CreateNilExpr(AParent: TPasElement): TNilExpr; +begin + Result:=TNilExpr(CreateElement(TNilExpr,'nil',AParent)); + Result.Kind:=pekNil; +end; + +function TPasParser.CreateRecordValues(AParent: TPasElement): TRecordValues; +begin + Result:=TRecordValues(CreateElement(TRecordValues,'',AParent)); + Result.Kind:=pekListOfExp; +end; end. diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index 93b711b8b5..bf7b2c7c95 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -251,7 +251,7 @@ type TStringStreamLineReader = class(TStreamLineReader) Public - constructor Create( const AFilename: string; Const ASource: String); + constructor Create( const AFilename: string; Const ASource: String); reintroduce; end; { TMacroReader } diff --git a/packages/fcl-passrc/tests/tcmoduleparser.pas b/packages/fcl-passrc/tests/tcmoduleparser.pas index e777f84fb0..a18dbc404d 100644 --- a/packages/fcl-passrc/tests/tcmoduleparser.pas +++ b/packages/fcl-passrc/tests/tcmoduleparser.pas @@ -118,7 +118,8 @@ begin StartUnit('unit1'); StartImplementation; ParseUnit; - AssertEquals('No interface units',0,IntfSection.UsesList.Count); + AssertEquals('Only system in interface units',1,IntfSection.UsesList.Count); + CheckUnit(0,'System',IntfSection.UsesList); AssertEquals('No implementation units',0,ImplSection.UsesList.Count); end; @@ -155,7 +156,8 @@ begin ParseUnit; AssertEquals('One implementation units',1,ImplSection.UsesList.Count); CheckUnit(0,'a',ImplSection.UsesList); - AssertEquals('No interface units',0,IntfSection.UsesList.Count); + AssertEquals('Only system in interface units',1,IntfSection.UsesList.Count); + CheckUnit(0,'System',IntfSection.UsesList); end; procedure TTestModuleParser.TestUnitTwoImplUses; @@ -164,10 +166,11 @@ begin StartImplementation; UsesClause(['a','b']); ParseUnit; + AssertEquals('One interface unit',1,IntfSection.UsesList.Count); + CheckUnit(0,'System',IntfSection.UsesList); AssertEquals('Two implementation units',2,ImplSection.UsesList.Count); CheckUnit(0,'a',ImplSection.UsesList); CheckUnit(1,'b',ImplSection.UsesList); - AssertEquals('No interface units',0,IntfSection.UsesList.Count); end; procedure TTestModuleParser.TestEmptyUnitInitialization; diff --git a/packages/fcl-passrc/tests/tcpassrcutil.pas b/packages/fcl-passrc/tests/tcpassrcutil.pas index a4d191840e..0462db7831 100644 --- a/packages/fcl-passrc/tests/tcpassrcutil.pas +++ b/packages/fcl-passrc/tests/tcpassrcutil.pas @@ -5,7 +5,7 @@ unit tcpassrcutil; interface uses - Classes, SysUtils, fpcunit, testutils,passrcutil, testregistry; + Classes, SysUtils, fpcunit,passrcutil, testregistry; type @@ -78,7 +78,7 @@ begin StartImplementation; EndSource; Analyser.GetInterfaceUnits(List); - AssertList('0 interface units',[]); + AssertList('1 interface unit',['System']); end; procedure TPasSrcUtilTest.TestGetImplementationUses; diff --git a/packages/fcl-passrc/tests/tcstatements.pas b/packages/fcl-passrc/tests/tcstatements.pas index 51c577de60..0e8fd4c0a8 100644 --- a/packages/fcl-passrc/tests/tcstatements.pas +++ b/packages/fcl-passrc/tests/tcstatements.pas @@ -1,3 +1,7 @@ +{ + Examples: + ./testpassrc --suite=TTestStatementParser.TestCallQualified2 +} unit tcstatements; {$mode objfpc}{$H+} @@ -382,10 +386,10 @@ begin S:=Statement as TPasImplSimple; AssertExpression('Doit call',S.Expr,pekBinary,TBinaryExpr); B:=S.Expr as TBinaryExpr; - AssertExpression('Unit name',B.Left,pekIdent,'Unita'); - AssertExpression('Doit call',B.Right,pekBinary,TBinaryExpr); - B:=B.Right as TBinaryExpr; - AssertExpression('Unit name',B.Left,pekIdent,'ClassB'); + AssertExpression('Unit name part 1',B.Left,pekIdent,'Unita'); + AssertExpression('Second part of unit name',B.Right,pekBinary,TBinaryExpr); + B:=B.Right as TBinaryExpr; + AssertExpression('Unit name part 2',B.Left,pekIdent,'ClassB'); AssertExpression('Doit call',B.Right,pekIdent,'Doit'); end; @@ -979,9 +983,6 @@ procedure TTestStatementParser.TestCaseOtherwiseBlockEmpty; Var C : TPasImplCaseOf; - S : TPasImplCaseStatement; - B : TPasImplbeginBlock; - begin DeclareVar('integer'); TestStatement(['case a of','1 : begin end;','otherwise',' end;']); diff --git a/packages/fcl-passrc/tests/tctypeparser.pas b/packages/fcl-passrc/tests/tctypeparser.pas index 9f31a94bfa..6eb25787b4 100644 --- a/packages/fcl-passrc/tests/tctypeparser.pas +++ b/packages/fcl-passrc/tests/tctypeparser.pas @@ -114,6 +114,7 @@ type Procedure TestStaticArrayTypedIndex; Procedure TestDynamicArray; Procedure TestDynamicArrayComment; + Procedure TestGenericArray; Procedure TestSimpleEnumerated; Procedure TestSimpleEnumeratedComment; Procedure TestSimpleEnumeratedComment2; @@ -2837,6 +2838,20 @@ begin AssertComment; end; +procedure TTestTypeParser.TestGenericArray; +begin + Add('Type'); + Add('generic TArray = array of T;'); +// Writeln(source.text); + ParseDeclarations; + AssertEquals('One type definition',1,Declarations.Types.Count); + AssertEquals('First declaration is type definition.',TPasArrayType,TObject(Declarations.Types[0]).ClassType); + AssertEquals('First declaration has correct name.','TArray',TPasType(Declarations.Types[0]).Name); + FType:=TPasType(Declarations.Types[0]); + AssertEquals('Array type','',TPasArrayType(TheType).IndexRange); + AssertEquals('Generic Array type',True,TPasArrayType(TheType).IsGenericArray); +end; + procedure TTestTypeParser.TestSimpleEnumerated; begin diff --git a/packages/fcl-passrc/tests/testpassrc.lpi b/packages/fcl-passrc/tests/testpassrc.lpi index 1d615d2902..c5e03a830f 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpi +++ b/packages/fcl-passrc/tests/testpassrc.lpi @@ -30,7 +30,7 @@ - +