paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 13:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46440 -
This commit is contained in:
nickysn 2020-08-15 00:44:32 +00:00
commit 93789508fb
17 changed files with 977 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -16595,6 +16595,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

7
compiler/i8086/hlcgcpu.pas
View File

@ -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;

2
compiler/optloop.pas
View File

@ -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);

3
compiler/pdecsub.pas
View File

@ -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;

10
compiler/scanner.pas
View File

@ -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')

1
compiler/x86/agx86nsm.pas
View File

@ -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

204
packages/fcl-db/src/sql/fpsqlparser.pas
View File

@ -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;
@ -77,6 +81,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;
@ -126,6 +131,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;
@ -169,8 +175,10 @@ 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;
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
@ -323,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
@ -345,8 +353,15 @@ begin
Expect(tsqlIdentifier);
T:=TSQLSimpleTableReference(CreateElement(TSQLSimpleTableReference,AParent));
Result:=T;
T.ObjectName:=CreateIdentifier(T,CurrentTokenString);
T.ObjectNamePath.Add(CreateIdentifier(T,CurrentTokenString));
GetNextToken;
while CurrentToken=tsqlDOT do
begin
GetNextToken;
Expect(tsqlIdentifier);
T.ObjectNamePath.Add(CreateIdentifier(T,CurrentTokenString));
GetNextToken;
end;
If CurrentToken=tsqlBraceOpen then
begin
T.Params:=ParseValueList(AParent,[eoParamValue]);
@ -406,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);
@ -420,15 +438,43 @@ 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.
AList.Source:=CurSource;
AList.SourceLine:=CurrentTokenLine;
AList.SourcePos:=CurrentTokenPos;
B:=True;
Repeat
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;
@ -441,18 +487,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
@ -462,8 +510,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;
@ -474,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
@ -523,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
@ -677,6 +731,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
@ -714,6 +770,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;
@ -1298,6 +1356,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
@ -1312,6 +1398,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
@ -2427,6 +2553,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;
@ -2514,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
@ -2633,6 +2763,7 @@ Var
N : String;
C : TSQLElementClass;
E : TSQLExtractElement;
IdentifierPath : TSQLIdentifierPath;
begin
Result:=Nil;
@ -2660,6 +2791,7 @@ begin
TSQLCastExpression(Result).NewType:=ParseTypeDefinition(Result,[ptfCast]);
Consume(tsqlBraceClose);
end;
tsqlCase: Result:=ParseCaseExpression(AParent);
tsqlExtract:
begin
GetNextToken;
@ -2743,6 +2875,11 @@ begin
TSQLParameterExpression(Result).Identifier:=CreateIdentifier(Result,N);
Consume(tsqlIdentifier);
end;
tsqlMUL:
begin
Result:=TSQLAsteriskExpression(CreateElement(TSQLAsteriskExpression,APArent));
GetNextToken;
end;
tsqlIdentifier:
begin
N:=CurrentTokenString;
@ -2750,18 +2887,31 @@ begin
begin
If (eoCheckConstraint in EO) and not (eoTableConstraint in EO) then
Error(SErrUnexpectedToken,[CurrentTokenString]);
If (CurrentToken=tsqlDot) then
// Plain identifier
IdentifierPath:=TSQLIdentifierPath.Create;
IdentifierPath.Add(CreateIdentifier(Result,N));
while (CurrentToken=tsqlDot) do
begin
GetNextToken;
Expect(tsqlIdentifier);
N:=N+'.'+CurrentTokenString;
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;
// Plain identifier
Result:=TSQLIdentifierExpression(CreateElement(TSQLIdentifierExpression,APArent));
TSQLIdentifierExpression(Result).Identifier:=CreateIdentifier(Result,N);
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
@ -4055,16 +4205,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;
@ -4073,6 +4213,8 @@ begin
begin
FCurrent:=FPeekToken;
FCurrentString:=FPeekTokenString;
FCurrentTokenLine:=FPeekTokenLine;
FCurrentTokenPos:=FPeekTokenPos;
FPeekToken:=tsqlUnknown;
FPeekTokenString:='';
end
@ -4080,6 +4222,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}
@ -4091,6 +4235,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;

45
packages/fcl-db/src/sql/fpsqlscanner.pp
View File

@ -51,23 +51,23 @@ 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,
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
@ -97,23 +97,23 @@ 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',
'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'
@ -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;
@ -174,6 +175,8 @@ Type
FCurRow: Integer;
FCurToken: TSQLToken;
FCurTokenString: string;
FCurTokenRow: Integer;
FCurTokenColumn: Integer;
FCurLine: string;
TokenStr: PChar;
FSourceStream : TStream;
@ -218,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;
@ -513,6 +518,8 @@ Var
begin
Delim:=TokenStr[0];
if Delim='[' then
Delim:=']';
Inc(TokenStr);
TokenStart := TokenStr;
OLen := 0;
@ -716,6 +723,8 @@ begin
FCurToken := Result;
exit;
end;
FCurTokenRow:=CurRow;
FCurTokenColumn:=CurColumn;
FCurTokenString := '';
case TokenStr[0] of
#0: // Empty line
@ -792,8 +801,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
@ -900,7 +917,7 @@ end;
function TSQLScanner.GetCurColumn: Integer;
begin
Result := TokenStr - PChar(FCurLine);
Result := TokenStr - PChar(FCurLine) + 1;
end;
Procedure TSQLScanner.ClearKeywords(Sender : TObject);

364
packages/fcl-db/src/sql/fpsqltree.pp
View File

@ -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);
@ -183,21 +191,51 @@ Type
Property Literal : TSQLLiteral Read FLiteral write FLiteral;
end;
{ TSQLIdentifierExpression }
{ TSQLIdentifierPath }
TSQLIdentifierExpression = Class(TSQLExpression)
TSQLIdentifierPath = Class(TSQLElementList)
private
FElementIndex: Integer;
FIdentifier: TSQLIdentifierName;
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;
{ TSQLIdentifierPathExpression }
TSQLIdentifierPathExpression = Class(TSQLExpression)
private
FIdentifierPath: TSQLIdentifierPath;
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 IdentifierPath: TSQLIdentifierPath Read FIdentifierPath Write FIdentifierPath;
end;
{ TSQLIdentifierExpression }
TSQLIdentifierExpression = Class(TSQLIdentifierPathExpression)
private
FElementIndex: Integer;
function GetIdentifier: TSQLIdentifierName;
procedure SetIdentifier(const AName: TSQLIdentifierName);
Public
Constructor Create(AParent : TSQLElement); override;
Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override;
Property Identifier : TSQLIdentifierName Read GetIdentifier Write SetIdentifier;
// 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)
@ -582,19 +620,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;
@ -607,12 +659,16 @@ Type
TSQLSimpleTableReference = Class(TSQLTableReference)
private
FAliasName: TSQLIdentifierName;
FObjectName: TSQLIdentifierName;
FObjectNamePath: TSQLIdentifierPath;
FParams: TSQLElementList;
function GetObjectName: TSQLIdentifierName;
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 FObjectName Write FObjectName;
Property ObjectName : TSQLIdentifierName Read GetObjectName Write SetObjectName;
Property ObjectNamePath : TSQLIdentifierPath Read FObjectNamePath;
Property Params : TSQLElementList Read FParams Write FParams;
Property AliasName : TSQLIdentifierName Read FAliasName Write FAliasName;
end;
@ -710,11 +766,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;
@ -744,6 +821,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;
@ -1373,6 +1451,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)
@ -1899,6 +2009,169 @@ 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;
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;
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;
begin
inherited Create;
FSkip:=-1;
FRowCount:=-1;
end;
{ TSQLSetTermStatement }
function TSQLSetTermStatement.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType;
@ -1978,6 +2251,7 @@ begin
FTables:=TSQLElementList.Create(True);
FGroupBy:=TSQLElementList.Create(True);
FOrderBy:=TSQLElementList.Create(True);
FLimit:=TSQLSelectLimit.Create;
end;
destructor TSQLSelectStatement.Destroy;
@ -1995,6 +2269,7 @@ begin
FreeAndNil(FForUpdate);
FreeAndNil(FTN);
FreeAndNil(FInto);
FreeAndNil(FLimit);
inherited Destroy;
end;
@ -2062,6 +2337,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);
@ -2077,6 +2361,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 }
@ -3058,24 +3349,28 @@ 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;
{ TSQLSimpleTableReference }
constructor TSQLSimpleTableReference.Create(AParent: TSQLElement);
begin
inherited Create(AParent);
FObjectNamePath:=TSQLIdentifierPath.Create;
end;
destructor TSQLSimpleTableReference.Destroy;
begin
FreeAndNil(FObjectName);
FreeAndNil(FObjectNamePath);
FreeAndNil(FParams);
FreeAndNil(FAliasName);
inherited Destroy;
@ -3085,7 +3380,6 @@ function TSQLSimpleTableReference.GetAsSQL(Options: TSQLFormatOptions; AIndent :
Var
I : integer;
begin
Result:='';
If Assigned(FParams) and (FParams.Count>0) then
@ -3098,12 +3392,22 @@ begin
end;
Result:='('+Result+')';
end;
If Assigned(FObjectname) then
Result:= FObjectName.GetAsSQL(Options)+Result;
Result:= FObjectNamePath.GetAsSQL(Options, AIndent)+Result;
if Assigned(FAliasName) then
Result:=Result+' '+FAliasName.GetAsSQL(Options);
end;
function TSQLSimpleTableReference.GetObjectName: TSQLIdentifierName;
begin
Result := TSQLIdentifierName(FObjectNamePath.Last);
end;
procedure TSQLSimpleTableReference.SetObjectName(const AName: TSQLIdentifierName);
begin
FObjectNamePath.Clear;
FObjectNamePath.Add(AName);
end;
{ TSQLJoinTableReference }
destructor TSQLJoinTableReference.Destroy;
@ -4087,26 +4391,20 @@ begin
Result:=Result+sp+SQLKeyWord('MODULE_NAME ',Options)+SQLFormatString(ModuleName,Options);
end;
{ TSQLIdentifierExpression }
{ TSQLIdentifierPathExpression }
constructor TSQLIdentifierExpression.Create(AParent: TSQLElement);
destructor TSQLIdentifierPathExpression.Destroy;
begin
inherited Create(AParent);
FElementIndex:=-1;
end;
destructor TSQLIdentifierExpression.Destroy;
begin
FreeAndNil(FIdentifier);
FreeAndNil(FIdentifierPath);
inherited Destroy;
end;
function TSQLIdentifierExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType;
function TSQLIdentifierPathExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType;
begin
If Assigned(FIdentifier) then
Result:= Identifier.GetAsSQL(Options);
If (ElementIndex<>-1) then
Result:=Result+Format('[%d]',[Elementindex]);
if Assigned(FIdentifierPath) then
Result:=FIdentifierPath.GetAsSQL(Options, AIndent)
else
Result:='';
end;
{ TSQLSelectExpression }

79
packages/fcl-db/tests/tcgensql.pas
View File

@ -64,10 +64,12 @@ type
Procedure TestValueLiteral;
Procedure TestLiteralExpression;
Procedure TestSelectField;
Procedure TestSelectFieldWithPath;
Procedure TestSimpleTablereference;
Procedure TestSimpleSelect;
Procedure TestAnyExpression;
procedure TestAllExpression;
procedure TestCaseExpression;
procedure TestExistsExpression;
procedure TestSomeExpression;
procedure TestSingularExpression;
@ -96,6 +98,7 @@ type
procedure TestPlanExpression;
procedure TestOrderBy;
Procedure TestSelect;
Procedure TestLimit;
procedure TestInsert;
procedure TestUpdatePair;
procedure TestUpdate;
@ -416,6 +419,24 @@ begin
AssertSQL(F,'A AS B');
end;
procedure TTestGenerateSQL.TestSelectFieldWithPath;
Var
I : TSQLIdentifierExpression;
F : TSQLSelectField;
begin
I:=CreateIdentifierExpression('A');
I.IdentifierPath.Add(CreateIdentifier('B'));
I.IdentifierPath.Add(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
@ -796,7 +817,7 @@ begin
AssertSQL(U,'constraint C unique (A , B)',[sfoLowercaseKeyWord]);
end;
procedure TTestGenerateSQL.TestTableprimaryKeyConstraintDef;
procedure TTestGenerateSQL.TestTablePrimaryKeyConstraintDef;
Var
U : TSQLTablePrimaryKeyConstraintDef;
@ -976,6 +997,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
@ -1825,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

284
packages/fcl-db/tests/tcparser.pas
View File

@ -230,6 +230,11 @@ type
procedure TestAnd;
procedure TestOr;
procedure TestNotOr;
procedure TestCase;
procedure TestAdd;
procedure TestSubtract;
procedure TestMultiply;
procedure TestDivide;
end;
{ TTestDomainParser }
@ -399,6 +404,7 @@ type
procedure TestSelectOneAllFieldOneTable;
procedure TestSelectAsteriskOneTable;
procedure TestSelectDistinctAsteriskOneTable;
procedure TestSelectAsteriskWithPath;
procedure TestSelectOneFieldOneTableAlias;
procedure TestSelectOneFieldOneTableAsAlias;
procedure TestSelectTwoFieldsTwoTables;
@ -411,6 +417,17 @@ type
procedure TestSelectTwoFieldsThreeTablesJoin;
procedure TestSelectTwoFieldsBracketThreeTablesJoin;
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;
@ -476,6 +493,8 @@ type
procedure TestWhereSome;
procedure TestParam;
procedure TestParamExpr;
procedure TestNoTable;
procedure TestSourcePosition;
end;
{ TTestRollBackParser }
@ -2109,6 +2128,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
@ -2163,6 +2195,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
@ -2192,6 +2237,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
@ -2222,6 +2295,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;
@ -2238,6 +2324,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
@ -3736,6 +3835,93 @@ 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.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).ObjectNamePath.Count);
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');
@ -3801,16 +3987,41 @@ 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 <link to table 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.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');
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);
AssertTable(Select.Tables[0],'A','');
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;
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');
@ -3840,6 +4051,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');
@ -3851,19 +4073,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.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');
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.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');
end;
@ -3894,6 +4130,27 @@ begin
AssertJoinOn(J.JoinClause,'E','F',boEq);
end;
procedure TTestSelectParser.TestSourcePosition;
begin
TestSelect('SELECT X FROM ABC ORDER BY Y');
AssertEquals('One table',1,Select.Tables.Count);
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'+sLineBreak+'ORDER BY Y');
AssertEquals('One table',1,Select.Tables.Count);
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;
procedure TTestSelectParser.TestSelectTwoFieldsTwoInnerTablesJoin;
Var
J : TSQLJoinTableReference;
@ -4521,6 +4778,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

10
packages/fcl-db/tests/tcsqlscanner.pas
View File

@ -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]);

4
packages/fcl-passrc/src/paswrite.pp
View File

@ -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

43
rtl/objpas/sysutils/sysencoding.inc
View File

@ -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;

9
tests/webtbf/tw37475.pp Normal file
View File

@ -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.

10
utils/pas2js/libstub.pp
View File

@ -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;

10
utils/pas2js/stubcreator.pp
View File

@ -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;