+ support for range checking calculations with hlcgobj

* added runerror number to JVM FpcRunTimeError exceptions
  * enabled calling errorproc when a run time error occurs on the
    JVM target

git-svn-id: branches/jvmbackend@18749 -

compiler/cg64f32.pas

@@ -779,7 +779,7 @@ unit cg64f32;
                  cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,-1,hreg,neglabel);
                end;
              { For all other values we have a range check error }
-             cg.a_call_name(list,'FPC_RANGEERROR',false);
+             cg.a_call_name(list,'fpc_rangeerror',false);
 
              { if the high dword = 0, the low dword can be considered a }
              { simple cardinal                                          }
@@ -819,7 +819,7 @@ unit cg64f32;
                  current_asmdata.getjumplabel(neglabel);
                  cg.a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
 
-                 cg.a_call_name(list,'FPC_RANGEERROR',false);
+                 cg.a_call_name(list,'fpc_rangeerror',false);
 
                  { if we get here, the 64bit value lies between }
                  { longint($80000000) and -1 (JM)               }
@@ -870,7 +870,7 @@ unit cg64f32;
                current_asmdata.getjumplabel(poslabel);
                cg.a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
 
-               cg.a_call_name(list,'FPC_RANGEERROR',false);
+               cg.a_call_name(list,'fpc_rangeerror',false);
                cg.a_label(list,poslabel);
              end;
       end;

compiler/cgobj.pas

@@ -463,6 +463,8 @@ unit cgobj;
              @param(p Node which contains the value to check)
              @param(todef Type definition of node to range check)
           }
+          { only left here because used by cg64f32; normally, the code in
+            hlcgobj is used }
           procedure g_rangecheck(list: TAsmList; const l:tlocation; fromdef,todef: tdef); virtual;
 
           {# Generates overflow checking code for a node }

compiler/hlcgobj.pas

@@ -496,6 +496,8 @@ unit hlcgobj;
             the assembler/object file }
           procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); virtual;
 
+          { generate a call to a routine in the system unit }
+          procedure g_call_system_proc(list: TAsmList; const procname: string);
        end;
 
     var
@@ -510,7 +512,7 @@ implementation
        globals,options,systems,
        fmodule,export,
        verbose,defutil,paramgr,
-       symbase,symsym,
+       symbase,symsym,symtable,
        ncon,nld,pass_1,pass_2,
        cpuinfo,cgobj,tgobj,cutils,procinfo,
        ncgutil,ngenutil;
@@ -1662,10 +1664,195 @@ implementation
     end;
 
   procedure thlcgobj.g_rangecheck(list: TAsmList; const l: tlocation; fromdef, todef: tdef);
+    var
+      aintmax: aint;
+      neglabel : tasmlabel;
+      hreg : tregister;
+      lto,hto,
+      lfrom,hfrom : TConstExprInt;
+      fromsize, tosize: cardinal;
+      maxdef: tdef;
+      from_signed, to_signed: boolean;
     begin
-      if not(cs_check_range in current_settings.localswitches) then
+      { range checking on and range checkable value? }
+      if not(cs_check_range in current_settings.localswitches) or
+         not(fromdef.typ in [orddef,enumdef]) or
+         { C-style booleans can't really fail range checks, }
+         { all values are always valid                      }
+         is_cbool(todef) then
         exit;
-      internalerror(2011010610);
+      { only check when assigning to scalar, subranges are different, }
+      { when todef=fromdef then the check is always generated         }
+      getrange(fromdef,lfrom,hfrom);
+      getrange(todef,lto,hto);
+      from_signed := is_signed(fromdef);
+      to_signed := is_signed(todef);
+      { check the rangedef of the array, not the array itself }
+      { (only change now, since getrange needs the arraydef)   }
+      if (todef.typ = arraydef) then
+        todef := tarraydef(todef).rangedef;
+      { no range check if from and to are equal and are both longint/dword }
+      { (if we have a 32bit processor) or int64/qword, since such          }
+      { operations can at most cause overflows (JM)                        }
+      { Note that these checks are mostly processor independent, they only }
+      { have to be changed once we introduce 64bit subrange types          }
+      if (fromdef = todef) and
+         (fromdef.typ=orddef) and
+         (((((torddef(fromdef).ordtype = s64bit) and
+             (lfrom = low(int64)) and
+             (hfrom = high(int64))) or
+            ((torddef(fromdef).ordtype = u64bit) and
+             (lfrom = low(qword)) and
+             (hfrom = high(qword))) or
+            ((torddef(fromdef).ordtype = scurrency) and
+             (lfrom = low(int64)) and
+             (hfrom = high(int64)))))) then
+        exit;
+      { 32 bit operations are automatically widened to 64 bit on 64 bit addr
+        targets }
+{$ifdef cpu32bitaddr}
+      if (fromdef = todef) and
+         (fromdef.typ=orddef) and
+         (((((torddef(fromdef).ordtype = s32bit) and
+             (lfrom = int64(low(longint))) and
+             (hfrom = int64(high(longint)))) or
+            ((torddef(fromdef).ordtype = u32bit) and
+             (lfrom = low(cardinal)) and
+             (hfrom = high(cardinal)))))) then
+        exit;
+{$endif cpu32bitaddr}
+
+      { optimize some range checks away in safe cases }
+      fromsize := fromdef.size;
+      tosize := todef.size;
+      if ((from_signed = to_signed) or
+          (not from_signed)) and
+         (lto<=lfrom) and (hto>=hfrom) and
+         (fromsize <= tosize) then
+        begin
+          { if fromsize < tosize, and both have the same signed-ness or }
+          { fromdef is unsigned, then all bit patterns from fromdef are }
+          { valid for todef as well                                     }
+          if (fromsize < tosize) then
+            exit;
+          if (fromsize = tosize) and
+             (from_signed = to_signed) then
+            { only optimize away if all bit patterns which fit in fromsize }
+            { are valid for the todef                                      }
+            begin
+{$ifopt Q+}
+{$define overflowon}
+{$Q-}
+{$endif}
+{$ifopt R+}
+{$define rangeon}
+{$R-}
+{$endif}
+              if to_signed then
+                begin
+                  { calculation of the low/high ranges must not overflow 64 bit
+                   otherwise we end up comparing with zero for 64 bit data types on
+                   64 bit processors }
+                  if (lto = (int64(-1) << (tosize * 8 - 1))) and
+                     (hto = (-((int64(-1) << (tosize * 8 - 1))+1))) then
+                    exit
+                end
+              else
+                begin
+                  { calculation of the low/high ranges must not overflow 64 bit
+                   otherwise we end up having all zeros for 64 bit data types on
+                   64 bit processors }
+                  if (lto = 0) and
+                     (qword(hto) = (qword(-1) >> (64-(tosize * 8))) ) then
+                    exit
+                end;
+{$ifdef overflowon}
+{$Q+}
+{$undef overflowon}
+{$endif}
+{$ifdef rangeon}
+{$R+}
+{$undef rangeon}
+{$endif}
+            end
+        end;
+
+      { depending on the types involved, we perform the range check for 64 or
+        for 32 bit }
+      if fromsize=8 then
+        maxdef:=fromdef
+      else
+        maxdef:=todef;
+{$if sizeof(aintmax) = 8}
+      if maxdef.size=8 then
+        aintmax:=high(int64)
+      else
+{$endif}
+        begin
+          aintmax:=high(longint);
+          maxdef:=u32inttype;
+        end;
+
+      { generate the rangecheck code for the def where we are going to }
+      { store the result                                               }
+
+      { use the trick that                                                 }
+      { a <= x <= b <=> 0 <= x-a <= b-a <=> unsigned(x-a) <= unsigned(b-a) }
+
+      { To be able to do that, we have to make sure however that either    }
+      { fromdef and todef are both signed or unsigned, or that we leave    }
+      { the parts < 0 and > maxlongint out                                 }
+
+      if from_signed xor to_signed then
+        begin
+           if from_signed then
+             { from is signed, to is unsigned }
+             begin
+               { if high(from) < 0 -> always range error }
+               if (hfrom < 0) or
+                  { if low(to) > maxlongint also range error }
+                  (lto > aintmax) then
+                 begin
+                   g_call_system_proc(list,'fpc_rangeerror');
+                   exit
+                 end;
+               { from is signed and to is unsigned -> when looking at to }
+               { as an signed value, it must be < maxaint (otherwise     }
+               { it will become negative, which is invalid since "to" is unsigned) }
+               if hto > aintmax then
+                 hto := aintmax;
+             end
+           else
+             { from is unsigned, to is signed }
+             begin
+               if (lfrom > aintmax) or
+                  (hto < 0) then
+                 begin
+                   g_call_system_proc(list,'fpc_rangeerror');
+                   exit
+                 end;
+               { from is unsigned and to is signed -> when looking at to }
+               { as an unsigned value, it must be >= 0 (since negative   }
+               { values are the same as values > maxlongint)             }
+               if lto < 0 then
+                 lto := 0;
+             end;
+        end;
+      hreg:=getintregister(list,maxdef);
+      a_load_loc_reg(list,fromdef,maxdef,l,hreg);
+      a_op_const_reg(list,OP_SUB,maxdef,tcgint(int64(lto)),hreg);
+      current_asmdata.getjumplabel(neglabel);
+      {
+      if from_signed then
+        a_cmp_const_reg_label(list,OS_INT,OC_GTE,aint(hto-lto),hreg,neglabel)
+      else
+      }
+      if qword(hto-lto)>qword(aintmax) then
+        a_cmp_const_reg_label(list,maxdef,OC_BE,aintmax,hreg,neglabel)
+      else
+        a_cmp_const_reg_label(list,maxdef,OC_BE,tcgint(int64(hto-lto)),hreg,neglabel);
+      g_call_system_proc(list,'fpc_rangeerror');
+      a_label(list,neglabel);
     end;
 
   procedure thlcgobj.g_profilecode(list: TAsmList);
@@ -2723,4 +2910,19 @@ implementation
         current_asmdata.asmlists[al_procedures].concatlist(data);
     end;
 
+  procedure thlcgobj.g_call_system_proc(list: TAsmList; const procname: string);
+    var
+      srsym: tsym;
+      pd: tprocdef;
+    begin
+      srsym:=tsym(systemunit.find(procname));
+      if not assigned(srsym) or
+         (srsym.typ<>procsym) then
+        Message1(cg_f_unknown_compilerproc,procname);
+      pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
+      a_call_name(list,pd,pd.mangledname,false);
+    end;
+
+
+
 end.

compiler/jvm/hlcgcpu.pas

@@ -192,8 +192,6 @@ uses
       procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
       procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
 
-      { generate a call to a routine in the system unit }
-      procedure g_call_system_proc(list: TAsmList; const procname: string);
     end;
 
   procedure create_hlcodegen;
@@ -2102,19 +2100,6 @@ implementation
         end;
     end;
 
-  procedure thlcgjvm.g_call_system_proc(list: TAsmList; const procname: string);
-    var
-      srsym: tsym;
-      pd: tprocdef;
-    begin
-      srsym:=tsym(systemunit.find(procname));
-      if not assigned(srsym) or
-         (srsym.typ<>procsym) then
-        Message1(cg_f_unknown_compilerproc,procname);
-      pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
-      a_call_name(list,pd,pd.mangledname,false);
-    end;
-
   procedure create_hlcodegen;
     begin
       hlcg:=thlcgjvm.create;

compiler/ncgcnv.pas

@@ -89,7 +89,7 @@ interface
 
         { insert range check if not explicit conversion }
         if not(nf_explicit in flags) then
-          cg.g_rangecheck(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef);
+          hlcg.g_rangecheck(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef);
 
         { is the result size smaller? when typecasting from void
           we always reuse the current location, because there is

rtl/java/compproc.inc

@@ -685,10 +685,11 @@ procedure fpc_largeset_symdif_sets(set1,set2,dest : pointer;size : longint); com
 procedure fpc_largeset_comp_sets(set1,set2 : pointer;size : longint); compilerproc;
 procedure fpc_largeset_contains_sets(set1,set2 : pointer; size: longint); compilerproc;
 {$endif LARGESETS}
-
+*)
 procedure fpc_rangeerror; compilerproc;
 procedure fpc_divbyzero; compilerproc;
 procedure fpc_overflow; compilerproc;
+(*
 procedure fpc_iocheck; compilerproc;
 
 procedure fpc_InitializeUnits; compilerproc;

rtl/java/jsystem.inc

@@ -983,10 +983,10 @@ end;
 
 Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPU86} register; {$endif}
 begin
-  raise FpcRunTimeError.Create(Errno);
-(*
   If pointer(ErrorProc)<>Nil then
     ErrorProc(Errno,addr,frame);
+  raise FpcRunTimeError.Create(Errno);
+(*
   errorcode:=word(Errno);
   erroraddr:=addr;
   errorbase:=frame;

rtl/java/jsystemh.inc

@@ -648,17 +648,22 @@ function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
 *)
 
 { Error handlers }
-(*
 Type
+(*
   TBackTraceStrFunc = Function (Addr: Pointer): ShortString;
+*)
   TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
+(*
   TAbstractErrorProc = Procedure;
   TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer);
   TSafeCallErrorProc = Procedure(error : HResult;addr : pointer);
-
+*)
 const
+(*
   BackTraceStrFunc  : TBackTraceStrFunc = @SysBackTraceStr;
+*)
   ErrorProc         : TErrorProc = nil;
+(*
   AbstractErrorProc : TAbstractErrorProc = nil;
   AssertErrorProc   : TAssertErrorProc = @SysAssert;
   SafeCallErrorProc : TSafeCallErrorProc = nil;

rtl/java/sysos.inc

@@ -18,5 +18,6 @@
 constructor FpcRunTimeError.create(l: longint);
   begin
     inherited Create('Run time error '+unicodestring(JLInteger.valueOf(l).toString));
+    errornr:=l;
   end;
 

rtl/java/sysosh.inc

@@ -17,5 +17,6 @@
 
 type
   FpcRunTimeError = class(JLException)
+    errornr: longint;
     constructor create(l: longint);
   end;