Merged revisions 6744,6756,6813-6814 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r6744 | jonas | 2007-03-06 16:51:41 +0100 (Tue, 06 Mar 2007) | 4 lines

  * prefer a loadsize of 4 over 8 bytes for packed loads on 64 bit,
    because unaligned 8 byte loads are much slower (at least on ppc64)
    than unaligned 4 byte loads

........
r6756 | jonas | 2007-03-09 16:51:09 +0100 (Fri, 09 Mar 2007) | 3 lines

  * fixed a_op_const_reg(_reg)(OP_OR/OP_XOR,OS_S8/OS_S16) for ppc32
    (is ok for ppc64)

........
r6813 | jonas | 2007-03-12 22:28:31 +0100 (Mon, 12 Mar 2007) | 2 lines

  * fixed range check errors when compiling with -Cr

........
r6814 | jonas | 2007-03-12 23:22:43 +0100 (Mon, 12 Mar 2007) | 9 lines

  * fixed val(s,int64) (it accepted values in the range
    high(int64+1)..high(qword) if written in decimal notation) + test
  * fixed range checking of qword constants parsed by the compiler
    (they always gave a range error if > high(int64), because the compiler
     internally stores them as int64)
  * turn off range checking flag of rdconstnodes created by the parser
    from _INTCONST, because those are already range checked by the
    way they are parsed using val()

........

git-svn-id: branches/fixes_2_2@6824 -

.gitattributes

@@ -6220,6 +6220,8 @@ tests/tbs/tb0526.pp -text
 tests/tbs/tb0527.pp svneol=native#text/plain
 tests/tbs/tb0528.pp svneol=native#text/x-pascal
 tests/tbs/tb0530.pp svneol=native#text/plain
+tests/tbs/tb0531.pp svneol=native#text/plain
+tests/tbs/tb0533.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
 tests/tbs/ub0119.pp svneol=native#text/plain

compiler/cutils.pas

@@ -280,7 +280,12 @@ implementation
            3,5,7,9,10,12,16:
              result := 2;
   {$ifdef cpu64bit}
-           11,13,14,15,17..26,28,32:
+           { performance penalty for unaligned 8 byte access is much   }
+           { higher than for unaligned 4 byte access, at least on ppc, }
+           { so use 4 bytes even in some cases where a value could     }
+           { always loaded using a single 8 byte load (e.g. in case of }
+           { 28 bit values)                                            }
+           11,13,14,15,17..32:
              result := 4;
            else
              result := 8;

compiler/defutil.pas

@@ -198,10 +198,10 @@ interface
     {# Returns true, if def is a 64 bit type }
     function is_64bit(def : tdef) : boolean;
 
-    {# If @var(l) isn't in the range of def a range check error (if not explicit) is generated and
+    {# If @var(l) isn't in the range of todef a range check error (if not explicit) is generated and
       the value is placed within the range
     }
-    procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
+    procedure testrange(fromdef, todef : tdef;var l : tconstexprint;explicit:boolean);
 
     {# Returns the range of def, where @var(l) is the low-range and @var(h) is
       the high-range.
@@ -693,9 +693,9 @@ implementation
       end;
 
 
-    { if l isn't in the range of def a range check error (if not explicit) is generated and
+    { if l isn't in the range of todef a range check error (if not explicit) is generated and
       the value is placed within the range }
-    procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
+    procedure testrange(fromdef, todef : tdef;var l : tconstexprint;explicit:boolean);
       var
          lv,hv: TConstExprInt;
          error: boolean;
@@ -703,9 +703,14 @@ implementation
          error := false;
          { for 64 bit types we need only to check if it is less than }
          { zero, if def is a qword node                              }
-         if is_64bitint(def) then
+         if is_64bitint(todef) then
            begin
-              if (l<0) and (torddef(def).ordtype=u64bit) then
+              if (l<0) and
+                 (torddef(todef).ordtype=u64bit) and
+                 { since tconstexprint is an int64, values > high(int64) will }
+                 { always be stored as negative numbers                       }
+                 (not is_64bitint(fromdef) or
+                  (torddef(fromdef).ordtype<>u64bit)) then
                 begin
                    { don't zero the result, because it may come from hex notation
                      like $ffffffffffffffff! (JM)
@@ -722,12 +727,12 @@ implementation
            end
          else
            begin
-              getrange(def,lv,hv);
+              getrange(todef,lv,hv);
               if (l<lv) or (l>hv) then
                 begin
                    if not explicit then
                     begin
-                      if ((def.typ=enumdef) and
+                      if ((todef.typ=enumdef) and
                           { delphi allows range check errors in
                            enumeration type casts FK }
                           not(m_delphi in current_settings.modeswitches)) or
@@ -742,16 +747,16 @@ implementation
          if error then
           begin
              { Fix the value to fit in the allocated space for this type of variable }
-             case longint(def.size) of
+             case longint(todef.size) of
                1: l := l and $ff;
                2: l := l and $ffff;
                { work around sign extension bug (to be fixed) (JM) }
                4: l := l and (int64($fffffff) shl 4 + $f);
              end;
              { do sign extension if necessary (JM) }
-             if is_signed(def) then
+             if is_signed(todef) then
               begin
-                case longint(def.size) of
+                case longint(todef.size) of
                   1: l := shortint(l);
                   2: l := smallint(l);
                   4: l := longint(l);

compiler/ncnv.pas

@@ -1830,10 +1830,10 @@ implementation
                       not(convtype=tc_char_2_char) then
                 begin
                    { replace the resultdef and recheck the range }
-                   left.resultdef:=resultdef;
                    if ([nf_explicit,nf_internal] * flags <> []) then
                      include(left.flags, nf_explicit);
-                   testrange(left.resultdef,tordconstnode(left).value,(nf_explicit in flags));
+                   testrange(left.resultdef,resultdef,tordconstnode(left).value,(nf_explicit in flags));
+                   left.resultdef:=resultdef;
                    result:=left;
                    left:=nil;
                    exit;

compiler/ncon.pas

@@ -623,7 +623,7 @@ implementation
         resultdef:=typedef;
         { only do range checking when explicitly asked for it }
         if rangecheck then
-           testrange(resultdef,value,false);
+           testrange(resultdef,resultdef,value,false);
       end;
 
     function tordconstnode.pass_1 : tnode;

compiler/ninl.pas

@@ -1306,9 +1306,9 @@ implementation
                  (index.left.nodetype = ordconstn) and
                  not is_special_array(unpackedarraydef) then
                 begin
-                  testrange(unpackedarraydef,tordconstnode(index.left).value,false);
+                  testrange(index.left.resultdef,unpackedarraydef,tordconstnode(index.left).value,false);
                   tempindex := tordconstnode(index.left).value + packedarraydef.highrange-packedarraydef.lowrange;
-                  testrange(unpackedarraydef,tempindex,false);
+                  testrange(index.left.resultdef,unpackedarraydef,tempindex,false);
                 end;
             end;
 

compiler/pexpr.pas

@@ -2459,7 +2459,10 @@ implementation
                         consume(_INTCONST);
                         p1:=crealconstnode.create(d,pbestrealtype^);
                      end;
-                 end;
+                 end
+               else
+                 { the necessary range checking has already been done by val }
+                 tordconstnode(p1).rangecheck:=false;
              end;
 
            _REALNUMBER :

compiler/powerpc/cgcpu.pas

@@ -523,23 +523,9 @@ const
               begin
                 case op of
                   OP_OR:
-                    case size of
-                      OS_8, OS_S8:
-                        list.concat(taicpu.op_reg_const(A_LI,dst,255));
-                      OS_16, OS_S16:
-                        a_load_const_reg(list,OS_16,65535,dst);
-                      else
-                        list.concat(taicpu.op_reg_const(A_LI,dst,-1));
-                    end;
+                    list.concat(taicpu.op_reg_const(A_LI,dst,-1));
                   OP_XOR:
-                    case size of
-                      OS_8, OS_S8:
-                        list.concat(taicpu.op_reg_reg_const(A_XORI,dst,src,255));
-                      OS_16, OS_S16:
-                        list.concat(taicpu.op_reg_reg_const(A_XORI,dst,src,65535));
-                      else
-                        list.concat(taicpu.op_reg_reg(A_NOT,dst,src));
-                    end;
+                    list.concat(taicpu.op_reg_reg(A_NOT,dst,src));
                   OP_AND:
                     a_load_reg_reg(list,size,size,src,dst);
                 end;

compiler/pstatmnt.pas

@@ -183,8 +183,8 @@ implementation
                         CGMessage(parser_e_case_lower_less_than_upper_bound);
                       if not casedeferror then
                        begin
-                         testrange(casedef,hl1,false);
-                         testrange(casedef,hl2,false);
+                         testrange(casedef,casedef,hl1,false);
+                         testrange(casedef,casedef,hl2,false);
                        end;
                     end
                   else
@@ -198,7 +198,7 @@ implementation
                     CGMessage(parser_e_case_mismatch);
                   hl1:=get_ordinal_value(p);
                   if not casedeferror then
-                    testrange(casedef,hl1,false);
+                    testrange(casedef,casedef,hl1,false);
                   casenode.addlabel(blockid,hl1,hl1);
                end;
              p.free;

compiler/ptconst.pas

@@ -233,7 +233,7 @@ implementation
                 begin
                    if is_constintnode(n) then
                      begin
-                       testrange(def,tordconstnode(n).value,false);
+                       testrange(n.resultdef,def,tordconstnode(n).value,false);
                        case def.size of
                          1 :
                            list.concat(Tai_const.Create_8bit(byte(tordconstnode(n).value)));

packages/base/mysql/mysql.inc

@@ -298,7 +298,7 @@ uses
        PNET = ^NET;
 
     const
-       packet_error : culong = not(0);
+       packet_error : culong = culong(not(0));
 
     type
        enum_field_types = (MYSQL_TYPE_DECIMAL,MYSQL_TYPE_TINY,
@@ -521,7 +521,7 @@ uses
 {$endif}
 
     const
-       NULL_LENGTH : dword = not(0); // For net_store_length
+       NULL_LENGTH : dword = dword(not(0)); // For net_store_length
 
     const
        MYSQL_STMT_HEADER = 4;

packages/fcl-registry/src/regdef.inc

@@ -1,12 +1,36 @@
+Type
+  LPDWORD = ^DWord;
+  LPVOID  = Pointer;
+  WINBOOL = LongBool;
+  LPCSTR  = PChar;
+  LPSTR   = Pchar;
+  LONG    = LongInt;
+  LPBYTE  = ^Byte;
+
+  ACCESS_MASK = DWORD;
+       REGSAM = ACCESS_MASK;
+
+  SECURITY_ATTRIBUTES = record
+    nLength : DWORD;
+    lpSecurityDescriptor : LPVOID;
+    bInheritHandle : WINBOOL;
+  end;
+  LPSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
+
+
+  HKEY = THandle;
+  PHKEY = ^HKEY;
+
+
 
 Const
-  HKEY_CLASSES_ROOT     = $80000000;
-  HKEY_CURRENT_USER     = $80000001;
-  HKEY_LOCAL_MACHINE    = $80000002;
-  HKEY_USERS            = $80000003;
-  HKEY_PERFORMANCE_DATA = $80000004;
-  HKEY_CURRENT_CONFIG   = $80000005;
-  HKEY_DYN_DATA         = $80000006;
+  HKEY_CLASSES_ROOT     = HKEY($80000000);
+  HKEY_CURRENT_USER     = HKEY($80000001);
+  HKEY_LOCAL_MACHINE    = HKEY($80000002);
+  HKEY_USERS            = HKEY($80000003);
+  HKEY_PERFORMANCE_DATA = HKEY($80000004);
+  HKEY_CURRENT_CONFIG   = HKEY($80000005);
+  HKEY_DYN_DATA         = HKEY($80000006);
 
   KEY_ALL_ACCESS         = $F003F;
   KEY_CREATE_LINK        = 32;
@@ -39,26 +63,4 @@ Const
 
   ERROR_SUCCESS = 0;
 
-Type
-  LPDWORD = ^DWord;
-  LPVOID  = Pointer;
-  WINBOOL = LongBool;
-  LPCSTR  = PChar;
-  LPSTR   = Pchar;
-  LONG    = LongInt;
-  LPBYTE  = ^Byte;
-
-  ACCESS_MASK = DWORD;
-       REGSAM = ACCESS_MASK;
-
-  SECURITY_ATTRIBUTES = record
-    nLength : DWORD;
-    lpSecurityDescriptor : LPVOID;
-    bInheritHandle : WINBOOL;
-  end;
-  LPSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
-
-
-  HKEY = THandle;
-  PHKEY = ^HKEY;
 

rtl/inc/sstrings.inc

@@ -796,38 +796,25 @@ end;
 {$ifndef CPU64}
 
   Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; [public, alias:'FPC_VAL_INT64_SHORTSTR']; compilerproc;
-   type
-     QWordRec = packed record
-       l1,l2: longint;
-     end;
 
-    var
-       u, temp, prev, maxint64, maxqword : qword;
+  var  u, temp, prev, maxprevvalue, maxnewvalue : qword;
        base : byte;
        negative : boolean;
 
+  const maxint64=qword($7fffffffffffffff);
+        maxqword=qword($ffffffffffffffff);
+
   begin
     fpc_val_int64_shortstr := 0;
     Temp:=0;
     Code:=InitVal(s,negative,base);
     if Code>length(s) then
      exit;
-    { high(int64) produces 0 in version 1.0 (JM) }
-    with qwordrec(maxint64) do
-      begin
-{$ifdef ENDIAN_LITTLE}
-        l1 := longint($ffffffff);
-        l2 := $7fffffff;
-{$else ENDIAN_LITTLE}
-        l1 := $7fffffff;
-        l2 := longint($ffffffff);
-{$endif ENDIAN_LITTLE}
-      end;
-    with qwordrec(maxqword) do
-      begin
-        l1 := longint($ffffffff);
-        l2 := longint($ffffffff);
-      end;
+    maxprevvalue := maxqword div base;
+    if (base = 10) then
+      maxnewvalue := maxint64 + ord(negative)
+    else
+      maxnewvalue := maxqword;
 
     while Code<=Length(s) do
      begin
@@ -840,13 +827,10 @@ end;
         u:=16;
        end;
        Prev:=Temp;
-       Temp:=Temp*Int64(base);
+       Temp:=Temp*qword(base);
      If (u >= base) or
-        ((base = 10) and
-         (maxint64-temp+ord(negative) < u)) or
-        ((base <> 10) and
-         (qword(maxqword-temp) < u)) or
-        (prev > maxqword div qword(base)) Then
+        (qword(maxnewvalue-u) < temp) or
+        (prev > maxprevvalue) Then
        Begin
          fpc_val_int64_shortstr := 0;
          Exit

tests/tbs/tb0531.pp

@@ -0,0 +1,109 @@
+procedure testshort;
+var
+  s1,s2: shortint;
+  l: longint;
+begin
+  s1 := -1;
+  s1 := s1 xor -1;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536) then
+    halt(1);
+
+  s1 := 127;
+  s1 := s1 or -128;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536-1) then
+    halt(2);
+
+
+  s1 := -1;
+  s1 := s1 xor -128;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536+127) then
+    halt(3);
+
+  s1 := 127;
+  s1 := s1 or -128;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536-1) then
+    halt(4);
+
+
+  s1 := -1;
+  s2 := -128;
+  s1 := s1 xor s2;
+  l := 0;
+  l := l + s1;
+  if l <> 127 then
+    halt(5);
+  
+  s1 := 126;
+  s2 := -128;
+  s1 := s1 or s2;
+  l := 0;
+  l := l + s1;
+  if l <> -2 then
+    halt(6);
+end;
+
+
+procedure testsmall;
+var
+  s1,s2: smallint;
+  l: longint;
+begin
+  s1 := -1;
+  s1 := s1 xor -1;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536) then
+    halt(1+6);
+
+  s1 := 32767;
+  s1 := s1 or -32678;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536-1) then
+    halt(2+6);
+
+
+  s1 := -1;
+  s1 := s1 xor -32768;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536+32767) then
+    halt(3+6);
+
+  s1 := 32767;
+  s1 := s1 or -32768;
+  l := -65536;
+  l := l + s1;
+  if (l <> -65536-1) then
+    halt(4+6);
+
+
+  s1 := -1;
+  s2 := -32768;
+  s1 := s1 xor s2;
+  l := 0;
+  l := l + s1;
+  if l <> 32767 then
+    halt(5+6);
+  
+  s1 := 32766;
+  s2 := -32768;
+  s1 := s1 or s2;
+  l := 0;
+  l := l + s1;
+  if l <> -2 then
+    halt(6+6);
+end;
+
+begin
+  testshort;
+  testsmall;
+end.

tests/tbs/tb0533.pp

@@ -0,0 +1,25 @@
+{$r+}
+
+const
+  q: qword = 18446744073709551615;
+
+var
+  i: int64;
+  code: longint;
+begin
+  val('18446744073709551615',i,code);
+  if (code = 0) then
+    halt(1);
+  val('-9223372036854775808',i,code);
+  if (code <> 0) or
+     (i <> low(int64)) then
+    halt(2);
+  val('9223372036854775807',i,code);
+  if (code <> 0) or
+     (i <> high(int64)) then
+    halt(3);
+  val('$8000000000000000',i,code);
+  if (code <> 0) or
+     (i <> low(int64)) then
+    halt(4);
+end.