diff options
author | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2007-03-13 18:28:31 +0000 |
---|---|---|
committer | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2007-03-13 18:28:31 +0000 |
commit | 3e64ef748707c51a4659354b059404f23c22f8df (patch) | |
tree | efc9b88b415bfc14b83edb70007f1689c2e06711 | |
parent | ba25bcc81f426aeed59d28a1b875a2017d5dbb1a (diff) | |
download | fpc-3e64ef748707c51a4659354b059404f23c22f8df.tar.gz |
Merged revisions 6744,6756,6813-6814 via svnmerge from
svn+ssh://jonas@svn.freepascal.org/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: http://svn.freepascal.org/svn/fpc/branches/fixes_2_2@6824 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r-- | compiler/cutils.pas | 7 | ||||
-rw-r--r-- | compiler/defutil.pas | 27 | ||||
-rw-r--r-- | compiler/ncnv.pas | 4 | ||||
-rw-r--r-- | compiler/ncon.pas | 2 | ||||
-rw-r--r-- | compiler/ninl.pas | 4 | ||||
-rw-r--r-- | compiler/pexpr.pas | 5 | ||||
-rw-r--r-- | compiler/powerpc/cgcpu.pas | 18 | ||||
-rw-r--r-- | compiler/pstatmnt.pas | 6 | ||||
-rw-r--r-- | compiler/ptconst.pas | 2 | ||||
-rw-r--r-- | packages/base/mysql/mysql.inc | 4 | ||||
-rw-r--r-- | packages/fcl-registry/src/regdef.inc | 60 | ||||
-rw-r--r-- | rtl/inc/sstrings.inc | 40 | ||||
-rw-r--r-- | tests/tbs/tb0531.pp | 109 | ||||
-rw-r--r-- | tests/tbs/tb0533.pp | 25 |
14 files changed, 216 insertions, 97 deletions
diff --git a/compiler/cutils.pas b/compiler/cutils.pas index 2741fa1173..d81ea6d153 100644 --- a/compiler/cutils.pas +++ b/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; diff --git a/compiler/defutil.pas b/compiler/defutil.pas index e2acfe76c5..ae5bb3ab1a 100644 --- a/compiler/defutil.pas +++ b/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); diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index ea872537d6..0873078ca5 100644 --- a/compiler/ncnv.pas +++ b/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; diff --git a/compiler/ncon.pas b/compiler/ncon.pas index d8dc182f14..0f3c8ad2fd 100644 --- a/compiler/ncon.pas +++ b/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; diff --git a/compiler/ninl.pas b/compiler/ninl.pas index d0f1aa09ad..5a9ea9fee5 100644 --- a/compiler/ninl.pas +++ b/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; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 0a9d3ad2bc..2400529a8f 100644 --- a/compiler/pexpr.pas +++ b/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 : diff --git a/compiler/powerpc/cgcpu.pas b/compiler/powerpc/cgcpu.pas index dc52410148..9cc7e72e8a 100644 --- a/compiler/powerpc/cgcpu.pas +++ b/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; diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index 8ff0b512e2..8876c130b6 100644 --- a/compiler/pstatmnt.pas +++ b/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; diff --git a/compiler/ptconst.pas b/compiler/ptconst.pas index 4dd48a0982..3b9c6ff413 100644 --- a/compiler/ptconst.pas +++ b/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))); diff --git a/packages/base/mysql/mysql.inc b/packages/base/mysql/mysql.inc index 79f3198c0b..dbe0d3cf6c 100644 --- a/packages/base/mysql/mysql.inc +++ b/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; diff --git a/packages/fcl-registry/src/regdef.inc b/packages/fcl-registry/src/regdef.inc index 18b7d0f68e..583c134324 100644 --- a/packages/fcl-registry/src/regdef.inc +++ b/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; diff --git a/rtl/inc/sstrings.inc b/rtl/inc/sstrings.inc index 3088229824..b3ac019052 100644 --- a/rtl/inc/sstrings.inc +++ b/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 diff --git a/tests/tbs/tb0531.pp b/tests/tbs/tb0531.pp new file mode 100644 index 0000000000..691b94a5d6 --- /dev/null +++ b/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. diff --git a/tests/tbs/tb0533.pp b/tests/tbs/tb0533.pp new file mode 100644 index 0000000000..29ecdc70f9 --- /dev/null +++ b/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. |