* synchronized with trunk

git-svn-id: branches/wasm@46500 -

.gitattributes

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

compiler/i8086/cgcpu.pas

@@ -1745,14 +1745,25 @@ unit cgcpu;
                 end;
               OS_32,OS_S32:
                 begin
-                  { Preload the ref base to reduce spilling }
+                  { Preload the ref base to a new register to reduce spilling
-                  if (tmpref.base<>NR_NO) and
+                    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) then
+                      (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 }
+                  { Preload the ref base to a new register to reduce spilling
-                  if (tmpref.base<>NR_NO) and
+                    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) then
+                      (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);

compiler/wasm32/agllvmmc.pas

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

compiler/x86/rax86att.pas

@@ -720,6 +720,7 @@ Implementation
                       if (actasmtoken=AS_PLUS) then
                         begin
                           l:=BuildConstExpression(true,false);
+                          if errorcount=0 then
                             case oper.opr.typ of
                               OPR_CONSTANT :
                                 inc(oper.opr.val,l);

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;

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

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

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;

rtl/msdos/classes.pp

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

rtl/msdos/sysutils.pp

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

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;
 

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

tests/webtbf/tw37459.pp

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