From f368c848a5ca0f82c162eace5278b2b904d9e844 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 09:01:06 +0000 Subject: [PATCH 01/21] sql parser: support table with schema git-svn-id: trunk@46419 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 9 +++- packages/fcl-db/src/sql/fpsqltree.pp | 66 ++++++++++++++++++++++--- packages/fcl-db/tests/tcparser.pas | 12 +++++ 3 files changed, 80 insertions(+), 7 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 6e4d16b0a9..29eb37573f 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -345,8 +345,15 @@ begin Expect(tsqlIdentifier); T:=TSQLSimpleTableReference(CreateElement(TSQLSimpleTableReference,AParent)); Result:=T; - T.ObjectName:=CreateIdentifier(T,CurrentTokenString); + T.AddObjectNameToPath(CreateIdentifier(T,CurrentTokenString)); GetNextToken; + while CurrentToken=tsqlDOT do + begin + GetNextToken; + Expect(tsqlIdentifier); + T.AddObjectNameToPath(CreateIdentifier(T,CurrentTokenString)); + GetNextToken; + end; If CurrentToken=tsqlBraceOpen then begin T.Params:=ParseValueList(AParent,[eoParamValue]); diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index a70b82e522..41ece3ad5b 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -607,12 +607,20 @@ Type TSQLSimpleTableReference = Class(TSQLTableReference) private FAliasName: TSQLIdentifierName; - FObjectName: TSQLIdentifierName; + FObjectNamePath: array of TSQLIdentifierName; FParams: TSQLElementList; + function GetObjectName: TSQLIdentifierName; + function GetObjectNamePath(Index: Integer): TSQLIdentifierName; + function GetObjectNamePathCount: Integer; + procedure SetObjectName(const AName: TSQLIdentifierName); Public Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; - Property ObjectName : TSQLIdentifierName Read FObjectName Write FObjectName; + Property ObjectName : TSQLIdentifierName Read GetObjectName Write SetObjectName; + Property ObjectNamePathCount: Integer Read GetObjectNamePathCount; + Procedure AddObjectNameToPath(AName: TSQLIdentifierName); + Procedure ClearObjectNamePath; + Property ObjectNamePath[Index: Integer] : TSQLIdentifierName Read GetObjectNamePath; Property Params : TSQLElementList Read FParams Write FParams; Property AliasName : TSQLIdentifierName Read FAliasName Write FAliasName; end; @@ -3073,9 +3081,24 @@ end; { TSQLSimpleTableReference } +procedure TSQLSimpleTableReference.AddObjectNameToPath(AName: TSQLIdentifierName); +begin + SetLength(FObjectNamePath, Length(FObjectNamePath)+1); + FObjectNamePath[High(FObjectNamePath)] := AName; +end; + +procedure TSQLSimpleTableReference.ClearObjectNamePath; +var + N: TSQLIdentifierName; +begin + for N in FObjectNamePath do + N.Free; + FObjectNamePath := nil; +end; + destructor TSQLSimpleTableReference.Destroy; begin - FreeAndNil(FObjectName); + ClearObjectNamePath; FreeAndNil(FParams); FreeAndNil(FAliasName); inherited Destroy; @@ -3085,7 +3108,8 @@ function TSQLSimpleTableReference.GetAsSQL(Options: TSQLFormatOptions; AIndent : Var I : integer; - + TableName: TSQLStringType; + N: TSQLIdentifierName; begin Result:=''; If Assigned(FParams) and (FParams.Count>0) then @@ -3098,12 +3122,42 @@ begin end; Result:='('+Result+')'; end; - If Assigned(FObjectname) then - Result:= FObjectName.GetAsSQL(Options)+Result; + TableName := ''; + for N in FObjectNamePath do + begin + if TableName<>'' then + TableName:=TableName+'.'; + TableName:=TableName+N.GetAsSQL(Options); + end; + Result:= TableName+Result; if Assigned(FAliasName) then Result:=Result+' '+FAliasName.GetAsSQL(Options); end; +function TSQLSimpleTableReference.GetObjectName: TSQLIdentifierName; +begin + if Length(FObjectNamePath)>0 then + Result := FObjectNamePath[High(FObjectNamePath)] + else + Result := nil; +end; + +function TSQLSimpleTableReference.GetObjectNamePath(Index: Integer): TSQLIdentifierName; +begin + Result := FObjectNamePath[Index]; +end; + +function TSQLSimpleTableReference.GetObjectNamePathCount: Integer; +begin + Result := Length(FObjectNamePath); +end; + +procedure TSQLSimpleTableReference.SetObjectName(const AName: TSQLIdentifierName); +begin + ClearObjectNamePath; + AddObjectNameToPath(AName); +end; + { TSQLJoinTableReference } destructor TSQLJoinTableReference.Destroy; diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index b55b34b68e..483097ed81 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -411,6 +411,7 @@ type procedure TestSelectTwoFieldsThreeTablesJoin; procedure TestSelectTwoFieldsBracketThreeTablesJoin; procedure TestSelectTwoFieldsThreeBracketTablesJoin; + procedure TestSelectTableWithSchema; procedure TestAggregateCount; procedure TestAggregateCountAsterisk; procedure TestAggregateCountAll; @@ -3811,6 +3812,17 @@ begin AssertTable(Select.Tables[0],'A'); end; +procedure TTestSelectParser.TestSelectTableWithSchema; +begin + TestSelect('SELECT B,C FROM S.A'); + AssertField(Select.Fields[0],'B'); + AssertField(Select.Fields[1],'C'); + AssertEquals('One table',1,Select.Tables.Count); + AssertTable(Select.Tables[0],'A',''); + AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePathCount); + AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); +end; + procedure TTestSelectParser.TestSelectOneDistinctFieldOneTable; begin TestSelect('SELECT DISTINCT B FROM A'); From 49f1d08467bd7d5bb8251965de26aa6e148ddc2c Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 09:03:43 +0000 Subject: [PATCH 02/21] sql parser: change Functions to Properties for better debugging git-svn-id: trunk@46420 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 29eb37573f..ebbf30dd6b 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -169,8 +169,8 @@ Type Function ParseScript(AllowPartial : Boolean) : TSQLElementList; deprecated 'use options'; Function ParseScript(aOptions : TParserOptions = []) : TSQLElementList; // Auxiliary stuff - Function CurrentToken : TSQLToken; - Function CurrentTokenString : String; + Property CurrentToken : TSQLToken read FCurrent; + Property CurrentTokenString : String read FCurrentString; // Gets next token; also updates current token Function GetNextToken : TSQLToken; // Looks at next token without changing current token @@ -4062,16 +4062,6 @@ begin end; end; -function TSQLParser.CurrentToken: TSQLToken; -begin - Result:=FCurrent; -end; - -function TSQLParser.CurrentTokenString: String; -begin - Result:=FCurrentString; -end; - function TSQLParser.GetNextToken: TSQLToken; begin FPrevious:=FCurrent; From 97ced59af04004398a4a4688c082089a7cf05063 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 10:06:33 +0000 Subject: [PATCH 03/21] sql parser: support field with schema git-svn-id: trunk@46421 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 11 +++-- packages/fcl-db/src/sql/fpsqltree.pp | 64 +++++++++++++++++++++++-- packages/fcl-db/tests/tcparser.pas | 51 ++++++++++++++++++-- 3 files changed, 111 insertions(+), 15 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index ebbf30dd6b..6ff0079ac2 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -2757,16 +2757,17 @@ begin begin If (eoCheckConstraint in EO) and not (eoTableConstraint in EO) then Error(SErrUnexpectedToken,[CurrentTokenString]); - If (CurrentToken=tsqlDot) then + // Plain identifier + Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent)); + TSQLIdentifierExpression(Result).AddIdentifierToPath(CreateIdentifier(Result,N)); + while (CurrentToken=tsqlDot) do begin GetNextToken; Expect(tsqlIdentifier); - N:=N+'.'+CurrentTokenString; + N:=CurrentTokenString; + TSQLIdentifierExpression(Result).AddIdentifierToPath(CreateIdentifier(Result,N)); GetNextToken; end; - // Plain identifier - Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent)); - TSQLIdentifierExpression(Result).Identifier:=CreateIdentifier(Result,N); // Array access ? If (CurrentToken=tsqlSquareBraceOpen) then // Either something like array[5] or, diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index 41ece3ad5b..2eef489b95 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -188,12 +188,20 @@ Type TSQLIdentifierExpression = Class(TSQLExpression) private FElementIndex: Integer; - FIdentifier: TSQLIdentifierName; + FIdentifierPath: array of TSQLIdentifierName; + function GetIdentifier: TSQLIdentifierName; + function GetIdentifierPath(Index: Integer): TSQLIdentifierName; + function GetIdentifierPathCount: Integer; + procedure SetIdentifier(const AName: TSQLIdentifierName); Public Constructor Create(AParent : TSQLElement); override; Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; - Property Identifier : TSQLIdentifierName Read FIdentifier Write FIdentifier; + Property Identifier : TSQLIdentifierName Read GetIdentifier Write SetIdentifier; + Property IdentifierPathCount: Integer Read GetIdentifierPathCount; + Procedure AddIdentifierToPath(AName: TSQLIdentifierName); + Procedure ClearIdentifierPath; + Property IdentifierPath[Index: Integer] : TSQLIdentifierName Read GetIdentifierPath; // For array types: index of element in array Property ElementIndex : Integer Read FElementIndex Write FElementIndex; end; @@ -4149,20 +4157,66 @@ begin FElementIndex:=-1; end; +procedure TSQLIdentifierExpression.AddIdentifierToPath(AName: TSQLIdentifierName); +begin + SetLength(FIdentifierPath, Length(FIdentifierPath)+1); + FIdentifierPath[High(FIdentifierPath)] := AName; +end; + +procedure TSQLIdentifierExpression.ClearIdentifierPath; +var + N: TSQLIdentifierName; +begin + for N in FIdentifierPath do + N.Free; + FIdentifierPath:=nil; +end; + destructor TSQLIdentifierExpression.Destroy; begin - FreeAndNil(FIdentifier); + ClearIdentifierPath; inherited Destroy; end; function TSQLIdentifierExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; +var + N: TSQLIdentifierName; begin - If Assigned(FIdentifier) then - Result:= Identifier.GetAsSQL(Options); + Result := ''; + for N in FIdentifierPath do + begin + if Result<>'' then + Result:=Result+'.'; + Result:=Result+N.GetAsSQL(Options); + end; If (ElementIndex<>-1) then Result:=Result+Format('[%d]',[Elementindex]); end; +function TSQLIdentifierExpression.GetIdentifier: TSQLIdentifierName; +begin + if Length(FIdentifierPath)>0 then + Result:=FIdentifierPath[High(FIdentifierPath)] + else + Result:=nil; +end; + +function TSQLIdentifierExpression.GetIdentifierPath(Index: Integer): TSQLIdentifierName; +begin + Result := FIdentifierPath[Index]; +end; + +function TSQLIdentifierExpression.GetIdentifierPathCount: Integer; +begin + Result := Length(FIdentifierPath); +end; + +procedure TSQLIdentifierExpression.SetIdentifier(const AName: TSQLIdentifierName); +begin + ClearIdentifierPath; + AddIdentifierToPath(AName); +end; + { TSQLSelectExpression } function TSQLSelectExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 483097ed81..7b4133dace 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -412,6 +412,7 @@ type procedure TestSelectTwoFieldsBracketThreeTablesJoin; procedure TestSelectTwoFieldsThreeBracketTablesJoin; procedure TestSelectTableWithSchema; + procedure TestSelectFieldWithSchema; procedure TestAggregateCount; procedure TestAggregateCountAsterisk; procedure TestAggregateCountAll; @@ -3737,6 +3738,26 @@ begin AssertException(ESQLParser,@TestParseError); end; +procedure TTestSelectParser.TestSelectFieldWithSchema; + +Var + Expr: TSQLIdentifierExpression; + +begin + TestSelect('SELECT S.A.B,C FROM S.A'); + AssertEquals('Two fields',2,Select.Fields.Count); + AssertField(Select.Fields[0],'B'); + Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); + AssertEquals('Field[0] path has 3 identifiers',3,Expr.IdentifierPathCount); + AssertEquals('Field[0] schema is S','S',Expr.IdentifierPath[0].Name); + AssertEquals('Field[0] table is A','A',Expr.IdentifierPath[1].Name); + AssertField(Select.Fields[1],'C'); + AssertEquals('One table',1,Select.Tables.Count); + AssertTable(Select.Tables[0],'A',''); + AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePathCount); + AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); +end; + procedure TTestSelectParser.TestSelectOneFieldOneTable; begin TestSelect('SELECT B FROM A'); @@ -3802,12 +3823,17 @@ end; procedure TTestSelectParser.TestSelectOneTableFieldOneTable; +Var + Expr: TSQLIdentifierExpression; + begin TestSelect('SELECT A.B FROM A'); AssertEquals('One field',1,Select.Fields.Count); - // Field does not support linking/refering to a table, so the field name is - // assigned as A.B (instead of B with a ) - AssertField(Select.Fields[0],'A.B'); + // Field supports linking/refering to a table + AssertField(Select.Fields[0],'B'); + Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); + AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table named A','A',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); end; @@ -3815,6 +3841,7 @@ end; procedure TTestSelectParser.TestSelectTableWithSchema; begin TestSelect('SELECT B,C FROM S.A'); + AssertEquals('Two fields',2,Select.Fields.Count); AssertField(Select.Fields[0],'B'); AssertField(Select.Fields[1],'C'); AssertEquals('One table',1,Select.Tables.Count); @@ -3863,19 +3890,33 @@ begin end; procedure TTestSelectParser.TestSelectOneFieldOneTableAlias; + +Var + Expr: TSQLIdentifierExpression; + begin TestSelect('SELECT C.B FROM A C'); AssertEquals('One field',1,Select.Fields.Count); - AssertField(Select.Fields[0],'C.B'); + AssertField(Select.Fields[0],'B'); + Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); + AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table named C','C',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); end; procedure TTestSelectParser.TestSelectOneFieldOneTableAsAlias; + +Var + Expr: TSQLIdentifierExpression; + begin TestSelect('SELECT C.B FROM A AS C'); AssertEquals('One field',1,Select.Fields.Count); - AssertField(Select.Fields[0],'C.B'); + AssertField(Select.Fields[0],'B'); + Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); + AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table named C','C',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); end; From 67d2c51b8d0cdbeda377a687444a4bea9498eb06 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 10:15:40 +0000 Subject: [PATCH 04/21] sql parser: add test for SQL generation of fields with path git-svn-id: trunk@46422 - --- packages/fcl-db/tests/tcgensql.pas | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/packages/fcl-db/tests/tcgensql.pas b/packages/fcl-db/tests/tcgensql.pas index a2faffc875..0034ec96a3 100644 --- a/packages/fcl-db/tests/tcgensql.pas +++ b/packages/fcl-db/tests/tcgensql.pas @@ -64,6 +64,7 @@ type Procedure TestValueLiteral; Procedure TestLiteralExpression; Procedure TestSelectField; + Procedure TestSelectFieldWithPath; Procedure TestSimpleTablereference; Procedure TestSimpleSelect; Procedure TestAnyExpression; @@ -416,6 +417,24 @@ begin AssertSQL(F,'A AS B'); end; +procedure TTestGenerateSQL.TestSelectFieldWithPath; + +Var + I : TSQLIdentifierExpression; + F : TSQLSelectField; + +begin + I:=CreateIdentifierExpression('A'); + I.AddIdentifierToPath(CreateIdentifier('B')); + I.AddIdentifierToPath(CreateIdentifier('C')); + F:=CreateSelectField(I,''); + AssertSQL(F,'A.B.C', []); + AssertSQL(F,'"A"."B"."C"',[sfoDoubleQuoteIdentifier]); + AssertSQL(F,'`A`.`B`.`C`',[sfoBackQuoteIdentifier]); + AssertSQL(F,'''A''.''B''.''C''',[sfoSingleQuoteIdentifier]); + FTofree:=F; +end; + procedure TTestGenerateSQL.TestSimpleTablereference; Var From 2c545f3afe8e1c9fea8b016fb7e86cfe0d8aa9d1 Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 14 Aug 2020 10:24:24 +0000 Subject: [PATCH 05/21] * Patch from Henrique Werlang to improve generation of IsImpl (bug ID 37510) git-svn-id: trunk@46423 - --- packages/fcl-passrc/src/paswrite.pp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/fcl-passrc/src/paswrite.pp b/packages/fcl-passrc/src/paswrite.pp index e3a9ea6687..a6c177f1ac 100644 --- a/packages/fcl-passrc/src/paswrite.pp +++ b/packages/fcl-passrc/src/paswrite.pp @@ -906,7 +906,7 @@ Var begin - IsImpl:=AProc.Parent is TPasSection; + IsImpl:=AProc.Parent is TImplementationSection; if IsImpl then PrepareDeclSection(''); if Not IsImpl then @@ -928,7 +928,7 @@ begin Add(' reintroduce;'); // if NamePrefix is not empty, we're writing a dummy for external class methods. // In that case, we must not write the 'overload'. - if AProc.IsOverload and (NamePrefix='') then + if AProc.IsOverload and (NamePrefix='') and not IsImpl then Add(' overload;'); if not IsImpl then begin From 0ca6707e95661bb73a6517c2bd11f197478ead24 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 10:32:37 +0000 Subject: [PATCH 06/21] sql parser: support []-identifiers git-svn-id: trunk@46424 - --- packages/fcl-db/src/sql/fpsqlscanner.pp | 17 ++++++++++++++--- packages/fcl-db/tests/tcsqlscanner.pas | 10 +++++++++- 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlscanner.pp b/packages/fcl-db/src/sql/fpsqlscanner.pp index d314876169..c37559afe9 100644 --- a/packages/fcl-db/src/sql/fpsqlscanner.pp +++ b/packages/fcl-db/src/sql/fpsqlscanner.pp @@ -161,7 +161,8 @@ Type soNoDoubleDelimIsChar, soDoubleQuoteStringLiteral, // Default: single quote is string literal soSingleQuoteIdentifier, // Default: double quote is identifier. Ignored if soDoubleQuoteStringLiteral is not specified - soBackQuoteIdentifier // Default: double quote is identifier + soBackQuoteIdentifier, // Default: double quote is identifier + soSquareBracketsIdentifier // Default: square brackets are not supported. (Enable for MSSQL support.) ); TSQLScannerOptions = Set of TSQLScannerOption; @@ -513,6 +514,8 @@ Var begin Delim:=TokenStr[0]; + if Delim='[' then + Delim:=']'; Inc(TokenStr); TokenStart := TokenStr; OLen := 0; @@ -792,8 +795,16 @@ begin end; '[': begin - Inc(TokenStr); - Result := tsqlSquareBraceOpen; + If (soSquareBracketsIdentifier in options) then + begin + Result:=DoStringLiteral; + Result:=tsqlIdentifier; + end + Else + begin + Inc(TokenStr); + Result := tsqlSquareBraceOpen; + end; end; ']': begin diff --git a/packages/fcl-db/tests/tcsqlscanner.pas b/packages/fcl-db/tests/tcsqlscanner.pas index a6e11099b0..f1b6cf7ee0 100644 --- a/packages/fcl-db/tests/tcsqlscanner.pas +++ b/packages/fcl-db/tests/tcsqlscanner.pas @@ -235,6 +235,7 @@ type procedure TestIdentifier3; procedure TestIdentifier4; procedure TestIdentifier5; + procedure TestIdentifier6; procedure TestIdentifierDotIdentifier; procedure TestEOLN; procedure TestEOLN2; @@ -1382,7 +1383,7 @@ begin CheckToken(tsqlSequence,'sequence'); end; -procedure TTestSQLScanner.CheckTokens(ASource : String; ATokens : Array of TSQLToken); +procedure TTestSQLScanner.CheckTokens(ASource: String; ATokens: array of TSQLToken); Var I : Integer; @@ -1440,6 +1441,13 @@ begin CheckToken(tsqlSymbolString,'$0'); end; +procedure TTestSQLScanner.TestIdentifier6; +begin + CreateScanner('[A]',[soSquareBracketsIdentifier]); + AssertEquals('Identifier is returned',tsqlIdentifier,FScanner.FetchToken); + AssertEquals('Correct identifier','A',FScanner.CurTokenString); +end; + procedure TTestSQLScanner.TestIdentifierDotIdentifier; begin CheckTokens('something.different',[tsqlIdentifier,tsqldot,tsqlIdentifier]); From dfca0bf9c8fdcd5d247c5c40a4ae8a6e491b832d Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 14 Aug 2020 10:33:07 +0000 Subject: [PATCH 07/21] * Improved exception handling, patch by Henrique Werlang (bug ID 37567) git-svn-id: trunk@46425 - --- utils/pas2js/libstub.pp | 10 +--------- utils/pas2js/stubcreator.pp | 10 +++++----- 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/utils/pas2js/libstub.pp b/utils/pas2js/libstub.pp index ae87c46c02..f8d3a9eb1f 100644 --- a/utils/pas2js/libstub.pp +++ b/utils/pas2js/libstub.pp @@ -123,15 +123,7 @@ end; Function ExecuteStubCreator(P : PStubCreator) : Boolean; stdcall; begin - Result:=False; - try - TStubCreator(P).Execute; - Result:=True; - except - On E: Exception do - Writeln('Exception ',E.ClassName,' ',E.Message); - // Ignore - end; + Result:=TStubCreator(P).Execute; end; Procedure GetStubCreatorLastError(P : PStubCreator; AError : PAnsiChar; diff --git a/utils/pas2js/stubcreator.pp b/utils/pas2js/stubcreator.pp index 7816db2caf..f4a71ca437 100644 --- a/utils/pas2js/stubcreator.pp +++ b/utils/pas2js/stubcreator.pp @@ -75,7 +75,7 @@ type Public Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; - Procedure Execute; + Function Execute: Boolean; Procedure GetLastError(Out AError,AErrorClass : String); // Streams take precedence over filenames. They will be freed on destroy! // OutputStream can be used combined with write callbacks. @@ -202,22 +202,22 @@ begin Include(O,woForwardClasses); end; -procedure TStubCreator.Execute; - - +function TStubCreator.Execute: Boolean; begin FLastErrorClass:=''; FLastError:=''; + Result := False; if Defines.IndexOf('MakeStub')=-1 then Try DoExecute; + + Result := True; except On E : Exception do begin FLastErrorClass:=E.Classname; FLastError:=E.Message; - Raise; end; end; end; From 6caf046df2e50fdd173502bc7d518e220cddeff5 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 12:35:20 +0000 Subject: [PATCH 08/21] sql parser: support LIMIT for FireBird/MSSQL/Postgres/MySQL git-svn-id: trunk@46426 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 66 +++++++++++++++++++ packages/fcl-db/src/sql/fpsqlscanner.pp | 16 ++--- packages/fcl-db/src/sql/fpsqltree.pp | 49 +++++++++++++++ packages/fcl-db/tests/tcgensql.pas | 28 +++++++++ packages/fcl-db/tests/tcparser.pas | 84 +++++++++++++++++++++++++ 5 files changed, 235 insertions(+), 8 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 6ff0079ac2..dda2998934 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -126,6 +126,7 @@ Type procedure ParseFromClause(AParent: TSQLSelectStatement; AList: TSQLElementList); procedure ParseGroupBy(AParent: TSQLSelectStatement; AList: TSQLElementList); procedure ParseOrderBy(AParent: TSQLSelectStatement; AList: TSQLElementList); + procedure ParseLimit(AParent: TSQLSelectStatement; ALimit: TSQLSelectLimit); procedure ParseSelectFieldList(AParent: TSQLSelectStatement; AList: TSQLElementList; Singleton : Boolean); function ParseForUpdate(AParent: TSQLSelectStatement): TSQLElementList; function ParseSelectPlan(AParent: TSQLElement): TSQLSelectPlan; @@ -436,6 +437,29 @@ begin GetNextToken; If B then begin + if (CurrentToken=tsqlTop) then + begin + GetNextToken; + Expect(tsqlIntegerNumber); + AParent.Limit.Style := lsMSSQL; + AParent.Limit.Top := StrToInt(CurrentTokenString); + GetNextToken; + end; + if (CurrentToken=tsqlFIRST) then + begin + GetNextToken; + Expect(tsqlIntegerNumber); + AParent.Limit.Style := lsFireBird; + AParent.Limit.First := StrToInt(CurrentTokenString); + GetNextToken; + if (CurrentToken=tsqlSKIP) then + begin + GetNextToken; + Expect(tsqlIntegerNumber); + AParent.Limit.Skip := StrToInt(CurrentTokenString); + GetNextToken; + end; + end; if (CurrentToken=tsqlDistinct) then begin AParent.Distinct:=True; @@ -721,6 +745,8 @@ begin begin if (CurrentToken=tsqlOrder) then ParseOrderBy(Result,Result.OrderBy); + if CurrentToken in [tsqlLimit,tsqlOFFSET] then + ParseLimit(Result,Result.Limit); if (CurrentToken=tsqlFOR) then Result.ForUpdate:=ParseForUpdate(Result); end; @@ -1319,6 +1345,46 @@ begin Until (CurrentToken<>tsqlComma); end; +procedure TSQLParser.ParseLimit(AParent: TSQLSelectStatement; ALimit: TSQLSelectLimit); + + procedure DoOffset; + begin + if CurrentToken=tsqlOFFSET then + begin + GetNextToken; + Expect(tsqlIntegerNumber); + ALimit.Offset := StrToInt(CurrentTokenString); + GetNextToken; + end; + end; +begin + ALimit.Style:=lsPostgres; + if CurrentToken=tsqlLIMIT then + begin + GetNextToken; + if CurrentToken=tsqlALL then + ALimit.RowCount := -1 + else + begin + Expect(tsqlIntegerNumber); + ALimit.RowCount := StrToInt(CurrentTokenString); + end; + GetNextToken; + if CurrentToken=tsqlCOMMA then + begin + GetNextToken; + Expect(tsqlIntegerNumber); + ALimit.Offset := ALimit.RowCount; + ALimit.RowCount := StrToInt(CurrentTokenString); + GetNextToken; + end + else + DoOffset; + end + else + DoOffset; +end; + function TSQLParser.ParseForStatement(AParent: TSQLElement): TSQLForStatement; begin diff --git a/packages/fcl-db/src/sql/fpsqlscanner.pp b/packages/fcl-db/src/sql/fpsqlscanner.pp index c37559afe9..f335340eb4 100644 --- a/packages/fcl-db/src/sql/fpsqlscanner.pp +++ b/packages/fcl-db/src/sql/fpsqlscanner.pp @@ -54,20 +54,20 @@ type tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString, tsqlDESC, tsqlDESCENDING, tsqlDISTINCT, tsqlDEFAULT, tsqlDELETE, tsqlDO, tsqlDouble, tsqlDECLARE, tsqlDROP, tsqlDomain, tsqlDecimal, tsqlDate,tsqlDatabase, tsqlESCAPE, tsqlEXISTS, tsqlELSE, tsqlException, tsqlExternal, tsqlExecute, tsqlEnd,tsqlExit,tsqlEntrypoint,tsqlExtract, - tsqlFROM, tsqlFULL, tsqlFOREIGN, tsqlFOR, tsqlFUNCTION, tsqlFLOAT, tsqlFile,tsqlFreeIt, + tsqlFIRST, tsqlFROM, tsqlFULL, tsqlFOREIGN, tsqlFOR, tsqlFUNCTION, tsqlFLOAT, tsqlFile,tsqlFreeIt, tsqlGenerator, tsqlGROUP, tsqlGenID,tsqlGDSCODE,tsqlGrant, tsqlHAVING, tsqlIF, tsqlIN, tsqlINNER, tsqlINSERT, tsqlINT, tsqlINTEGER, tsqlINTO, tsqlIS, tsqlINDEX, tsqlInactive, tsqlJOIN, tsqlKEY, - tsqlLEFT, tsqlLIKE, tsqlLength, + tsqlLEFT, tsqlLIKE, tsqlLIMIT, tsqlLength, tsqlMAX, tsqlMIN, tsqlMERGE, tsqlManual, tsqlModuleName, tsqlNOT, tsqlNULL, tsqlNUMERIC , tsqlNChar, tsqlNATIONAL,tsqlNO, tsqlNatural, - tsqlOFF {not an FB reserved word; used in isql scripts}, tsqlON, tsqlOR, tsqlORDER, tsqlOUTER, tsqlOption, + tsqlOFF {not an FB reserved word; used in isql scripts}, tsqlOFFSET, tsqlON, tsqlOR, tsqlORDER, tsqlOUTER, tsqlOption, tsqlPrecision, tsqlPRIMARY, tsqlProcedure, tsqlPosition, tsqlPlan, tsqlPassword, tsqlPage,tsqlPages,tsqlPageSize,tsqlPostEvent,tsqlPrivileges,tsqlPublic, tsqlRIGHT, tsqlROLE, tsqlReferences, tsqlRollBack, tsqlRelease, tsqlretain, tsqlReturningValues,tsqlReturns, tsqlrevoke, tsqlSELECT, tsqlSET, tsqlSINGULAR, tsqlSOME, tsqlSTARTING, tsqlSUM, tsqlSKIP,tsqlSUBTYPE,tsqlSize,tsqlSegment, tsqlSORT, tsqlSnapShot,tsqlSchema,tsqlShadow,tsqlSuspend,tsqlSQLCode,tsqlSmallint, - tSQLTABLE, tsqlText, tsqlTrigger, tsqlTime, tsqlTimeStamp, tsqlType, tsqlTo, tsqlTransaction, tsqlThen, + tSQLTABLE, tsqlText, tsqlTrigger, tsqlTime, tsqlTimeStamp, tsqlType, tsqlTo, tsqlTop, tsqlTransaction, tsqlThen, tsqlUNION, tsqlUPDATE, tsqlUPPER, tsqlUNIQUE, tsqlUSER, tsqlValue, tsqlVALUES, tsqlVARIABLE, tsqlVIEW, tsqlVARCHAR,TSQLVARYING, tsqlWHERE, tsqlWITH, tsqlWHILE, tsqlWork, tsqlWhen,tsqlSequence,tsqlRestart,tsqlrecreate,tsqlterm @@ -100,20 +100,20 @@ const 'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING', 'DESC', 'DESCENDING', 'DISTINCT', 'DEFAULT', 'DELETE', 'DO', 'DOUBLE', 'DECLARE', 'DROP', 'DOMAIN', 'DECIMAL', 'DATE','DATABASE', 'ESCAPE', 'EXISTS', 'ELSE', 'EXCEPTION', 'EXTERNAL','EXECUTE', 'END','EXIT','ENTRY_POINT','EXTRACT', - 'FROM', 'FULL','FOREIGN', 'FOR', 'FUNCTION', 'FLOAT','FILE', 'FREE_IT', + 'FIRST', 'FROM', 'FULL','FOREIGN', 'FOR', 'FUNCTION', 'FLOAT','FILE', 'FREE_IT', 'GENERATOR', 'GROUP', 'GEN_ID','GDSCODE','GRANT', 'HAVING', 'IF', 'IN', 'INNER', 'INSERT', 'INT', 'INTEGER', 'INTO', 'IS', 'INDEX', 'INACTIVE', 'JOIN', 'KEY', - 'LEFT', 'LIKE', 'LENGTH', + 'LEFT', 'LIKE', 'LIMIT', 'LENGTH', 'MAX', 'MIN', 'MERGE', 'MANUAL', 'MODULE_NAME', 'NOT', 'NULL', 'NUMERIC','NCHAR','NATIONAL', 'NO', 'NATURAL', - 'OFF', 'ON', 'OR', 'ORDER', 'OUTER', 'OPTION', + 'OFF', 'OFFSET', 'ON', 'OR', 'ORDER', 'OUTER', 'OPTION', 'PRECISION', 'PRIMARY', 'PROCEDURE','POSITION','PLAN', 'PASSWORD','PAGE','PAGES','PAGE_SIZE','POST_EVENT','PRIVILEGES','PUBLIC', 'RIGHT', 'ROLE', 'REFERENCES', 'ROLLBACK','RELEASE', 'RETAIN', 'RETURNING_VALUES', 'RETURNS','REVOKE', 'SELECT', 'SET', 'SINGULAR', 'SOME', 'STARTING', 'SUM', 'SKIP','SUB_TYPE', 'SIZE', 'SEGMENT', 'SORT', 'SNAPSHOT','SCHEMA','SHADOW','SUSPEND','SQLCODE','SMALLINT', - 'TABLE', 'TEXT', 'TRIGGER', 'TIME', 'TIMESTAMP', 'TYPE', 'TO', 'TRANSACTION', 'THEN', + 'TABLE', 'TEXT', 'TRIGGER', 'TIME', 'TIMESTAMP', 'TYPE', 'TO', 'TOP', 'TRANSACTION', 'THEN', 'UNION', 'UPDATE', 'UPPER', 'UNIQUE', 'USER', 'VALUE','VALUES','VARIABLE', 'VIEW','VARCHAR','VARYING', 'WHERE', 'WITH', 'WHILE','WORK','WHEN','SEQUENCE','RESTART','RECREATE','TERM' diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index 2eef489b95..0c1ee50c0f 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -726,11 +726,32 @@ Type Property OrderBy : TSQLOrderDirection Read FOrderBy write FOrderBy; end; + { TSQLSelectLimit } + + TSQLSelectLimitStyle = (lsNone, lsFireBird, lsMSSQL, lsPostgres{lsMySQL}); + + TSQLSelectLimit = Class + private + FRowCount: Integer; + FSkip: Integer; + FStyle: TSQLSelectLimitStyle; + public + constructor Create; + public + property Style: TSQLSelectLimitStyle read FStyle write FStyle; + property First: Integer read FRowCount write FRowCount; // lsFireBird + property Skip: Integer read FSkip write FSkip; // lsFireBird + property Top: Integer read FRowCount write FRowCount; // lsMSSQL + property RowCount: Integer read FRowCount write FRowCount; // lsPostgres + property Offset: Integer read FSkip write FSkip; // lsPostgres + end; + { TSQLSelectStatement } TSQLSelectStatement = Class(TSQLDMLStatement) private FAll: Boolean; + FLimit: TSQLSelectLimit; FDistinct: Boolean; FEndAt: TSQLExpression; FFields: TSQLElementList; @@ -760,6 +781,7 @@ Type Property ForUpdate : TSQLElementList Read FForUpdate Write FForUpdate; Property Union : TSQLSelectStatement Read FUnion Write FUnion; Property Plan : TSQLSelectPlan Read FPlan Write FPlan; + Property Limit: TSQLSelectLimit Read FLimit; Property Distinct : Boolean Read FDistinct Write FDistinct; Property All : Boolean Read FAll Write FAll; Property UnionAll : Boolean Read FUnionAll Write FUnionAll; @@ -1915,6 +1937,15 @@ begin Sep:=', '; end; +{ TSQLSelectLimit } + +constructor TSQLSelectLimit.Create; +begin + inherited Create; + FSkip:=-1; + FRowCount:=-1; +end; + { TSQLSetTermStatement } function TSQLSetTermStatement.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; @@ -1994,6 +2025,7 @@ begin FTables:=TSQLElementList.Create(True); FGroupBy:=TSQLElementList.Create(True); FOrderBy:=TSQLElementList.Create(True); + FLimit:=TSQLSelectLimit.Create; end; destructor TSQLSelectStatement.Destroy; @@ -2011,6 +2043,7 @@ begin FreeAndNil(FForUpdate); FreeAndNil(FTN); FreeAndNil(FInto); + FreeAndNil(FLimit); inherited Destroy; end; @@ -2078,6 +2111,15 @@ Var begin Result:=SQLKeyWord('SELECT',Options); + If Limit.Style=lsMSSQL then + Result:=Result+' '+SQLKeyword('TOP',Options)+' '+IntToStr(Limit.Top) + else + If Limit.Style=lsFireBird then + begin + Result:=Result+' '+SQLKeyword('FIRST',Options)+' '+IntToStr(Limit.First); + if Limit.Skip>=0 then + Result:=Result+' '+SQLKeyword('SKIP',Options)+' '+IntToStr(Limit.Skip); + end; If Distinct then Result:=Result+' '+SQLKeyword('DISTINCT',Options); NewLinePending:=(sfoOneFieldPerLine in Options); @@ -2093,6 +2135,13 @@ begin NewLinePending:=NewLinePending or (sfoPlanOnSeparateLine in Options); AddExpression('PLAN',Plan,(sfoPlanOnSeparateLine in Options),(sfoIndentPlan in Options)); AddList('ORDER BY',OrderBy,(sfoOneOrderByFieldPerLine in Options),(sfoIndentOrderByFields in Options)); + If Limit.Style=lsPostgres then + begin + if Limit.RowCount>=0 then + Result:=Result+' '+SQLKeyword('LIMIT',Options)+' '+IntToStr(Limit.RowCount); + if Limit.Offset>=0 then + Result:=Result+' '+SQLKeyword('OFFSET',Options)+' '+IntToStr(Limit.Offset); + end; end; { TSQLInsertStatement } diff --git a/packages/fcl-db/tests/tcgensql.pas b/packages/fcl-db/tests/tcgensql.pas index 0034ec96a3..f83cf54aaf 100644 --- a/packages/fcl-db/tests/tcgensql.pas +++ b/packages/fcl-db/tests/tcgensql.pas @@ -97,6 +97,7 @@ type procedure TestPlanExpression; procedure TestOrderBy; Procedure TestSelect; + Procedure TestLimit; procedure TestInsert; procedure TestUpdatePair; procedure TestUpdate; @@ -995,6 +996,33 @@ begin AssertSQL(J,'(E JOIN F ON (G = H)) FULL OUTER JOIN A ON (C = D)',[sfoBracketLeftJoin]); end; +procedure TTestGenerateSQL.TestLimit; + +Var + S : TSQLSelectStatement; + +begin + S:=CreateSelect(CreateIdentifierExpression('A'),'B'); + + S.Limit.Style:=lsFireBird; + S.Limit.First := 10; + AssertSQL(S,'SELECT FIRST 10 A FROM B'); + S.Limit.Style:=lsMSSQL; + AssertSQL(S,'SELECT TOP 10 A FROM B'); + S.Limit.Style:=lsPostgres; + AssertSQL(S,'SELECT A FROM B LIMIT 10'); + + S.Limit.Skip := 20; + S.Limit.Style:=lsFireBird; + AssertSQL(S,'SELECT FIRST 10 SKIP 20 A FROM B'); + S.Limit.Style:=lsPostgres; + AssertSQL(S,'SELECT A FROM B LIMIT 10 OFFSET 20'); + + S.Limit.RowCount := -1; + S.Limit.Style:=lsPostgres; + AssertSQL(S,'SELECT A FROM B OFFSET 20'); +end; + procedure TTestGenerateSQL.TestPlanNatural; Var diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 7b4133dace..ccc0dc81f9 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -413,6 +413,15 @@ type procedure TestSelectTwoFieldsThreeBracketTablesJoin; procedure TestSelectTableWithSchema; procedure TestSelectFieldWithSchema; + procedure TestSelectFirst; + procedure TestSelectFirstSkip; + procedure TestSelectTop; + procedure TestSelectLimit; + procedure TestSelectLimitAll; + procedure TestSelectLimitAllOffset; + procedure TestSelectLimitOffset1; + procedure TestSelectLimitOffset2; + procedure TestSelectOffset; procedure TestAggregateCount; procedure TestAggregateCountAsterisk; procedure TestAggregateCountAll; @@ -3758,6 +3767,73 @@ begin AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); end; +procedure TTestSelectParser.TestSelectFirst; +begin + // FireBird + TestSelect('SELECT FIRST 100 A FROM B'); + AssertEquals('Limit style',Ord(lsFireBird),Ord(Select.Limit.Style)); + AssertEquals('Limit FIRST 100',100,Select.Limit.First); +end; + +procedure TTestSelectParser.TestSelectFirstSkip; +begin + // FireBird + TestSelect('SELECT FIRST 100 SKIP 200 A FROM B'); + AssertEquals('Limit style',Ord(lsFireBird),Ord(Select.Limit.Style)); + AssertEquals('Limit FIRST 100',100,Select.Limit.First); + AssertEquals('Limit SKIP 200',200,Select.Limit.Skip); +end; + +procedure TTestSelectParser.TestSelectLimit; +begin + // MySQL&Postgres + TestSelect('SELECT A FROM B LIMIT 100'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit RowCount 100',100,Select.Limit.RowCount); +end; + +procedure TTestSelectParser.TestSelectLimitAll; +begin + // Postgres + TestSelect('SELECT A FROM B LIMIT ALL'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit RowCount -1',-1,Select.Limit.RowCount); +end; + +procedure TTestSelectParser.TestSelectLimitAllOffset; +begin + // Postgres + TestSelect('SELECT A FROM B LIMIT ALL OFFSET 200'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit Offset 200',200,Select.Limit.Offset); +end; + +procedure TTestSelectParser.TestSelectLimitOffset1; +begin + // MySQL + TestSelect('SELECT A FROM B LIMIT 200, 100'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit RowCount 100',100,Select.Limit.RowCount); + AssertEquals('Limit Offset 200',200,Select.Limit.Offset); +end; + +procedure TTestSelectParser.TestSelectLimitOffset2; +begin + // MySQL&Postgres + TestSelect('SELECT A FROM B LIMIT 100 OFFSET 200'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit RowCount 100',100,Select.Limit.RowCount); + AssertEquals('Limit Offset 200',200,Select.Limit.Offset); +end; + +procedure TTestSelectParser.TestSelectOffset; +begin + // Postgres + TestSelect('SELECT A FROM B OFFSET 200'); + AssertEquals('Limit style',Ord(lsPostgres),Ord(Select.Limit.Style)); + AssertEquals('Limit Offset 200',200,Select.Limit.Offset); +end; + procedure TTestSelectParser.TestSelectOneFieldOneTable; begin TestSelect('SELECT B FROM A'); @@ -3850,6 +3926,14 @@ begin AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); end; +procedure TTestSelectParser.TestSelectTop; +begin + // MSSQL + TestSelect('SELECT TOP 100 A FROM B'); + AssertEquals('Limit style',Ord(lsMSSQL),Ord(Select.Limit.Style)); + AssertEquals('Limit TOP 100',100,Select.Limit.Top); +end; + procedure TTestSelectParser.TestSelectOneDistinctFieldOneTable; begin TestSelect('SELECT DISTINCT B FROM A'); From 887de9f27c255dfcba30973cd24b1c98431d6b05 Mon Sep 17 00:00:00 2001 From: yury Date: Fri, 14 Aug 2020 13:10:12 +0000 Subject: [PATCH 09/21] * Fixed nasm writer by adding a new line after the GLOBAL directive. git-svn-id: trunk@46427 - --- compiler/x86/agx86nsm.pas | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/x86/agx86nsm.pas b/compiler/x86/agx86nsm.pas index 30e3042d6d..e10e2e445f 100644 --- a/compiler/x86/agx86nsm.pas +++ b/compiler/x86/agx86nsm.pas @@ -802,6 +802,7 @@ interface writer.AsmWrite(tai_datablock(hp).sym.name); if tai_datablock(hp).sym.bind=AB_PRIVATE_EXTERN then WriteHiddenSymbolAttribute(tai_datablock(hp).sym); + writer.AsmLn; end; writer.AsmWrite(PadTabs(ApplyAsmSymbolRestrictions(tai_datablock(hp).sym.name),':')); if SmartAsm then From 0fb6419edd5cbb83e26043f7f14891938d4da6ca Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 13:48:29 +0000 Subject: [PATCH 10/21] sql parser: support CASE expression git-svn-id: trunk@46428 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 30 +++++++++ packages/fcl-db/src/sql/fpsqlscanner.pp | 4 +- packages/fcl-db/src/sql/fpsqltree.pp | 89 +++++++++++++++++++++++++ packages/fcl-db/tests/tcgensql.pas | 32 ++++++++- packages/fcl-db/tests/tcparser.pas | 29 ++++++++ 5 files changed, 181 insertions(+), 3 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index dda2998934..4607016674 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -77,6 +77,7 @@ Type function ParseExprLevel5(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression; function ParseExprLevel6(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression; function ParseExprPrimitive(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression; + function ParseCaseExpression(AParent: TSQLElement): TSQLCaseExpression; function ParseInoperand(AParent: TSQLElement): TSQLExpression; // Lists, primitives function ParseIdentifierList(AParent: TSQLElement; AList: TSQLelementList): integer; @@ -1331,6 +1332,34 @@ begin end; +function TSQLParser.ParseCaseExpression(AParent: TSQLElement): TSQLCaseExpression; +var + Branch: TSQLCaseExpressionBranch; +begin + Consume(tsqlCASE); + Result:=TSQLCaseExpression(CreateElement(TSQLCaseExpression,AParent)); + try + while CurrentToken=tsqlWhen do + begin + GetNextToken; + Branch := TSQLCaseExpressionBranch.Create; + Branch.Condition:=ParseExprLevel1(AParent,[eoIF]); + Consume(tsqlThen); + Branch.Expression:=ParseExprLevel1(AParent,[eoIF]); + Result.AddBranch(Branch); + end; + if CurrentToken=tsqlELSE then + begin + GetNextToken; + Result.ElseBranch:=ParseExprLevel1(AParent,[eoIF]); + end; + Consume(tsqlEnd); + except + FreeAndNil(Result); + Raise; + end; +end; + procedure TSQLParser.ParseIntoList(AParent : TSQLElement; List : TSQLElementList); begin @@ -2733,6 +2762,7 @@ begin TSQLCastExpression(Result).NewType:=ParseTypeDefinition(Result,[ptfCast]); Consume(tsqlBraceClose); end; + tsqlCase: Result:=ParseCaseExpression(AParent); tsqlExtract: begin GetNextToken; diff --git a/packages/fcl-db/src/sql/fpsqlscanner.pp b/packages/fcl-db/src/sql/fpsqlscanner.pp index f335340eb4..f004cc8b96 100644 --- a/packages/fcl-db/src/sql/fpsqlscanner.pp +++ b/packages/fcl-db/src/sql/fpsqlscanner.pp @@ -51,7 +51,7 @@ type { Note: if adding before tsqlALL or after tsqlWHEN please update FirstKeyword/LastKeyword } tsqlALL, tsqlAND, tsqlANY, tsqlASC, tsqlASCENDING, tsqlAVG, tsqlALTER, tsqlAdd, tsqlActive, tsqlAction, tsqlAs,tsqlAt, tsqlAuto, tsqlAfter,tsqlAdmin, tsqlBETWEEN, tsqlBinary, tsqlBY, tsqlBLOB, tsqlBegin, tsqlBefore, - tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString, + tsqlCASE, tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString, tsqlDESC, tsqlDESCENDING, tsqlDISTINCT, tsqlDEFAULT, tsqlDELETE, tsqlDO, tsqlDouble, tsqlDECLARE, tsqlDROP, tsqlDomain, tsqlDecimal, tsqlDate,tsqlDatabase, tsqlESCAPE, tsqlEXISTS, tsqlELSE, tsqlException, tsqlExternal, tsqlExecute, tsqlEnd,tsqlExit,tsqlEntrypoint,tsqlExtract, tsqlFIRST, tsqlFROM, tsqlFULL, tsqlFOREIGN, tsqlFOR, tsqlFUNCTION, tsqlFLOAT, tsqlFile,tsqlFreeIt, @@ -97,7 +97,7 @@ const // Identifiers last: 'ALL', 'AND', 'ANY', 'ASC', 'ASCENDING', 'AVG', 'ALTER', 'ADD','ACTIVE','ACTION', 'AS', 'AT', 'AUTO', 'AFTER', 'ADMIN', 'BETWEEN', 'BINARY', 'BY', 'BLOB','BEGIN', 'BEFORE', - 'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING', + 'CASE', 'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING', 'DESC', 'DESCENDING', 'DISTINCT', 'DEFAULT', 'DELETE', 'DO', 'DOUBLE', 'DECLARE', 'DROP', 'DOMAIN', 'DECIMAL', 'DATE','DATABASE', 'ESCAPE', 'EXISTS', 'ELSE', 'EXCEPTION', 'EXTERNAL','EXECUTE', 'END','EXIT','ENTRY_POINT','EXTRACT', 'FIRST', 'FROM', 'FULL','FOREIGN', 'FOR', 'FUNCTION', 'FLOAT','FILE', 'FREE_IT', diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index 0c1ee50c0f..bb22a9b771 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -1411,6 +1411,38 @@ Type Property FalseBranch : TSQLStatement Read FFalseBranch Write FFalseBranch; end; + { TSQLCaseExpressionBranch } + + TSQLCaseExpressionBranch = Class + private + FCondition: TSQLExpression; + FExpression: TSQLExpression; + public + destructor Destroy; override; + public + property Condition: TSQLExpression read FCondition write FCondition; + property Expression: TSQLExpression read FExpression write FExpression; + end; + + { TSQLCaseExpression } + + TSQLCaseExpression = Class(TSQLExpression) + private + FBranches: array of TSQLCaseExpressionBranch; + FElseBranch: TSQLExpression; + function GetBranch(Index: Integer): TSQLCaseExpressionBranch; + function GetBranchCount: Integer; + Public + Destructor Destroy; override; + Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; + + Property BranchCount: Integer Read GetBranchCount; + Procedure AddBranch(ABranch: TSQLCaseExpressionBranch); + Procedure ClearBranches; + Property Branches[Index: Integer] : TSQLCaseExpressionBranch Read GetBranch; + Property ElseBranch : TSQLExpression Read FElseBranch Write FElseBranch; + end; + { TSQLForStatement } TSQLForStatement = Class(TSQLStatement) @@ -1937,6 +1969,63 @@ begin Sep:=', '; end; +{ TSQLCaseExpressionBranch } + +destructor TSQLCaseExpressionBranch.Destroy; +begin + FreeAndNil(FCondition); + FreeAndNil(FExpression); + inherited Destroy; +end; + +{ TSQLCaseExpression } + +procedure TSQLCaseExpression.AddBranch(ABranch: TSQLCaseExpressionBranch); +begin + SetLength(FBranches, Length(FBranches)+1); + FBranches[High(FBranches)] := ABranch; +end; + +procedure TSQLCaseExpression.ClearBranches; +var + B: TSQLCaseExpressionBranch; +begin + for B in FBranches do + B.Free; + FBranches:=nil; +end; + +destructor TSQLCaseExpression.Destroy; +begin + ClearBranches; + FreeAndNil(FElseBranch); + inherited Destroy; +end; + +function TSQLCaseExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; +var + B: TSQLCaseExpressionBranch; +begin + Result:=SQLKeyWord('CASE',Options)+' '; + for B in FBranches do + Result:=Result+ + SQLKeyWord('WHEN ',Options)+B.Condition.GetAsSQL(Options, AIndent)+' '+ + SQLKeyWord('THEN ',Options)+B.Expression.GetAsSQL(Options, AIndent)+' '; + If Assigned(FElseBranch) then + Result:=Result+SQLKeyWord('ELSE ',Options)+ElseBranch.GetAsSQL(Options,AIndent)+' '; + Result:=Result+SQLKeyWord('END',Options); +end; + +function TSQLCaseExpression.GetBranch(Index: Integer): TSQLCaseExpressionBranch; +begin + Result := FBranches[Index]; +end; + +function TSQLCaseExpression.GetBranchCount: Integer; +begin + Result := Length(FBranches); +end; + { TSQLSelectLimit } constructor TSQLSelectLimit.Create; diff --git a/packages/fcl-db/tests/tcgensql.pas b/packages/fcl-db/tests/tcgensql.pas index f83cf54aaf..4ecf89a3e3 100644 --- a/packages/fcl-db/tests/tcgensql.pas +++ b/packages/fcl-db/tests/tcgensql.pas @@ -69,6 +69,7 @@ type Procedure TestSimpleSelect; Procedure TestAnyExpression; procedure TestAllExpression; + procedure TestCaseExpression; procedure TestExistsExpression; procedure TestSomeExpression; procedure TestSingularExpression; @@ -816,7 +817,7 @@ begin AssertSQL(U,'constraint C unique (A , B)',[sfoLowercaseKeyWord]); end; -procedure TTestGenerateSQL.TestTableprimaryKeyConstraintDef; +procedure TTestGenerateSQL.TestTablePrimaryKeyConstraintDef; Var U : TSQLTablePrimaryKeyConstraintDef; @@ -1872,6 +1873,35 @@ begin AssertSQL(B,'BEGIN'+sLineBreak+' BEGIN'+sLineBreak+' EXIT;'+sLineBreak+' END'+sLineBreak+'END'); end; +procedure TTestGenerateSQL.TestCaseExpression; + +Var + E : TSQLCaseExpression; + B : TSQLCaseExpressionBranch; + C : TSQLBinaryExpression; + +begin + E:=TSQLCaseExpression.Create(Nil); + + B:=TSQLCaseExpressionBranch.Create; + C:=CreateBinaryExpression(CreateIdentifierExpression('A'),CreateIdentifierExpression('B')); + C.Operation:=boEQ; + B.Condition:=C; + B.Expression:=CreateLiteralExpression(CreateLiteral(1)); + E.AddBranch(B); + + B:=TSQLCaseExpressionBranch.Create; + C:=CreateBinaryExpression(CreateIdentifierExpression('A'),CreateIdentifierExpression('B')); + C.Operation:=boGT; + B.Condition:=C; + B.Expression:=CreateLiteralExpression(CreateLiteral(2)); + E.AddBranch(B); + + E.ElseBranch:=CreateLiteralExpression(CreateLiteral(3)); + FTofree:=E; + AssertSQL(E,'CASE WHEN A = B THEN 1 WHEN A > B THEN 2 ELSE 3 END'); +end; + procedure TTestGenerateSQL.TestAssignment; var diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index ccc0dc81f9..255658968a 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -230,6 +230,7 @@ type procedure TestAnd; procedure TestOr; procedure TestNotOr; + procedure TestCase; end; { TTestDomainParser } @@ -2203,6 +2204,34 @@ begin AssertLiteralExpr('Right is integer',T.Right,TSQLIntegerLiteral); end; +procedure TTestCheckParser.TestCase; + +Var + T : TSQLCaseExpression; + B : TSQLBinaryExpression; + R : TSQLIdentifierName; + +begin + T:=TSQLCaseExpression(TestCheck('CASE WHEN A=1 THEN "a" WHEN B=2 THEN "b" ELSE "c" END',TSQLCaseExpression)); + AssertEquals('Branch count = 2',2,T.BranchCount); + AssertNotNull('Else branch exists',T.ElseBranch); + + B:=(T.Branches[0].Condition as TSQLBinaryExpression); + R:=(T.Branches[0].Expression as TSQLIdentifierExpression).Identifier; + AssertEquals('First WHEN Identifier is A', 'A', (B.Left as TSQLIdentifierExpression).Identifier.Name); + AssertEquals('First WHEN Number is 1', 1, ((B.Right as TSQLLiteralExpression).Literal as TSQLIntegerLiteral).Value); + AssertEquals('First THEN result is "a"', 'a', R.Name); + + B:=(T.Branches[1].Condition as TSQLBinaryExpression); + R:=(T.Branches[1].Expression as TSQLIdentifierExpression).Identifier; + AssertEquals('Second WHEN Identifier is B', 'B', (B.Left as TSQLIdentifierExpression).Identifier.Name); + AssertEquals('Second WHEN Number is 2', 2, ((B.Right as TSQLLiteralExpression).Literal as TSQLIntegerLiteral).Value); + AssertEquals('Second THEN result is "b"', 'b', R.Name); + + R:=(T.ElseBranch as TSQLIdentifierExpression).Identifier; + AssertEquals('ELSE result is "c"', 'c', R.Name); +end; + procedure TTestCheckParser.TestNotBetween; Var From 56613723b9f60c582df39bf0154dd7dccbe6d1b0 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 14:17:54 +0000 Subject: [PATCH 11/21] sql parser: fix source position git-svn-id: trunk@46429 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 16 ++++++++++++++-- packages/fcl-db/src/sql/fpsqlscanner.pp | 8 +++++++- packages/fcl-db/tests/tcparser.pas | 14 ++++++++++++++ 3 files changed, 35 insertions(+), 3 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 4607016674..5d06c99a2f 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -47,10 +47,14 @@ Type FScanner : TSQLScanner; FCurrent : TSQLToken; FCurrentString : String; + FCurrentTokenLine : Integer; + FCurrentTokenPos : Integer; FPrevious : TSQLToken; FFreeScanner : Boolean; FPeekToken: TSQLToken; FPeekTokenString: String; + FPeekTokenLine : Integer; + FPeekTokenPos : Integer; Procedure CheckEOF; protected procedure UnexpectedToken; overload; @@ -173,6 +177,8 @@ Type // Auxiliary stuff Property CurrentToken : TSQLToken read FCurrent; Property CurrentTokenString : String read FCurrentString; + Property CurrentTokenLine : Integer read FCurrentTokenLine; + Property CurrentTokenPos : Integer read FCurrentTokenPos; // Gets next token; also updates current token Function GetNextToken : TSQLToken; // Looks at next token without changing current token @@ -325,8 +331,8 @@ function TSQLParser.CreateElement(AElementClass: TSQLElementClass; begin Result:=AElementClass.Create(AParent); Result.Source:=CurSource; - Result.SourceLine:=CurLine; - Result.SourcePos:=CurPos; + Result.SourceLine:=CurrentTokenLine; + Result.SourcePos:=CurrentTokenPos; end; function TSQLParser.ParseTableRef(AParent: TSQLSelectStatement @@ -4167,6 +4173,8 @@ begin begin FCurrent:=FPeekToken; FCurrentString:=FPeekTokenString; + FCurrentTokenLine:=FPeekTokenLine; + FCurrentTokenPos:=FPeekTokenPos; FPeekToken:=tsqlUnknown; FPeekTokenString:=''; end @@ -4174,6 +4182,8 @@ begin begin FCurrent:=FScanner.FetchToken; FCurrentString:=FScanner.CurTokenString; + FCurrentTokenLine:=FScanner.CurTokenRow; + FCurrentTokenPos:=FScanner.CurTokenColumn; end; Result:=FCurrent; {$ifdef debugparser}Writeln('GetNextToken : ',GetEnumName(TypeInfo(TSQLToken),Ord(FCurrent)), ' As string: ',FCurrentString);{$endif debugparser} @@ -4185,6 +4195,8 @@ begin begin FPeekToken:=FScanner.FetchToken; FPeekTokenString:=FScanner.CurTokenString; + FPeekTokenLine:=FScanner.CurTokenRow; + FPeekTokenPos:=FScanner.CurTokenColumn; end; {$ifdef debugparser}Writeln('PeekNextToken : ',GetEnumName(TypeInfo(TSQLToken),Ord(FPeekToken)), ' As string: ',FPeekTokenString);{$endif debugparser} Result:=FPeekToken; diff --git a/packages/fcl-db/src/sql/fpsqlscanner.pp b/packages/fcl-db/src/sql/fpsqlscanner.pp index f004cc8b96..7a61d1386b 100644 --- a/packages/fcl-db/src/sql/fpsqlscanner.pp +++ b/packages/fcl-db/src/sql/fpsqlscanner.pp @@ -175,6 +175,8 @@ Type FCurRow: Integer; FCurToken: TSQLToken; FCurTokenString: string; + FCurTokenRow: Integer; + FCurTokenColumn: Integer; FCurLine: string; TokenStr: PChar; FSourceStream : TStream; @@ -219,6 +221,8 @@ Type property CurColumn: Integer read GetCurColumn; property CurToken: TSQLToken read FCurToken; property CurTokenString: string read FCurTokenString; + Property CurTokenRow : Integer Read FCurTokenRow; + Property CurTokenColumn : Integer Read FCurTokenColumn; Property ExcludeKeywords : TStrings Read GetExcludeKeywords Write SetExcludeKeywords; Property AlternateTerminator : String Read FAlternateTerminator Write FAlternateTerminator; end; @@ -719,6 +723,8 @@ begin FCurToken := Result; exit; end; + FCurTokenRow:=CurRow; + FCurTokenColumn:=CurColumn; FCurTokenString := ''; case TokenStr[0] of #0: // Empty line @@ -911,7 +917,7 @@ end; function TSQLScanner.GetCurColumn: Integer; begin - Result := TokenStr - PChar(FCurLine); + Result := TokenStr - PChar(FCurLine) + 1; end; Procedure TSQLScanner.ClearKeywords(Sender : TObject); diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 255658968a..2c5b14c376 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -488,6 +488,7 @@ type procedure TestWhereSome; procedure TestParam; procedure TestParamExpr; + procedure TestSourcePosition; end; { TTestRollBackParser } @@ -4060,6 +4061,19 @@ begin AssertJoinOn(J.JoinClause,'E','F',boEq); end; +procedure TTestSelectParser.TestSourcePosition; +begin + TestSelect('SELECT X FROM ABC'); + AssertEquals('One table',1,Select.Tables.Count); + AssertEquals('Table source position = 1', 1, Select.Tables[0].SourceLine); + AssertEquals('Table source position = 15', 15, Select.Tables[0].SourcePos); + + TestSelect('SELECT X'+sLineBreak+'FROM ABC'); + AssertEquals('One table',1,Select.Tables.Count); + AssertEquals('Table source position = 2', 2, Select.Tables[0].SourceLine); + AssertEquals('Table source position = 6', 6, Select.Tables[0].SourcePos); +end; + procedure TTestSelectParser.TestSelectTwoFieldsTwoInnerTablesJoin; Var J : TSQLJoinTableReference; From 38c7659d070963527f9ed5c5310e2e441ddbadb6 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 14:59:05 +0000 Subject: [PATCH 12/21] TEncoding: fix base convert functions for empty inputs git-svn-id: trunk@46430 - --- rtl/objpas/sysutils/sysencoding.inc | 43 ++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/rtl/objpas/sysutils/sysencoding.inc b/rtl/objpas/sysutils/sysencoding.inc index 23e27ab730..a50b3eac55 100644 --- a/rtl/objpas/sysutils/sysencoding.inc +++ b/rtl/objpas/sysutils/sysencoding.inc @@ -38,7 +38,10 @@ end; function TEncoding.GetAnsiBytes(const S: string): TBytes; begin - Result := GetAnsiBytes(S, 1, Length(S)); + if S='' then + Result := nil + else + Result := GetAnsiBytes(S, 1, Length(S)); end; function TEncoding.GetAnsiBytes(const S: string; CharIndex, CharCount: Integer @@ -49,7 +52,10 @@ end; function TEncoding.GetAnsiString(const Bytes: TBytes): string; begin - Result := GetAnsiString(Bytes, 0, Length(Bytes)); + if Length(Bytes)=0 then + Result := '' + else + Result := GetAnsiString(Bytes, 0, Length(Bytes)); end; function TEncoding.GetAnsiString(const Bytes: TBytes; ByteIndex, @@ -294,7 +300,10 @@ end; function TEncoding.GetByteCount(const Chars: TUnicodeCharArray): Integer; begin - Result := GetByteCount(Chars, 0, Length(Chars)); + if Length(Chars)=0 then + Result := 0 + else + Result := GetByteCount(Chars, 0, Length(Chars)); end; function TEncoding.GetByteCount(const Chars: TUnicodeCharArray; CharIndex, @@ -309,7 +318,10 @@ end; function TEncoding.GetByteCount(const S: UnicodeString): Integer; begin - Result := GetByteCount(PUnicodeChar(S), Length(S)); + if S='' then + Result := 0 + else + Result := GetByteCount(PUnicodeChar(S), Length(S)); end; function TEncoding.GetByteCount(const S: UnicodeString; CharIndex, CharCount: Integer): Integer; @@ -324,7 +336,8 @@ end; function TEncoding.GetBytes(const Chars: TUnicodeCharArray): TBytes; begin SetLength(Result, GetByteCount(Chars)); - GetBytes(@Chars[0], Length(Chars), @Result[0], Length(Result)); + if Length(Result)>0 then + GetBytes(@Chars[0], Length(Chars), @Result[0], Length(Result)); end; function TEncoding.GetBytes(const Chars: TUnicodeCharArray; CharIndex, @@ -358,7 +371,8 @@ end; function TEncoding.GetBytes(const S: UnicodeString): TBytes; begin SetLength(Result, GetByteCount(S)); - GetBytes(@S[1], Length(S), @Result[0], Length(Result)); + if Length(Result)>0 then + GetBytes(@S[1], Length(S), @Result[0], Length(Result)); end; function TEncoding.GetBytes(const S: UnicodeString; CharIndex, CharCount: Integer; @@ -380,7 +394,10 @@ end; function TEncoding.GetCharCount(const Bytes: TBytes): Integer; begin - Result := GetCharCount(@Bytes[0], Length(Bytes)); + if Length(Bytes)=0 then + Result := 0 + else + Result := GetCharCount(@Bytes[0], Length(Bytes)); end; function TEncoding.GetCharCount(const Bytes: TBytes; ByteIndex, @@ -394,7 +411,8 @@ end; function TEncoding.GetChars(const Bytes: TBytes): TUnicodeCharArray; begin SetLength(Result, GetCharCount(Bytes)); - GetChars(@Bytes[0], Length(Bytes), @Result[0], Length(Result)); + if Length(Result)>0 then + GetChars(@Bytes[0], Length(Bytes), @Result[0], Length(Result)); end; function TEncoding.GetChars(const Bytes: TBytes; ByteIndex, ByteCount: Integer): TUnicodeCharArray; @@ -444,8 +462,13 @@ function TEncoding.GetString(const Bytes: TBytes): UnicodeString; var Chars: TUnicodeCharArray; begin - Chars := GetChars(Bytes); - SetString(Result, PUnicodeChar(Chars), Length(Chars)); + if Length(Bytes)=0 then + Result := '' + else + begin + Chars := GetChars(Bytes); + SetString(Result, PUnicodeChar(Chars), Length(Chars)); + end; end; function TEncoding.GetString(const Bytes: TBytes; ByteIndex, ByteCount: Integer): UnicodeString; From 631ec771578492fefe448d4f861283f04f1a5521 Mon Sep 17 00:00:00 2001 From: yury Date: Fri, 14 Aug 2020 16:17:18 +0000 Subject: [PATCH 13/21] * 8086: Fixed calling of local routines with the near attribute in the 'far code' memory models. git-svn-id: trunk@46431 - --- compiler/i8086/hlcgcpu.pas | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/compiler/i8086/hlcgcpu.pas b/compiler/i8086/hlcgcpu.pas index 6f9f411212..086d633c26 100644 --- a/compiler/i8086/hlcgcpu.pas +++ b/compiler/i8086/hlcgcpu.pas @@ -70,6 +70,7 @@ interface procedure reference_reset_base(var ref: treference; regsize: tdef; reg: tregister; offset: longint; temppos: treftemppos; alignment: longint; volatility: tvolatilityset); override; function a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;override; + function a_call_name_static(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef): tcgpara; override; procedure a_load_loc_ref(list : TAsmList;fromsize, tosize: tdef; const loc: tlocation; const ref : treference);override; procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override; @@ -325,6 +326,12 @@ implementation end; + function thlcgcpu.a_call_name_static(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef): tcgpara; + begin + Result:=a_call_name(list,pd,s,paras,forceresdef,false); + end; + + procedure thlcgcpu.a_load_loc_ref(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const ref: treference); var tmpref: treference; From 9d3b105fab0d6d66192678520c14c20d9d638357 Mon Sep 17 00:00:00 2001 From: yury Date: Fri, 14 Aug 2020 16:21:12 +0000 Subject: [PATCH 14/21] * msdos: By default external routine names with the pascal calling convention must be all upper case. This is TP and TASM compatible. git-svn-id: trunk@46432 - --- compiler/pdecsub.pas | 3 +++ 1 file changed, 3 insertions(+) diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 0d78f8c896..df39eaeb1b 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -3178,6 +3178,9 @@ const result:=target_info.Cprefix+tprocdef(pd).procsym.realname else result:=pd.procsym.realname; + if (target_info.system=system_i8086_msdos) and + (pd.proccalloption=pocall_pascal) then + result:=UpCase(result); end; end; end; From f7d14128b53ad2147e50042d1d148e4ae9de62b3 Mon Sep 17 00:00:00 2001 From: yury Date: Fri, 14 Aug 2020 16:56:13 +0000 Subject: [PATCH 15/21] * 8086: Do not force far calls in the TP mode by default. This is TP compatible. Other modes need forced far calls by default in order to compile non-TP code. git-svn-id: trunk@46433 - --- compiler/scanner.pas | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/compiler/scanner.pas b/compiler/scanner.pas index 282ad9dd1c..ba953b53e6 100644 --- a/compiler/scanner.pas +++ b/compiler/scanner.pas @@ -604,6 +604,16 @@ implementation include(init_settings.localswitches,cs_strict_var_strings); end; +{$ifdef i8086} + { Do not force far calls in the TP mode by default } + if (m_tp7 in current_settings.modeswitches) then + begin + exclude(current_settings.localswitches,cs_force_far_calls); + if changeinit then + exclude(init_settings.localswitches,cs_force_far_calls); + end; +{$endif i8086} + { Undefine old symbol } if (m_delphi in oldmodeswitches) then undef_system_macro('FPC_DELPHI') From 9fca033ac33faffd4fa4257311decd9b888a3010 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 17:46:38 +0000 Subject: [PATCH 16/21] sql parser: unify identifier path code git-svn-id: trunk@46434 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 8 +- packages/fcl-db/src/sql/fpsqltree.pp | 155 ++++++++++-------------- packages/fcl-db/tests/tcgensql.pas | 4 +- packages/fcl-db/tests/tcparser.pas | 12 +- 4 files changed, 73 insertions(+), 106 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 5d06c99a2f..62ecc0aad5 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -353,13 +353,13 @@ begin Expect(tsqlIdentifier); T:=TSQLSimpleTableReference(CreateElement(TSQLSimpleTableReference,AParent)); Result:=T; - T.AddObjectNameToPath(CreateIdentifier(T,CurrentTokenString)); + T.ObjectNamePath.Add(CreateIdentifier(T,CurrentTokenString)); GetNextToken; while CurrentToken=tsqlDOT do begin GetNextToken; Expect(tsqlIdentifier); - T.AddObjectNameToPath(CreateIdentifier(T,CurrentTokenString)); + T.ObjectNamePath.Add(CreateIdentifier(T,CurrentTokenString)); GetNextToken; end; If CurrentToken=tsqlBraceOpen then @@ -2861,13 +2861,13 @@ begin Error(SErrUnexpectedToken,[CurrentTokenString]); // Plain identifier Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent)); - TSQLIdentifierExpression(Result).AddIdentifierToPath(CreateIdentifier(Result,N)); + TSQLIdentifierExpression(Result).IdentifierPath.Add(CreateIdentifier(Result,N)); while (CurrentToken=tsqlDot) do begin GetNextToken; Expect(tsqlIdentifier); N:=CurrentTokenString; - TSQLIdentifierExpression(Result).AddIdentifierToPath(CreateIdentifier(Result,N)); + TSQLIdentifierExpression(Result).IdentifierPath.Add(CreateIdentifier(Result,N)); GetNextToken; end; // Array access ? diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index bb22a9b771..f3a4bb2cc4 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -183,25 +183,32 @@ Type Property Literal : TSQLLiteral Read FLiteral write FLiteral; end; + { TSQLIdentifierPath } + + TSQLIdentifierPath = Class(TSQLElementList) + private + function GetI(AIndex : Integer): TSQLIdentifierName; + procedure SetI(AIndex : Integer; const AIdentifier: TSQLIdentifierName); + Public + Function Add(AName: TSQLIdentifierName): Integer; + Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; + Property Identifiers[AIndex : Integer] : TSQLIdentifierName Read GetI Write SetI; default; + end; + { TSQLIdentifierExpression } TSQLIdentifierExpression = Class(TSQLExpression) private FElementIndex: Integer; - FIdentifierPath: array of TSQLIdentifierName; + FIdentifierPath: TSQLIdentifierPath; function GetIdentifier: TSQLIdentifierName; - function GetIdentifierPath(Index: Integer): TSQLIdentifierName; - function GetIdentifierPathCount: Integer; procedure SetIdentifier(const AName: TSQLIdentifierName); Public Constructor Create(AParent : TSQLElement); override; Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; Property Identifier : TSQLIdentifierName Read GetIdentifier Write SetIdentifier; - Property IdentifierPathCount: Integer Read GetIdentifierPathCount; - Procedure AddIdentifierToPath(AName: TSQLIdentifierName); - Procedure ClearIdentifierPath; - Property IdentifierPath[Index: Integer] : TSQLIdentifierName Read GetIdentifierPath; + Property IdentifierPath: TSQLIdentifierPath Read FIdentifierPath; // For array types: index of element in array Property ElementIndex : Integer Read FElementIndex Write FElementIndex; end; @@ -615,20 +622,16 @@ Type TSQLSimpleTableReference = Class(TSQLTableReference) private FAliasName: TSQLIdentifierName; - FObjectNamePath: array of TSQLIdentifierName; + FObjectNamePath: TSQLIdentifierPath; FParams: TSQLElementList; function GetObjectName: TSQLIdentifierName; - function GetObjectNamePath(Index: Integer): TSQLIdentifierName; - function GetObjectNamePathCount: Integer; procedure SetObjectName(const AName: TSQLIdentifierName); Public + constructor Create(AParent: TSQLElement); override; Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; Property ObjectName : TSQLIdentifierName Read GetObjectName Write SetObjectName; - Property ObjectNamePathCount: Integer Read GetObjectNamePathCount; - Procedure AddObjectNameToPath(AName: TSQLIdentifierName); - Procedure ClearObjectNamePath; - Property ObjectNamePath[Index: Integer] : TSQLIdentifierName Read GetObjectNamePath; + Property ObjectNamePath : TSQLIdentifierPath Read FObjectNamePath; Property Params : TSQLElementList Read FParams Write FParams; Property AliasName : TSQLIdentifierName Read FAliasName Write FAliasName; end; @@ -1969,6 +1972,36 @@ begin Sep:=', '; end; +{ TSQLIdentifierPath } + +function TSQLIdentifierPath.Add(AName: TSQLIdentifierName): Integer; +begin + Result := inherited Add(AName); +end; + +function TSQLIdentifierPath.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; +var + N: TSQLElement; +begin + Result := ''; + for Pointer(N) in Self do + begin + if Result<>'' then + Result:=Result+'.'; + Result:=Result+N.GetAsSQL(Options); + end; +end; + +function TSQLIdentifierPath.GetI(AIndex: Integer): TSQLIdentifierName; +begin + Result := TSQLIdentifierName(inherited Items[AIndex]); +end; + +procedure TSQLIdentifierPath.SetI(AIndex: Integer; const AIdentifier: TSQLIdentifierName); +begin + inherited Items[AIndex] := AIdentifier; +end; + { TSQLCaseExpressionBranch } destructor TSQLCaseExpressionBranch.Destroy; @@ -3227,24 +3260,15 @@ end; { TSQLSimpleTableReference } -procedure TSQLSimpleTableReference.AddObjectNameToPath(AName: TSQLIdentifierName); +constructor TSQLSimpleTableReference.Create(AParent: TSQLElement); begin - SetLength(FObjectNamePath, Length(FObjectNamePath)+1); - FObjectNamePath[High(FObjectNamePath)] := AName; -end; - -procedure TSQLSimpleTableReference.ClearObjectNamePath; -var - N: TSQLIdentifierName; -begin - for N in FObjectNamePath do - N.Free; - FObjectNamePath := nil; + inherited Create(AParent); + FObjectNamePath:=TSQLIdentifierPath.Create; end; destructor TSQLSimpleTableReference.Destroy; begin - ClearObjectNamePath; + FreeAndNil(FObjectNamePath); FreeAndNil(FParams); FreeAndNil(FAliasName); inherited Destroy; @@ -3254,8 +3278,6 @@ function TSQLSimpleTableReference.GetAsSQL(Options: TSQLFormatOptions; AIndent : Var I : integer; - TableName: TSQLStringType; - N: TSQLIdentifierName; begin Result:=''; If Assigned(FParams) and (FParams.Count>0) then @@ -3268,40 +3290,20 @@ begin end; Result:='('+Result+')'; end; - TableName := ''; - for N in FObjectNamePath do - begin - if TableName<>'' then - TableName:=TableName+'.'; - TableName:=TableName+N.GetAsSQL(Options); - end; - Result:= TableName+Result; + Result:= FObjectNamePath.GetAsSQL(Options, AIndent)+Result; if Assigned(FAliasName) then Result:=Result+' '+FAliasName.GetAsSQL(Options); end; function TSQLSimpleTableReference.GetObjectName: TSQLIdentifierName; begin - if Length(FObjectNamePath)>0 then - Result := FObjectNamePath[High(FObjectNamePath)] - else - Result := nil; -end; - -function TSQLSimpleTableReference.GetObjectNamePath(Index: Integer): TSQLIdentifierName; -begin - Result := FObjectNamePath[Index]; -end; - -function TSQLSimpleTableReference.GetObjectNamePathCount: Integer; -begin - Result := Length(FObjectNamePath); + Result := TSQLIdentifierName(FObjectNamePath.Last); end; procedure TSQLSimpleTableReference.SetObjectName(const AName: TSQLIdentifierName); begin - ClearObjectNamePath; - AddObjectNameToPath(AName); + FObjectNamePath.Clear; + FObjectNamePath.Add(AName); end; { TSQLJoinTableReference } @@ -4292,67 +4294,32 @@ end; constructor TSQLIdentifierExpression.Create(AParent: TSQLElement); begin inherited Create(AParent); + FIdentifierPath:=TSQLIdentifierPath.Create; FElementIndex:=-1; end; -procedure TSQLIdentifierExpression.AddIdentifierToPath(AName: TSQLIdentifierName); -begin - SetLength(FIdentifierPath, Length(FIdentifierPath)+1); - FIdentifierPath[High(FIdentifierPath)] := AName; -end; - -procedure TSQLIdentifierExpression.ClearIdentifierPath; -var - N: TSQLIdentifierName; -begin - for N in FIdentifierPath do - N.Free; - FIdentifierPath:=nil; -end; - destructor TSQLIdentifierExpression.Destroy; begin - ClearIdentifierPath; + FreeAndNil(FIdentifierPath); inherited Destroy; end; function TSQLIdentifierExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; -var - N: TSQLIdentifierName; begin - Result := ''; - for N in FIdentifierPath do - begin - if Result<>'' then - Result:=Result+'.'; - Result:=Result+N.GetAsSQL(Options); - end; + Result := FIdentifierPath.GetAsSQL(Options, AIndent); If (ElementIndex<>-1) then Result:=Result+Format('[%d]',[Elementindex]); end; function TSQLIdentifierExpression.GetIdentifier: TSQLIdentifierName; begin - if Length(FIdentifierPath)>0 then - Result:=FIdentifierPath[High(FIdentifierPath)] - else - Result:=nil; -end; - -function TSQLIdentifierExpression.GetIdentifierPath(Index: Integer): TSQLIdentifierName; -begin - Result := FIdentifierPath[Index]; -end; - -function TSQLIdentifierExpression.GetIdentifierPathCount: Integer; -begin - Result := Length(FIdentifierPath); + Result := TSQLIdentifierName(FIdentifierPath.Last); end; procedure TSQLIdentifierExpression.SetIdentifier(const AName: TSQLIdentifierName); begin - ClearIdentifierPath; - AddIdentifierToPath(AName); + FIdentifierPath.Clear; + FIdentifierPath.Add(AName); end; { TSQLSelectExpression } diff --git a/packages/fcl-db/tests/tcgensql.pas b/packages/fcl-db/tests/tcgensql.pas index 4ecf89a3e3..867814ddf6 100644 --- a/packages/fcl-db/tests/tcgensql.pas +++ b/packages/fcl-db/tests/tcgensql.pas @@ -427,8 +427,8 @@ Var begin I:=CreateIdentifierExpression('A'); - I.AddIdentifierToPath(CreateIdentifier('B')); - I.AddIdentifierToPath(CreateIdentifier('C')); + I.IdentifierPath.Add(CreateIdentifier('B')); + I.IdentifierPath.Add(CreateIdentifier('C')); F:=CreateSelectField(I,''); AssertSQL(F,'A.B.C', []); AssertSQL(F,'"A"."B"."C"',[sfoDoubleQuoteIdentifier]); diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 2c5b14c376..2ab8b4879e 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -3787,13 +3787,13 @@ begin AssertEquals('Two fields',2,Select.Fields.Count); AssertField(Select.Fields[0],'B'); Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); - AssertEquals('Field[0] path has 3 identifiers',3,Expr.IdentifierPathCount); + AssertEquals('Field[0] path has 3 identifiers',3,Expr.IdentifierPath.Count); AssertEquals('Field[0] schema is S','S',Expr.IdentifierPath[0].Name); AssertEquals('Field[0] table is A','A',Expr.IdentifierPath[1].Name); AssertField(Select.Fields[1],'C'); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A',''); - AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePathCount); + AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath.Count); AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); end; @@ -3938,7 +3938,7 @@ begin // Field supports linking/refering to a table AssertField(Select.Fields[0],'B'); Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); - AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table',2,Expr.IdentifierPath.Count); AssertEquals('Field has explicit table named A','A',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); @@ -3952,7 +3952,7 @@ begin AssertField(Select.Fields[1],'C'); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A',''); - AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePathCount); + AssertEquals('Table path has 2 objects',2,(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath.Count); AssertEquals('Schema name = S','S',(Select.Tables[0] as TSQLSimpleTableReference).ObjectNamePath[0].Name); end; @@ -4013,7 +4013,7 @@ begin AssertEquals('One field',1,Select.Fields.Count); AssertField(Select.Fields[0],'B'); Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); - AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table',2,Expr.IdentifierPath.Count); AssertEquals('Field has explicit table named C','C',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); @@ -4029,7 +4029,7 @@ begin AssertEquals('One field',1,Select.Fields.Count); AssertField(Select.Fields[0],'B'); Expr := ((Select.Fields[0] as TSQLSelectField).Expression as TSQLIdentifierExpression); - AssertEquals('Field has explicit table',2,Expr.IdentifierPathCount); + AssertEquals('Field has explicit table',2,Expr.IdentifierPath.Count); AssertEquals('Field has explicit table named C','C',Expr.IdentifierPath[0].Name); AssertEquals('One table',1,Select.Tables.Count); AssertTable(Select.Tables[0],'A'); From 1ba8255af07aa5e3c5a75d487c47b7e97d4a2016 Mon Sep 17 00:00:00 2001 From: florian Date: Fri, 14 Aug 2020 18:10:56 +0000 Subject: [PATCH 17/21] * do not try to unroll a loop if previously an error was thrown, resolves #37475 git-svn-id: trunk@46435 - --- .gitattributes | 1 + compiler/optloop.pas | 2 ++ tests/webtbf/tw37475.pp | 9 +++++++++ 3 files changed, 12 insertions(+) create mode 100644 tests/webtbf/tw37475.pp diff --git a/.gitattributes b/.gitattributes index 05c382d00a..551cd6bc0b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16558,6 +16558,7 @@ tests/webtbf/tw3738.pp svneol=native#text/plain tests/webtbf/tw3740.pp svneol=native#text/plain tests/webtbf/tw37460.pp svneol=native#text/pascal tests/webtbf/tw37462.pp svneol=native#text/pascal +tests/webtbf/tw37475.pp svneol=native#text/pascal tests/webtbf/tw3790.pp svneol=native#text/plain tests/webtbf/tw3812.pp svneol=native#text/plain tests/webtbf/tw3930a.pp svneol=native#text/plain diff --git a/compiler/optloop.pas b/compiler/optloop.pas index 6b04949848..1c613453b7 100644 --- a/compiler/optloop.pas +++ b/compiler/optloop.pas @@ -112,6 +112,8 @@ unit optloop; result:=nil; if (cs_opt_size in current_settings.optimizerswitches) then exit; + if ErrorCount<>0 then + exit; if not(node.nodetype in [forn]) then exit; unrolls:=number_unrolls(tfornode(node).t2); diff --git a/tests/webtbf/tw37475.pp b/tests/webtbf/tw37475.pp new file mode 100644 index 0000000000..3644cd4bbd --- /dev/null +++ b/tests/webtbf/tw37475.pp @@ -0,0 +1,9 @@ +{ %fail } +{ %opt=-O3 } +var a : integer; +begin + for a := 1 to 1 do + for a := 1 to a do + end; +end. + From 5bac4c25e0e34bbaf5aad0e006bad792d240236c Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 18:40:46 +0000 Subject: [PATCH 18/21] sql parser: support A.* syntax git-svn-id: trunk@46436 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 44 +++++-- packages/fcl-db/src/sql/fpsqltree.pp | 147 ++++++++++++++++++------ packages/fcl-db/tests/tcparser.pas | 12 ++ 3 files changed, 157 insertions(+), 46 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 62ecc0aad5..e893c1e594 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -435,7 +435,9 @@ procedure TSQLParser.ParseSelectFieldList(AParent: TSQLSelectStatement; AList: TSQLElementList; Singleton: Boolean); Var F : TSQLSelectField; + A : TSQLSelectAsterisk; B : Boolean; + Expression : TSQLExpression; begin // On entry, we're on the token preceding the field list. @@ -479,18 +481,20 @@ begin end; B:=False; end; - If (CurrentToken=tsqlMul) then + Expression:=ParseExprLevel1(AParent,[eoSelectvalue]); + if Expression is TSQLAsteriskExpression then begin If Singleton then Error(SErrNoAsteriskInSingleTon); - AList.Add(CreateElement(TSQLSelectAsterisk,AParent)); - GetNextToken; + A:=TSQLSelectAsterisk(CreateElement(TSQLSelectAsterisk,AParent)); + AList.Add(A); + A.Expression:=TSQLAsteriskExpression(Expression); end else begin F:=TSQLSelectField(CreateElement(TSQLSelectField,AParent)); AList.Add(F); - F.Expression:=ParseExprLevel1(AParent,[eoSelectvalue]); + F.Expression:=Expression; If CurrentToken in [tsqlAs,Tsqlidentifier] then begin If currentToken=tsqlAs then @@ -2741,6 +2745,7 @@ Var N : String; C : TSQLElementClass; E : TSQLExtractElement; + IdentifierPath : TSQLIdentifierPath; begin Result:=Nil; @@ -2852,6 +2857,11 @@ begin TSQLParameterExpression(Result).Identifier:=CreateIdentifier(Result,N); Consume(tsqlIdentifier); end; + tsqlMUL: + begin + Result:=TSQLAsteriskExpression(CreateElement(TSQLAsteriskExpression,APArent)); + GetNextToken; + end; tsqlIdentifier: begin N:=CurrentTokenString; @@ -2860,18 +2870,30 @@ begin If (eoCheckConstraint in EO) and not (eoTableConstraint in EO) then Error(SErrUnexpectedToken,[CurrentTokenString]); // Plain identifier - Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent)); - TSQLIdentifierExpression(Result).IdentifierPath.Add(CreateIdentifier(Result,N)); + IdentifierPath:=TSQLIdentifierPath.Create; + IdentifierPath.Add(CreateIdentifier(Result,N)); while (CurrentToken=tsqlDot) do begin GetNextToken; - Expect(tsqlIdentifier); - N:=CurrentTokenString; - TSQLIdentifierExpression(Result).IdentifierPath.Add(CreateIdentifier(Result,N)); - GetNextToken; + if CurrentToken=tsqlMUL then + begin + Result:=TSQLAsteriskExpression(CreateElement(TSQLAsteriskExpression,APArent)); + GetNextToken; + break; + end + else + begin + Expect(tsqlIdentifier); + N:=CurrentTokenString; + IdentifierPath.Add(CreateIdentifier(Result,N)); + GetNextToken; + end; end; + if not Assigned(Result) then + Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent)); + TSQLIdentifierPathExpression(Result).IdentifierPath:=IdentifierPath; // Array access ? - If (CurrentToken=tsqlSquareBraceOpen) then + If (CurrentToken=tsqlSquareBraceOpen) and (Result is TSQLIdentifierExpression) then // Either something like array[5] or, // in procedures etc array[i:] where i is a variable begin diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index f3a4bb2cc4..e489c6f265 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -195,24 +195,39 @@ Type Property Identifiers[AIndex : Integer] : TSQLIdentifierName Read GetI Write SetI; default; end; + { TSQLIdentifierPathExpression } + + TSQLIdentifierPathExpression = Class(TSQLExpression) + private + FIdentifierPath: TSQLIdentifierPath; + Public + Destructor Destroy; override; + Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; + Property IdentifierPath: TSQLIdentifierPath Read FIdentifierPath Write FIdentifierPath; + end; + { TSQLIdentifierExpression } - TSQLIdentifierExpression = Class(TSQLExpression) + TSQLIdentifierExpression = Class(TSQLIdentifierPathExpression) private FElementIndex: Integer; - FIdentifierPath: TSQLIdentifierPath; function GetIdentifier: TSQLIdentifierName; procedure SetIdentifier(const AName: TSQLIdentifierName); Public Constructor Create(AParent : TSQLElement); override; - Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; Property Identifier : TSQLIdentifierName Read GetIdentifier Write SetIdentifier; - Property IdentifierPath: TSQLIdentifierPath Read FIdentifierPath; // For array types: index of element in array Property ElementIndex : Integer Read FElementIndex Write FElementIndex; end; + { TSQLAsteriskExpression } + + TSQLAsteriskExpression = Class(TSQLIdentifierPathExpression) + Public + Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; + end; + { TSQLParameterExpression } TSQLParameterExpression = Class(TSQLExpression) @@ -597,19 +612,33 @@ Type { TSelectField } - TSQLSelectElement = Class(TSQLElement); - TSQLSelectAsterisk = Class(TSQLSelectElement); + TSQLSelectElement = Class(TSQLElement) + private + FExpression: TSQLExpression; + Public + Destructor Destroy; override; + Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; + Property Expression : TSQLExpression Read FExpression Write FExpression; + end; + + { TSQLSelectAsterisk } + + TSQLSelectAsterisk = Class(TSQLSelectElement) + private + function GetExpression: TSQLAsteriskExpression; + procedure SetExpression(const AExpression: TSQLAsteriskExpression); + Public + Property Expression : TSQLAsteriskExpression Read GetExpression Write SetExpression; + end; { TSQLSelectField } TSQLSelectField = Class(TSQLSelectElement) private FAliasName: TSQLIdentifierName; - FExpression: TSQLExpression; Public Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; - Property Expression : TSQLExpression Read FExpression Write FExpression; Property AliasName : TSQLIdentifierName Read FAliasName Write FAliasName; end; @@ -1972,6 +2001,73 @@ begin Sep:=', '; end; +{ TSQLAsteriskExpression } + +function TSQLAsteriskExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; +begin + Result := inherited GetAsSQL(Options, AIndent); + if Result<>'' then + Result:=Result+'.'; + Result:=Result+'*'; +end; + +{ TSQLIdentifierExpression } + +constructor TSQLIdentifierExpression.Create(AParent: TSQLElement); +begin + inherited Create(AParent); + FElementIndex:=-1; +end; + +function TSQLIdentifierExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; +begin + Result := inherited GetAsSQL(Options, AIndent); + If (ElementIndex<>-1) then + Result:=Result+Format('[%d]',[Elementindex]); +end; + +function TSQLIdentifierExpression.GetIdentifier: TSQLIdentifierName; +begin + Result := TSQLIdentifierName(FIdentifierPath.Last); +end; + +procedure TSQLIdentifierExpression.SetIdentifier(const AName: TSQLIdentifierName); +begin + if Assigned(FIdentifierPath) then + FIdentifierPath.Clear + else + FIdentifierPath:=TSQLIdentifierPath.Create; + FIdentifierPath.Add(AName); +end; + +{ TSQLSelectElement } + +destructor TSQLSelectElement.Destroy; +begin + FreeAndNil(FExpression); + inherited Destroy; +end; + +function TSQLSelectElement.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType; +begin + If Assigned(FExpression) then + Result:=FExpression.GetAsSQL(Options) + Else + Result:=''; +end; + +{ TSQLSelectAsterisk } + +function TSQLSelectAsterisk.GetExpression: TSQLAsteriskExpression; +begin + Result:=TSQLAsteriskExpression(inherited Expression) +end; + +procedure TSQLSelectAsterisk.SetExpression(const AExpression: TSQLAsteriskExpression); +begin + inherited Expression:=AExpression; +end; + { TSQLIdentifierPath } function TSQLIdentifierPath.Add(AName: TSQLIdentifierName): Integer; @@ -3245,15 +3341,13 @@ end; destructor TSQLSelectField.Destroy; begin - FreeAndNil(FExpression); FreeAndNil(FAliasName); inherited Destroy; end; function TSQLSelectField.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; begin - If Assigned(FExpression) then - Result:=FExpression.GetAsSQL(Options); + Result := inherited GetAsSQL(Options, AIndent); If Assigned(FAliasName) then Result:=Result+' AS '+FAliasName.GetAsSQL(Options); end; @@ -4289,37 +4383,20 @@ begin Result:=Result+sp+SQLKeyWord('MODULE_NAME ',Options)+SQLFormatString(ModuleName,Options); end; -{ TSQLIdentifierExpression } +{ TSQLIdentifierPathExpression } -constructor TSQLIdentifierExpression.Create(AParent: TSQLElement); -begin - inherited Create(AParent); - FIdentifierPath:=TSQLIdentifierPath.Create; - FElementIndex:=-1; -end; - -destructor TSQLIdentifierExpression.Destroy; +destructor TSQLIdentifierPathExpression.Destroy; begin FreeAndNil(FIdentifierPath); inherited Destroy; end; -function TSQLIdentifierExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; +function TSQLIdentifierPathExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; begin - Result := FIdentifierPath.GetAsSQL(Options, AIndent); - If (ElementIndex<>-1) then - Result:=Result+Format('[%d]',[Elementindex]); -end; - -function TSQLIdentifierExpression.GetIdentifier: TSQLIdentifierName; -begin - Result := TSQLIdentifierName(FIdentifierPath.Last); -end; - -procedure TSQLIdentifierExpression.SetIdentifier(const AName: TSQLIdentifierName); -begin - FIdentifierPath.Clear; - FIdentifierPath.Add(AName); + if Assigned(FIdentifierPath) then + Result:=FIdentifierPath.GetAsSQL(Options, AIndent) + else + Result:=''; end; { TSQLSelectExpression } diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 2ab8b4879e..09d953611c 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -400,6 +400,7 @@ type procedure TestSelectOneAllFieldOneTable; procedure TestSelectAsteriskOneTable; procedure TestSelectDistinctAsteriskOneTable; + procedure TestSelectAsteriskWithPath; procedure TestSelectOneFieldOneTableAlias; procedure TestSelectOneFieldOneTableAsAlias; procedure TestSelectTwoFieldsTwoTables; @@ -3993,6 +3994,17 @@ begin AssertTable(Select.Tables[0],'A'); end; +procedure TTestSelectParser.TestSelectAsteriskWithPath; +begin + TestSelect('SELECT A.* FROM A'); + AssertEquals('One field',1,Select.Fields.Count); + CheckClass(Select.Fields[0],TSQLSelectAsterisk); + AssertEquals('Path count = 1',1,TSQLSelectAsterisk(Select.Fields[0]).Expression.IdentifierPath.Count); + AssertEquals('Path table = A','A',TSQLSelectAsterisk(Select.Fields[0]).Expression.IdentifierPath[0].Name); + AssertEquals('One table',1,Select.Tables.Count); + AssertTable(Select.Tables[0],'A'); +end; + procedure TTestSelectParser.TestSelectDistinctAsteriskOneTable; begin TestSelect('SELECT DISTINCT * FROM A'); From f89650c4706eaa76ad62c5033e6fb0cc7f474a18 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 19:14:37 +0000 Subject: [PATCH 19/21] sql parser: fix A*B, A/B and add tests git-svn-id: trunk@46437 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 1 + packages/fcl-db/tests/tcparser.pas | 56 +++++++++++++++++++++++++ 2 files changed, 57 insertions(+) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index e893c1e594..e245383bf7 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -2539,6 +2539,7 @@ begin Right:=ParseExprLevel5(AParent,EO); B:=TSQLBinaryExpression(CreateElement(TSQLBinaryExpression,AParent)); B.Left:=Result; + Result:=B; B.Right:=Right; Case tt of tsqlMul : B.Operation:=boMultiply; diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index 09d953611c..eac08bbc51 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -231,6 +231,10 @@ type procedure TestOr; procedure TestNotOr; procedure TestCase; + procedure TestAdd; + procedure TestSubtract; + procedure TestMultiply; + procedure TestDivide; end; { TTestDomainParser } @@ -2123,6 +2127,19 @@ begin AssertLiteralExpr('Right is string',B.Right,TSQLStringLiteral); end; +procedure TTestCheckParser.TestDivide; + +Var + B : TSQLBinaryExpression; + +begin + B:=TSQLBinaryExpression(TestCheck('VALUE / 1',TSQLBinaryExpression)); + AssertEquals('Correct operator', boDivide, B.Operation); + AssertLiteralExpr('Left is value',B.Left,TSQLValueLiteral); + AssertLiteralExpr('Right is integer',B.Right,TSQLIntegerLiteral); + AssertEquals('Right is 1',1, TSQLIntegerLiteral(TSQLLiteralExpression(B.Right).Literal).Value); +end; + procedure TTestCheckParser.TestNotContaining; Var @@ -2177,6 +2194,19 @@ begin AssertLiteralExpr('Right is string',B.Right,TSQLStringLiteral); end; +procedure TTestCheckParser.TestSubtract; + +Var + B : TSQLBinaryExpression; + +begin + B:=TSQLBinaryExpression(TestCheck('VALUE - 1',TSQLBinaryExpression)); + AssertEquals('Correct operator', boSubtract, B.Operation); + AssertLiteralExpr('Left is value',B.Left,TSQLValueLiteral); + AssertLiteralExpr('Right is integer',B.Right,TSQLIntegerLiteral); + AssertEquals('Right is 1',1, TSQLIntegerLiteral(TSQLLiteralExpression(B.Right).Literal).Value); +end; + procedure TTestCheckParser.TestNotStartingWith; Var @@ -2264,6 +2294,19 @@ begin AssertLiteralExpr('Right is string',T.Right,TSQLStringLiteral); end; +procedure TTestCheckParser.TestMultiply; + +Var + B : TSQLBinaryExpression; + +begin + B:=TSQLBinaryExpression(TestCheck('VALUE * 1',TSQLBinaryExpression)); + AssertEquals('Correct operator', boMultiply, B.Operation); + AssertLiteralExpr('Left is value',B.Left,TSQLValueLiteral); + AssertLiteralExpr('Right is integer',B.Right,TSQLIntegerLiteral); + AssertEquals('Right is 1',1, TSQLIntegerLiteral(TSQLLiteralExpression(B.Right).Literal).Value); +end; + procedure TTestCheckParser.TestNotLikeEscape; Var U : TSQLUnaryExpression; @@ -2280,6 +2323,19 @@ begin AssertLiteralExpr('Right is string',T.Right,TSQLStringLiteral); end; +procedure TTestCheckParser.TestAdd; + +Var + B : TSQLBinaryExpression; + +begin + B:=TSQLBinaryExpression(TestCheck('VALUE + 1',TSQLBinaryExpression)); + AssertEquals('Correct operator', boAdd, B.Operation); + AssertLiteralExpr('Left is value',B.Left,TSQLValueLiteral); + AssertLiteralExpr('Right is integer',B.Right,TSQLIntegerLiteral); + AssertEquals('Right is 1',1, TSQLIntegerLiteral(TSQLLiteralExpression(B.Right).Literal).Value); +end; + procedure TTestCheckParser.TestAnd; Var From 98036f52be23acb93c458284a3eebcd29da33f28 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 19:23:45 +0000 Subject: [PATCH 20/21] sql parser: support SELECT without a FROM clause git-svn-id: trunk@46438 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 6 ++++-- packages/fcl-db/tests/tcparser.pas | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index e245383bf7..51deec85ce 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -504,8 +504,8 @@ begin GetNextToken; end; end; - Expect([tsqlComma,tsqlFrom]); - until (CurrentToken=tsqlFROM); + Expect([tsqlComma,tsqlFrom,tsqlEOF]); + until (CurrentToken in [tsqlFROM,tsqlEOF]); end; procedure TSQLParser.ParseGroupBy(AParent: TSQLSelectStatement; @@ -719,6 +719,8 @@ begin Result.TransactionName:=CreateIdentifier(Result,CurrentTokenString); end; ParseSelectFieldList(Result,Result.Fields,sfSingleton in Flags); + If CurrentToken=tsqlEOF then + Exit; // On return, we are on the FROM keyword. ParseFromClause(Result,Result.Tables); If CurrentToken=tsqlWhere then diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index eac08bbc51..fbcd5c110d 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -493,6 +493,7 @@ type procedure TestWhereSome; procedure TestParam; procedure TestParamExpr; + procedure TestNoTable; procedure TestSourcePosition; end; @@ -4769,6 +4770,23 @@ begin AssertAggregateExpression(H.Left,afCount,'C',aoNone); end; +procedure TTestSelectParser.TestNoTable; + +Var + F : TSQLSelectField; + L : TSQLIntegerLiteral; + +begin + TestSelect('SELECT 1'); + AssertEquals('0 tables in select',0,Select.Tables.Count); + AssertEquals('1 field in select',1,Select.Fields.Count); + AssertNotNull('Have field',Select.Fields[0]); + F:=TSQLSelectField(CheckClass(Select.Fields[0],TSQLSelectField)); + AssertNotNull('Have field expresssion,',F.Expression); + L:=TSQLIntegerLiteral(AssertLiteralExpr('Field is a literal',F.Expression,TSQLIntegerLiteral)); + AssertEquals('SELECT 1',1,L.Value); +end; + procedure TTestSelectParser.TestUnionSimple; Var From 672e59317afd0702cfeeb64aff47a5814f6f7d37 Mon Sep 17 00:00:00 2001 From: ondrej Date: Fri, 14 Aug 2020 19:56:36 +0000 Subject: [PATCH 21/21] sql parser: add source position information to element lists git-svn-id: trunk@46439 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 15 +++++++++++++++ packages/fcl-db/src/sql/fpsqltree.pp | 8 ++++++++ packages/fcl-db/tests/tcparser.pas | 16 ++++++++++++---- 3 files changed, 35 insertions(+), 4 deletions(-) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index 51deec85ce..893fef5b9a 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -421,6 +421,9 @@ Var begin // On entry, we are on the FROM keyword. + AList.Source:=CurSource; + AList.SourceLine:=CurrentTokenLine; + AList.SourcePos:=CurrentTokenPos; Consume(tsqlFrom); Repeat T:=ParseTableRef(AParent); @@ -441,6 +444,9 @@ Var begin // On entry, we're on the token preceding the field list. + AList.Source:=CurSource; + AList.SourceLine:=CurrentTokenLine; + AList.SourcePos:=CurrentTokenPos; B:=True; Repeat GetNextToken; @@ -516,6 +522,9 @@ Var begin // On entry we're on the GROUP token. + AList.Source:=CurSource; + AList.SourceLine:=CurrentTokenLine; + AList.SourcePos:=CurrentTokenPos; Consume(tsqlGroup); Expect(tsqlBy); Repeat @@ -565,6 +574,9 @@ Var begin // On entry we're on the ORDER token. + AList.Source:=CurSource; + AList.SourceLine:=CurrentTokenLine; + AList.SourcePos:=CurrentTokenPos; Consume(tsqlOrder); Expect(tsqlBy); Repeat @@ -2629,6 +2641,9 @@ function TSQLParser.ParseIdentifierList(AParent: TSQLElement; begin // on entry, we're on first identifier + AList.Source:=CurSource; + AList.SourceLine:=CurrentTokenLine; + AList.SourcePos:=CurrentTokenPos; Expect(tsqlIdentifier); Result:=0; repeat diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index e489c6f265..8b93816310 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -91,10 +91,18 @@ Type TSQLElementList = Class(TObjectList) private + Fline: Integer; + FPos: Integer; + FSource: String; + function GetE(AIndex : Integer): TSQLElement; procedure SetE(AIndex : Integer; const AValue: TSQLElement); Public Property Elements[AIndex : Integer] : TSQLElement Read GetE Write SetE; default; + + Property Source : String Read FSource write FSource; + Property SourceLine : Integer Read Fline Write Fline; + Property SourcePos : Integer Read FPos Write FPos; end; TSQLLiteral = Class(TSQLElement); diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index fbcd5c110d..fc62c71650 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -4132,14 +4132,22 @@ end; procedure TTestSelectParser.TestSourcePosition; begin - TestSelect('SELECT X FROM ABC'); + TestSelect('SELECT X FROM ABC ORDER BY Y'); AssertEquals('One table',1,Select.Tables.Count); - AssertEquals('Table source position = 1', 1, Select.Tables[0].SourceLine); + AssertEquals('FROM source line = 1', 1, Select.Tables.SourceLine); + AssertEquals('FROM source position = 10', 10, Select.Tables.SourcePos); + AssertEquals('ORDER BY source line = 1', 1, Select.Orderby.SourceLine); + AssertEquals('ORDER BY source position = 19', 19, Select.Orderby.SourcePos); + AssertEquals('Table source line = 1', 1, Select.Tables[0].SourceLine); AssertEquals('Table source position = 15', 15, Select.Tables[0].SourcePos); - TestSelect('SELECT X'+sLineBreak+'FROM ABC'); + TestSelect('SELECT X'+sLineBreak+'FROM ABC'+sLineBreak+'ORDER BY Y'); AssertEquals('One table',1,Select.Tables.Count); - AssertEquals('Table source position = 2', 2, Select.Tables[0].SourceLine); + AssertEquals('FROM source line = 2', 2, Select.Tables.SourceLine); + AssertEquals('FROM source position = 1', 1, Select.Tables.SourcePos); + AssertEquals('ORDER BY source line = 3', 3, Select.Orderby.SourceLine); + AssertEquals('ORDER BY source position = 1', 1, Select.Orderby.SourcePos); + AssertEquals('Table source line = 2', 2, Select.Tables[0].SourceLine); AssertEquals('Table source position = 6', 6, Select.Tables[0].SourcePos); end;