+ Added support for ErrorProc variable. All internal functions are required

  to call HandleError instead of runerror from now on.
  This is necessary for exception support.

rtl/dos/go32v2/system.pp

@@ -181,7 +181,7 @@ __short_on_stack:
         popl    %ebx
         popl    %eax
   end['EAX','EBX'];
-  RunError(202);
+  HandleError(202);
 end;
 
 
@@ -489,13 +489,13 @@ end;
 
      procedure syscopytodos(addr : longint; len : longint);
      begin
-        if len > tb_size then runerror(217);
+        if len > tb_size then HandleError(217);
         sysseg_move(get_ds,addr,dos_selector,tb,len);
      end;
 
      procedure syscopyfromdos(addr : longint; len : longint);
      begin
-        if len > tb_size then runerror(217);
+        if len > tb_size then HandleError(217);
         sysseg_move(dos_selector,tb,get_ds,addr,len);
      end;
 
@@ -627,7 +627,7 @@ begin
   AllowSlash(p1);
   AllowSlash(p2);
   if strlen(p1)+strlen(p2)+3>tb_size then
-   RunError(217);
+   HandleError(217);
   sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
   sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
   regs.realedi:=tb and 15;
@@ -1057,7 +1057,12 @@ Begin
 End.
 {
   $Log$
-  Revision 1.12  1998-07-13 21:19:08  florian
+  Revision 1.13  1998-07-30 13:26:22  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.12  1998/07/13 21:19:08  florian
     * some problems with ansi string support fixed
 
   Revision 1.11  1998/07/07 12:33:08  carl

rtl/i386/heap.inc

@@ -192,7 +192,7 @@
        		      if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
 			  begin
 			      writeln('error in linked list of heap_mem_info');
-			       runerror(204);
+			       HandleError(204);
 			  end
 
 		      if pp=p then
@@ -637,13 +637,13 @@
 		if assigned(heaperror) then
                   begin
                      case call_heaperror(heaperror,size) of
-                        0 : runerror(203);
+                        0 : HandleError(203);
                         1 : p:=nil;
                         2 : nochmal:=true;
                      end;
                   end
                 else
-                  runerror(203);
+                  HandleError(203);
              end
            else
              begin
@@ -701,7 +701,7 @@ check_new:
           p:=p-sizeof(heap_mem_info);
           { made after heap_switch
           if not (is_in_getmem_list(p)) then
-		runerror(204); }
+		HandleError(204); }
        end;
 {$endif CHECKHEAP}
          if size=0 then
@@ -738,7 +738,7 @@ check_new:
 				begin
 				   writeln('pointer ',hexstr(longint(@p),8),' at ',
 					 hexstr(longint(p),8),' doesn''t points to the heap');
-				   runerror(204);
+				   HandleError(204);
 				end;
 		   end;
 {$endif TEMPHEAP}
@@ -746,7 +746,7 @@ check_new:
 	 if trace then
 	   begin
 	       if not (is_in_getmem_list(p)) then
-		   runerror(204);
+		   HandleError(204);
 	       if pheap_mem_info(p)^.sig=$AAAAAAAA then
 		   dump_free(p);
 	       if pheap_mem_info(p)^.next<>nil then
@@ -823,7 +823,7 @@ check_new:
 			   writeln('pointer to dispose at ',hexstr(longint(p),8),
 			    ' has already been disposed');
 {$endif CHECKHEAP}
-			   runerror(204);
+			   HandleError(204);
 		       end;
 		   { connecting two blocks ? }
 		   if hp+hp^.size=p then
@@ -845,7 +845,7 @@ check_new:
 					  writeln('pointer to dispose at ',hexstr(longint(p),8),
 					   ' is too big !!');
 {$endif CHECKHEAP}
-				          runerror(204);
+				          HandleError(204);
 				   end;
 			   break;
 		        end
@@ -1062,7 +1062,12 @@ end;
 
 {
   $Log$
-  Revision 1.13  1998-07-02 14:24:09  michael
+  Revision 1.14  1998-07-30 13:26:21  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.13  1998/07/02 14:24:09  michael
   Undid carls changes, but renamed _heapsize to _internal_heapsize. Make cycle now works
 
   Revision 1.11  1998/06/25 09:26:10  daniel

rtl/i386/i386.inc

@@ -272,8 +272,8 @@ asm
      popl %edi
      ret $4
 .Lco_re:
-     pushw $210
-     call runerror
+     pushl $210
+     call handleerror
 end;
 
 
@@ -523,35 +523,54 @@ asm
 end ['EAX'];
 
 
+Procedure HandleError (Errno : longint);[alias : 'handleerror'];
+{
+  Procedure to handle internal errors, i.e. not user-invoked errors
+  Internal function should ALWAYS call HandleError instead of RunError.
+}
+function get_addr : Pointer;assembler;
+asm
+  movl (%ebp),%eax
+  movl 4(%eax),%eax
+end;
+
+function get_error_bp : Longint;assembler;
+asm
+   movl (%ebp),%eax 
+end;
+
+begin
+  If ErrorProc<>Nil then
+    TErrorProc (ErrorProc)(Errno,get_addr);
+  errorcode:=Errno;
+  exitcode:=Errno;
+  erroraddr:=Get_addr;
+  DoError := TRUE;
+  errorbase:=get_error_bp;
+  halt(errorcode);
+end;
+
 procedure runerror(w : word);[alias: 'runerror'];
 
-  function get_addr : longint;
-
-    begin
-       asm
-          movl (%ebp),%eax
-          movl 4(%eax),%eax
-          movl %eax,__RESULT
-       end ['EAX'];
-    end;
-
-  function get_error_bp : longint;
-
-    begin
-       asm
-          movl (%ebp),%eax {%ebp of run_error}
-          movl %eax,__RESULT
-       end ['EAX'];
-    end;
-
-  begin
-     errorcode:=w;
-     exitcode:=w;
-     erroraddr:=pointer(get_addr);
-     DoError := TRUE;
-     errorbase:=get_error_bp;
-     halt(errorcode);
-  end;
+function get_addr : Pointer;assembler;
+asm
+   movl (%ebp),%eax
+   movl 4(%eax),%eax
+end;
+
+function get_error_bp : Longint;assembler;
+asm
+   movl (%ebp),%eax {%ebp of run_error}
+end;
+
+begin
+  errorcode:=w;
+  exitcode:=w;
+  erroraddr:=pointer(get_addr);
+  DoError := TRUE;
+  errorbase:=get_error_bp;
+  halt(errorcode);
+end;
 
 procedure int_iocheck(addr : longint);[public,alias: 'IOCHECK'];
 var
@@ -565,12 +584,14 @@ begin
   l:=ioresult;
   if l<>0 then
    begin
+     If ErrorProc<>Nil then
+       TErrorProc(Errorproc)(l,pointer(addr));
 {$ifndef RTLLITE}
      writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
 {$else}
      writeln('IO-Error ',l,' at ',addr);
 {$endif}
-     halt(byte(l));
+     Halt(byte(l));
    end;
   asm
         popal
@@ -587,12 +608,14 @@ begin
         movl    4(%ebp),%edi
         movl    %edi,addr
    end;
+   If ErrorProc<>Nil then
+     TErrorProc (ErrorProc)(215,Pointer(Addr));
 {$ifndef RTLLITE}
    writeln('Overflow at 0x',HexStr(addr,8));
 {$else}
    writeln('Overflow at ',addr);
 {$endif}
-   RunError(215);
+   HandleError(215);
 end;
 
 
@@ -728,7 +751,12 @@ end;
 
 {
   $Log$
-  Revision 1.16  1998-07-02 12:55:04  carl
+  Revision 1.17  1998-07-30 13:26:20  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.16  1998/07/02 12:55:04  carl
     * Put back DoError, DO NOT TOUCH!
 
   Revision 1.15  1998/07/02 12:19:32  carl

rtl/inc/system.inc

@@ -25,6 +25,8 @@
 {$i filerec.inc}
 {$i textrec.inc}
 
+Procedure HandleError (Errno : Longint); forward;
+
 type
   FileFunc = Procedure(var t : TextRec);
 
@@ -509,7 +511,7 @@ begin
     write (stderr,msg);
   writeln (stderr,'(File : ',name,', line ',LineNo,'.');
   flush (stderr);
-  runerror (227);
+  HandleError (227);
 end;
 
 {*****************************************************************************
@@ -527,7 +529,12 @@ end;
 
 {
   $Log$
-  Revision 1.24  1998-07-28 20:37:45  michael
+  Revision 1.25  1998-07-30 13:26:18  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.24  1998/07/28 20:37:45  michael
   + added setjmp/longjmp and exception support
 
   Revision 1.23  1998/07/23 19:53:20  michael

rtl/inc/systemh.inc

@@ -93,6 +93,8 @@ const
   fmAppend = $D7B4;
   Filemode : byte = 2;
 
+Type TErrorProc = Procedure (ErrNo : Longint; Address : Pointer);
+
 var
 { Standard In- and Output }
   Output,
@@ -104,6 +106,9 @@ var
   LowestStack,
   RandSeed    : Longint;
 
+Const 
+  ErrorProc   : Pointer = nil;
+
 {****************************************************************************
                         Processor specific routines
 ****************************************************************************}
@@ -405,7 +410,12 @@ Procedure halt;
 
 {
   $Log$
-  Revision 1.20  1998-07-28 20:37:47  michael
+  Revision 1.21  1998-07-30 13:26:17  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.20  1998/07/28 20:37:47  michael
   + added setjmp/longjmp and exception support
 
   Revision 1.19  1998/07/20 23:36:57  michael

rtl/inc/text.inc

@@ -60,7 +60,7 @@ Begin
    fmOutput : Flags:=$1101;
    fmAppend : Flags:=$1011;
   else
-   RunError(102);
+   HandleError(102);
   End;
   Do_Open(t,PChar(@t.Name),Flags);
   t.CloseFunc:=@FileCloseFunc;
@@ -957,7 +957,7 @@ Begin
    ReadNumeric(f,hs,Base);
   Val(hs,l,code);
   If code<>0 Then
-   RunError(106);
+   HandleError(106);
 End;
 
 
@@ -969,7 +969,7 @@ Begin
   If InOutRes <> 0 then exit;
   Read_Longint(f,ll);
   If (ll<-32768) or (ll>32767) Then
-   RunError(106);
+   HandleError(106);
   l:=ll;
 End;
 
@@ -982,7 +982,7 @@ Begin
   If InOutRes <> 0 then exit;
   Read_Longint(f,ll);
   If (ll<0) or (ll>$ffff) Then
-   RunError(106);
+   HandleError(106);
   l:=ll;
 End;
 
@@ -995,7 +995,7 @@ Begin
   If InOutRes <> 0 then exit;
   Read_Longint(f,ll);
   If (ll<0) or (ll>255) Then
-   RunError(106);
+   HandleError(106);
   l:=ll;
 End;
 
@@ -1008,7 +1008,7 @@ Begin
   If InOutRes <> 0 then exit;
   Read_Longint(f,ll);
   If (ll<-128) or (ll>127) Then
-   RunError(106);
+   HandleError(106);
   l:=ll;
 End;
 
@@ -1028,7 +1028,7 @@ Begin
    ReadNumeric(f,hs,Base);
   val(hs,l,code);
   If code<>0 Then
-   RunError(106);
+   HandleError(106);
 End;
 
 
@@ -1066,7 +1066,7 @@ Begin
    end;
   val(hs,d,code);
   If code<>0 Then
-   RunError(106);
+   HandleError(106);
 End;
 
 
@@ -1105,7 +1105,7 @@ Begin
    end;
   val(hs,d,code);
   If code<>0 Then
-   RunError(106);
+   HandleError(106);
 End;
 {$endif SUPPORT_EXTENDED}
 
@@ -1145,7 +1145,7 @@ Begin
    end;
   val(hs,d,code);
   If code<>0 Then
-   RunError(106);
+   HandleError(106);
 End;
 {$endif SUPPORT_COMP}
 
@@ -1185,14 +1185,19 @@ begin
               TextRec(f).FlushFunc:=@FileWriteFunc;
             end;
   else
-   RunError(102);
+   HandleError(102);
   end;
 end;
 
 
 {
   $Log$
-  Revision 1.18  1998-07-29 21:44:35  michael
+  Revision 1.19  1998-07-30 13:26:16  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.18  1998/07/29 21:44:35  michael
   + Implemented reading/writing of ansistrings
 
   Revision 1.17  1998/07/19 19:55:33  michael

rtl/linux/syslinux.pp

@@ -646,7 +646,7 @@ end;
 Procedure SegFaultHandler (Sig : longint);
 begin
   if sig=11 then
-   RunError (216);
+   HandleError (216);
 end;
 
 
@@ -675,7 +675,12 @@ End.
 
 {
   $Log$
-  Revision 1.9  1998-07-20 23:40:20  michael
+  Revision 1.10  1998-07-30 13:26:15  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.9  1998/07/20 23:40:20  michael
   changed sbrk to fc_sbrk, to avoid conflicts with C library.
 
   Revision 1.8  1998/07/13 21:19:14  florian

rtl/m68k/m68k.inc

@@ -52,10 +52,12 @@
   asm
      move.b d0,b
   end;
-     RunError(b);
+     HandleError(b);
  end;
 
 
+
+
    Procedure FillChar(var x; count: longint; value: byte);
    begin
      asm
@@ -332,6 +334,42 @@
          end ['a0'];
       end;
 
+Procedure HandleError (Errno : longint);[alias : 'handleerror'];
+{
+  Procedure to handle internal errors, i.e. not user-invoked errors
+  Internal function should ALWAYS call HandleError instead of RunError.
+}
+      function get_addr : pointer;
+
+        begin
+           asm
+              move.l (a6),a0
+              move.l 4(a0),a0
+              move.l a0,@RESULT
+           end ['a0'];
+        end;
+      function get_error_bp : longint;
+
+        begin
+           asm
+              { get base pointer of error }
+              move.l (a6),d0
+              move.l d0,@RESULT
+           end ['d0'];
+        end;
+
+begin
+  If ErrorProc<>Nil then
+    TErrorProc (ErrorProc)(Errno,get_addr);
+  errorcode:=Errno;
+  exitcode:=Errno;
+  erroraddr:=Get_addr;
+  DoError := TRUE;
+  errorbase:=get_error_bp;
+  halt(errorcode);
+end;
+
+
     procedure runerror(w : word);
 
       function get_addr : longint;
@@ -398,7 +436,7 @@
             move.l d0,addr
          end;
          writeln('Overflow at 0x',HexStr(addr,8));
-         RunError(215);
+         HandleError(215);
       end;
 
 {    procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];}
@@ -748,7 +786,12 @@ XDEF RE_BOUNDS_CHECK
 
 {
   $Log$
-  Revision 1.8  1998-07-10 11:02:41  peter
+  Revision 1.9  1998-07-30 13:26:14  michael
+  + Added support for ErrorProc variable. All internal functions are required
+    to call HandleError instead of runerror from now on.
+    This is necessary for exception support.
+
+  Revision 1.8  1998/07/10 11:02:41  peter
     * support_fixed, becuase fixed is not 100% yet for the m68k
 
   Revision 1.7  1998/07/02 12:20:58  carl