From 809db09169a8d95117fb9a3db4e63d62823a99aa Mon Sep 17 00:00:00 2001 From: ondrej Date: Wed, 19 Aug 2020 08:45:00 +0000 Subject: [PATCH 1/7] sql parser: support CASE with selector (CASE A WHEN 1 THEN B ELSE C END) git-svn-id: trunk@46489 - --- packages/fcl-db/src/sql/fpsqlparser.pas | 2 ++ packages/fcl-db/src/sql/fpsqltree.pp | 5 ++++ packages/fcl-db/tests/tcparser.pas | 31 +++++++++++++++++++++++++ 3 files changed, 38 insertions(+) diff --git a/packages/fcl-db/src/sql/fpsqlparser.pas b/packages/fcl-db/src/sql/fpsqlparser.pas index d6bc986933..a5c9d50dd0 100644 --- a/packages/fcl-db/src/sql/fpsqlparser.pas +++ b/packages/fcl-db/src/sql/fpsqlparser.pas @@ -1363,6 +1363,8 @@ begin Consume(tsqlCASE); Result:=TSQLCaseExpression(CreateElement(TSQLCaseExpression,AParent)); try + if CurrentToken<>tsqlWhen then // case A when 1 the 2 when 3 then 4 else 5 + Result.Selector:=ParseExprLevel1(AParent,[eoIF]); while CurrentToken=tsqlWhen do begin GetNextToken; diff --git a/packages/fcl-db/src/sql/fpsqltree.pp b/packages/fcl-db/src/sql/fpsqltree.pp index ab27552f1c..9cf3a2638d 100644 --- a/packages/fcl-db/src/sql/fpsqltree.pp +++ b/packages/fcl-db/src/sql/fpsqltree.pp @@ -1469,6 +1469,7 @@ Type TSQLCaseExpression = Class(TSQLExpression) private + FSelector: TSQLExpression; FBranches: array of TSQLCaseExpressionBranch; FElseBranch: TSQLExpression; function GetBranch(Index: Integer): TSQLCaseExpressionBranch; @@ -1477,6 +1478,7 @@ Type Destructor Destroy; override; Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override; + Property Selector: TSQLExpression Read FSelector Write FSelector; Property BranchCount: Integer Read GetBranchCount; Procedure AddBranch(ABranch: TSQLCaseExpressionBranch); Procedure ClearBranches; @@ -2137,6 +2139,7 @@ destructor TSQLCaseExpression.Destroy; begin ClearBranches; FreeAndNil(FElseBranch); + FreeAndNil(FSelector); inherited Destroy; end; @@ -2145,6 +2148,8 @@ var B: TSQLCaseExpressionBranch; begin Result:=SQLKeyWord('CASE',Options)+' '; + if Assigned(Selector) then + Result:=Result+Selector.GetAsSQL(Options,AIndent)+' '; for B in FBranches do Result:=Result+ SQLKeyWord('WHEN ',Options)+B.Condition.GetAsSQL(Options, AIndent)+' '+ diff --git a/packages/fcl-db/tests/tcparser.pas b/packages/fcl-db/tests/tcparser.pas index bc141090f8..92a4e7a0a1 100644 --- a/packages/fcl-db/tests/tcparser.pas +++ b/packages/fcl-db/tests/tcparser.pas @@ -231,6 +231,7 @@ type procedure TestOr; procedure TestNotOr; procedure TestCase; + procedure TestCaseWithSelector; procedure TestAdd; procedure TestSubtract; procedure TestMultiply; @@ -2268,6 +2269,36 @@ begin AssertEquals('ELSE result is "c"', 'c', R.Name); end; +procedure TTestCheckParser.TestCaseWithSelector; + +Var + T : TSQLCaseExpression; + L : TSQLLiteralExpression; + R : TSQLIdentifierName; + +begin + T:=TSQLCaseExpression(TestCheck('CASE A WHEN 1 THEN "a" WHEN 2 THEN "b" ELSE "c" END',TSQLCaseExpression)); + AssertNotNull('Selector exists',T.Selector); + AssertEquals('Branch count = 2',2,T.BranchCount); + AssertNotNull('Else branch exists',T.ElseBranch); + + R:=(T.Selector as TSQLIdentifierExpression).Identifier; + AssertEquals('Selector identifier is "A"', 'A', R.Name); + + L:=(T.Branches[0].Condition as TSQLLiteralExpression); + R:=(T.Branches[0].Expression as TSQLIdentifierExpression).Identifier; + AssertEquals('First WHEN Number is 1', 1, (L.Literal as TSQLIntegerLiteral).Value); + AssertEquals('First THEN result is "a"', 'a', R.Name); + + L:=(T.Branches[1].Condition as TSQLLiteralExpression); + R:=(T.Branches[1].Expression as TSQLIdentifierExpression).Identifier; + AssertEquals('Second WHEN Number is 2', 2, (L.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 4873ec73a796b55e7002e8b5971189dd9ce570da Mon Sep 17 00:00:00 2001 From: yury Date: Wed, 19 Aug 2020 10:20:47 +0000 Subject: [PATCH 2/7] * 8086: Fixed loading a 32-bit ref to a register in case the target register is used as the ref base or index. git-svn-id: trunk@46490 - --- compiler/i8086/cgcpu.pas | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/compiler/i8086/cgcpu.pas b/compiler/i8086/cgcpu.pas index 91c54d162a..8547e99fca 100644 --- a/compiler/i8086/cgcpu.pas +++ b/compiler/i8086/cgcpu.pas @@ -1876,14 +1876,25 @@ unit cgcpu; end; OS_32,OS_S32: begin - { Preload the ref base to reduce spilling } - if (tmpref.base<>NR_NO) and - (tmpref.index<>NR_NO) and - (getsupreg(tmpref.base)>=first_int_imreg) then + { Preload the ref base to a new register to reduce spilling + Also preload if the first target reg is used as base or index + to prevent overwriting } + if ((tmpref.base<>NR_NO) and + (tmpref.index<>NR_NO) and + (getsupreg(tmpref.base)>=first_int_imreg)) or + (tmpref.base=reg) or + (tmpref.index=reg) then begin tmpreg:=getaddressregister(list); a_load_reg_reg(list,OS_ADDR,OS_ADDR,tmpref.base,tmpreg); tmpref.base:=tmpreg; + if tmpref.index=reg then + begin + list.concat(taicpu.op_ref_reg(A_LEA, S_W, tmpref, tmpref.base)); + tmpref.index:=NR_NO; + tmpref.offset:=0; + tmpref.scalefactor:=0; + end; end; list.concat(taicpu.op_ref_reg(A_MOV, S_W, tmpref, reg)); inc(tmpref.offset, 2); From 97eb32e6fd2216cb5e284329b4eb9758720b8a16 Mon Sep 17 00:00:00 2001 From: yury Date: Wed, 19 Aug 2020 10:27:19 +0000 Subject: [PATCH 3/7] * 8086: Also fixed loading a register to a 32-bit ref in case the source register is used as the ref base or index. git-svn-id: trunk@46491 - --- compiler/i8086/cgcpu.pas | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/compiler/i8086/cgcpu.pas b/compiler/i8086/cgcpu.pas index 8547e99fca..6896f65883 100644 --- a/compiler/i8086/cgcpu.pas +++ b/compiler/i8086/cgcpu.pas @@ -1745,14 +1745,25 @@ unit cgcpu; end; OS_32,OS_S32: begin - { Preload the ref base to reduce spilling } - if (tmpref.base<>NR_NO) and - (tmpref.index<>NR_NO) and - (getsupreg(tmpref.base)>=first_int_imreg) then + { Preload the ref base to a new register to reduce spilling + Also preload if the first source reg is used as base or index + to prevent overwriting } + if ((tmpref.base<>NR_NO) and + (tmpref.index<>NR_NO) and + (getsupreg(tmpref.base)>=first_int_imreg)) or + (tmpref.base=reg) or + (tmpref.index=reg) then begin tmpreg:=getaddressregister(list); a_load_reg_reg(list,OS_ADDR,OS_ADDR,tmpref.base,tmpreg); tmpref.base:=tmpreg; + if tmpref.index=reg then + begin + list.concat(taicpu.op_ref_reg(A_LEA, S_W, tmpref, tmpref.base)); + tmpref.index:=NR_NO; + tmpref.offset:=0; + tmpref.scalefactor:=0; + end; end; list.concat(taicpu.op_reg_ref(A_MOV, S_W, reg, tmpref)); inc(tmpref.offset, 2); From 9d41a435c2c9524623f4c6002cfcd33f3c0822d4 Mon Sep 17 00:00:00 2001 From: yury Date: Wed, 19 Aug 2020 10:48:00 +0000 Subject: [PATCH 4/7] * tinyheap: Disable inline when FPC_TINYHEAP_HUGE is defined to prevent code bloat. git-svn-id: trunk@46492 - --- rtl/inc/tinyheap.inc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/rtl/inc/tinyheap.inc b/rtl/inc/tinyheap.inc index 87a98d0e5a..f96bcf0ad3 100644 --- a/rtl/inc/tinyheap.inc +++ b/rtl/inc/tinyheap.inc @@ -63,7 +63,7 @@ procedure RegisterTinyHeapBlock(AAddress: Pointer; ASize:{$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif}); forward; - function EncodeTinyHeapFreeBlockSize(Size: PtrUInt): TTinyHeapFreeBlockSize; inline; + function EncodeTinyHeapFreeBlockSize(Size: PtrUInt): TTinyHeapFreeBlockSize; {$ifndef FPC_TINYHEAP_HUGE} inline; {$endif} begin {$ifdef FPC_TINYHEAP_HUGE} EncodeTinyHeapFreeBlockSize.OfsSize := Size and 15; @@ -73,7 +73,7 @@ {$endif FPC_TINYHEAP_HUGE} end; - function DecodeTinyHeapFreeBlockSize(Size: TTinyHeapFreeBlockSize): PtrUInt; inline; + function DecodeTinyHeapFreeBlockSize(Size: TTinyHeapFreeBlockSize): PtrUInt; {$ifndef FPC_TINYHEAP_HUGE} inline; {$endif} begin {$ifdef FPC_TINYHEAP_HUGE} DecodeTinyHeapFreeBlockSize := (PtrUInt(Size.SegSize) shl 4) + Size.OfsSize; From 1b9927961788a4f4106512a1f5e96f6d35763dce Mon Sep 17 00:00:00 2001 From: yury Date: Wed, 19 Aug 2020 10:49:40 +0000 Subject: [PATCH 5/7] * msdos: Enabled $HUGECODE for sysutils and classes to overcome 64K per unit code limit. git-svn-id: trunk@46493 - --- rtl/msdos/classes.pp | 1 + rtl/msdos/sysutils.pp | 1 + 2 files changed, 2 insertions(+) diff --git a/rtl/msdos/classes.pp b/rtl/msdos/classes.pp index f02120d2a2..180a7f8cbd 100644 --- a/rtl/msdos/classes.pp +++ b/rtl/msdos/classes.pp @@ -25,6 +25,7 @@ {$else} {$fatal Unknown i8086 memory model.} {$endif} +{$hugecode on} unit Classes; diff --git a/rtl/msdos/sysutils.pp b/rtl/msdos/sysutils.pp index 2c6e68bf21..cfa837a35e 100644 --- a/rtl/msdos/sysutils.pp +++ b/rtl/msdos/sysutils.pp @@ -25,6 +25,7 @@ interface {$H+} {$modeswitch typehelpers} {$modeswitch advancedrecords} +{$hugecode on} uses {go32,}dos; From e200fde888ff418fd79566e42a0b84c9cd2740d9 Mon Sep 17 00:00:00 2001 From: yury Date: Wed, 19 Aug 2020 11:02:29 +0000 Subject: [PATCH 6/7] * Fixed tests for 16-bit CPUs. git-svn-id: trunk@46494 - --- tests/test/dumpclass.pp | 16 ++++++++-------- tests/test/dumpmethods.pp | 6 +++--- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/test/dumpclass.pp b/tests/test/dumpclass.pp index b627dd1166..75bd502bfe 100644 --- a/tests/test/dumpclass.pp +++ b/tests/test/dumpclass.pp @@ -7,26 +7,26 @@ uses const VMT_COUNT = 100; - + ITEM_COUNT = 1000; type TMethodNameTableEntry = packed record Name: PShortstring; - Addr: Pointer; + Addr: CodePointer; end; TMethodNameTable = packed record Count: DWord; - Entries: packed array[0..9999999] of TMethodNameTableEntry; + Entries: packed array[0..ITEM_COUNT-1] of TMethodNameTableEntry; end; PMethodNameTable = ^TMethodNameTable; - TPointerArray = packed array[0..9999999] of Pointer; + TPointerArray = packed array[0..ITEM_COUNT-1] of Pointer; PPointerArray = ^TPointerArray; PFieldInfo = ^TFieldInfo; TFieldInfo = packed record - FieldOffset: LongWord; + FieldOffset: sizeuint; ClassTypeIndex: Word; Name: ShortString; end; @@ -38,7 +38,7 @@ type {$endif FPC_REQUIRES_PROPER_ALIGNMENT} record Count: Word; - Entries: array[Word] of TPersistentClass; + Entries: array[0..ITEM_COUNT-1] of ^TPersistentClass; end; PFieldTable = ^TFieldTable; @@ -103,7 +103,7 @@ var Cvmt: PPointerArray; Cmnt: PMethodNameTable; Cft: PFieldTable; - FieldOffset: LongWord; + FieldOffset: sizeuint; fi: PFieldInfo; Indent: String; n, idx: Integer; @@ -167,7 +167,7 @@ begin WriteLn(Indent, 'Field class count: ', Cft^.ClassTable^.Count); for n := 0 to Cft^.ClassTable^.Count - 1 do begin - WriteLn(Indent, ' ', n, ': ', Cft^.ClassTable^.Entries[n].ClassName); + WriteLn(Indent, ' ', n, ': ', Cft^.ClassTable^.Entries[n]^.ClassName); end; end; diff --git a/tests/test/dumpmethods.pp b/tests/test/dumpmethods.pp index 6c7e994823..f341be682e 100644 --- a/tests/test/dumpmethods.pp +++ b/tests/test/dumpmethods.pp @@ -7,7 +7,7 @@ uses const VMT_COUNT = 100; - + ITEM_COUNT = 1000; type TMethodNameTableEntry = packed record @@ -17,11 +17,11 @@ type TMethodNameTable = packed record Count: DWord; - Entries: packed array[0..9999999] of TMethodNameTableEntry; + Entries: packed array[0..ITEM_COUNT-1] of TMethodNameTableEntry; end; PMethodNameTable = ^TMethodNameTable; - TPointerArray = packed array[0..9999999] of Pointer; + TPointerArray = packed array[0..ITEM_COUNT-1] of Pointer; PPointerArray = ^TPointerArray; {$M+} From 120825d1d6976806b5e7ab02e77ef1455598b03c Mon Sep 17 00:00:00 2001 From: florian Date: Wed, 19 Aug 2020 21:09:44 +0000 Subject: [PATCH 7/7] * do not throw an internal error on illegal assembler expressions, resolves #37439 git-svn-id: trunk@46499 - --- .gitattributes | 1 + compiler/x86/rax86att.pas | 33 +++++++++++++++++---------------- tests/webtbf/tw37459.pp | 4 ++++ 3 files changed, 22 insertions(+), 16 deletions(-) create mode 100644 tests/webtbf/tw37459.pp diff --git a/.gitattributes b/.gitattributes index 70b988380e..e7009c625f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16556,6 +16556,7 @@ tests/webtbf/tw37272b.pp svneol=native#text/pascal tests/webtbf/tw37303.pp -text svneol=native#text/pascal tests/webtbf/tw3738.pp svneol=native#text/plain tests/webtbf/tw3740.pp svneol=native#text/plain +tests/webtbf/tw37459.pp svneol=native#text/pascal tests/webtbf/tw37460.pp svneol=native#text/pascal tests/webtbf/tw37462.pp svneol=native#text/pascal tests/webtbf/tw37475.pp svneol=native#text/pascal diff --git a/compiler/x86/rax86att.pas b/compiler/x86/rax86att.pas index 1014dda649..c917a0f631 100644 --- a/compiler/x86/rax86att.pas +++ b/compiler/x86/rax86att.pas @@ -720,22 +720,23 @@ Implementation if (actasmtoken=AS_PLUS) then begin l:=BuildConstExpression(true,false); - case oper.opr.typ of - OPR_CONSTANT : - inc(oper.opr.val,l); - OPR_LOCAL : - begin - inc(oper.opr.localsymofs,l); - inc(oper.opr.localconstoffset, l); - end; - OPR_REFERENCE : - begin - inc(oper.opr.ref.offset,l); - inc(oper.opr.constoffset, l); - end; - else - internalerror(200309202); - end; + if errorcount=0 then + case oper.opr.typ of + OPR_CONSTANT : + inc(oper.opr.val,l); + OPR_LOCAL : + begin + inc(oper.opr.localsymofs,l); + inc(oper.opr.localconstoffset, l); + end; + OPR_REFERENCE : + begin + inc(oper.opr.ref.offset,l); + inc(oper.opr.constoffset, l); + end; + else + internalerror(200309202); + end; end; end; end; diff --git a/tests/webtbf/tw37459.pp b/tests/webtbf/tw37459.pp new file mode 100644 index 0000000000..a57d4e8a0a --- /dev/null +++ b/tests/webtbf/tw37459.pp @@ -0,0 +1,4 @@ +{ %fail } +begin + asm test ptr + , +// end.