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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46500 -
This commit is contained in:
nickysn 2020-08-19 21:23:36 +00:00
commit 05235a1066
13 changed files with 108 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

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

38
compiler/i8086/cgcpu.pas
View File

@ -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);
@ -1876,14 +1887,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);

6
compiler/wasm32/agllvmmc.pas
View File

@ -149,9 +149,9 @@ implementation
begin
if not(tai_symbol(hp).has_value) then
begin
if tai_symbol(hp).is_global then
writer.AsmWriteLn(ApplyAsmSymbolRestrictions(tai_symbol(hp).sym.name) + '::')
else
//if tai_symbol(hp).is_global then
// writer.AsmWriteLn(ApplyAsmSymbolRestrictions(tai_symbol(hp).sym.name) + '::')
//else
writer.AsmWriteLn(ApplyAsmSymbolRestrictions(tai_symbol(hp).sym.name) + ':');
end
else

33
compiler/x86/rax86att.pas
View File

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

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

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

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

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

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

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

4
rtl/inc/tinyheap.inc
View File

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

1
rtl/msdos/classes.pp
View File

@ -25,6 +25,7 @@
{$else}
{$fatal Unknown i8086 memory model.}
{$endif}
{$hugecode on}
unit Classes;

1
rtl/msdos/sysutils.pp
View File

@ -25,6 +25,7 @@ interface
{$H+}
{$modeswitch typehelpers}
{$modeswitch advancedrecords}
{$hugecode on}
uses
{go32,}dos;

16
tests/test/dumpclass.pp
View File

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

6
tests/test/dumpmethods.pp
View File

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

4
tests/webtbf/tw37459.pp Normal file
View File

@ -0,0 +1,4 @@
{ %fail }
begin
asm test ptr + ,
// end.