diff --git a/rtl/objpas/stre.inc b/rtl/objpas/stre.inc index 7df6cef4c8..28d0effb51 100644 --- a/rtl/objpas/stre.inc +++ b/rtl/objpas/stre.inc @@ -55,9 +55,15 @@ Const SUnderflow = 'Floating point underflow'; SIntOverflow = 'Arithmetic overflow'; SInvalidOp = 'Invalid floating point operation'; + SAbortError = 'Operation aborted'; + SExceptionErrorMessage = 'exception at %p'; { $Log$ - Revision 1.10 2000-02-09 16:59:32 peter + Revision 1.11 2000-06-22 18:05:18 michael + + Added ExceptObject, ExceptAddr,ExceptionErrorMessage + ShowException Abort; OutOfMemoryError; Beep; + + Revision 1.10 2000/02/09 16:59:32 peter * truncated log Revision 1.9 2000/01/07 16:41:44 daniel @@ -67,4 +73,4 @@ Const * bug 471 fixed: run time error 2 is now converted into a file not found exception -} +} \ No newline at end of file diff --git a/rtl/objpas/sysutils.pp b/rtl/objpas/sysutils.pp index 835d3aa968..e4c61d92b0 100644 --- a/rtl/objpas/sysutils.pp +++ b/rtl/objpas/sysutils.pp @@ -108,6 +108,19 @@ type EAbstractError = Class(Exception); EAssertionFailed = Class(Exception); + { Exception handling routines } + function ExceptObject: TObject; + function ExceptAddr: Pointer; + function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + procedure Abort; + procedure OutOfMemoryError; + procedure Beep; + +Var + OnShowException : Procedure (Msg : ShortString); + { FileRec/TextRec } {$i filerec.inc} {$i textrec.inc} @@ -294,8 +307,89 @@ begin InvalidPointer:=EInvalidPointer.Create(SInvalidPointer); AssertErrorProc:=@AssertErrorHandler; ErrorProc:=@RunErrorToExcept; + OnShowException:=Nil; end; +{ Exception handling routines } + +function ExceptObject: TObject; + +begin + If RaiseList=Nil then + Result:=Nil + else + Result:=RaiseList^.FObject; +end; + +function ExceptAddr: Pointer; + +begin + If RaiseList=Nil then + Result:=Nil + else + Result:=RaiseList^.Addr; +end; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + +Var + S : AnsiString; + Len : Integer; + +begin + S:=Format(SExceptionErrorMessage,[ExceptObject.ClassName,ExceptAddr]); + If ExceptObject is Exception then + S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]); + Len:=Length(S); + If S[Len]<>'.' then + begin + S:=S+'.'; + Inc(len); + end; + If Len>Size then + Len:=Size; + Move(S[1],Buffer^,Len); + Result:=Len; +end; + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + +// use shortstring. On exception, the heap may be corrupt. + +Var + Buf : ShortString; + +begin + SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255)); + If IsConsole Then + writeln(Buf) + else + If Assigned(OnShowException) Then + OnShowException (Buf); +end; + +procedure Abort; + +begin + Raise EAbort.Create(SAbortError) at Get_Caller_addr(Get_Frame) +end; + +procedure OutOfMemoryError; + +begin + Raise OutOfMemory; +end; + +procedure Beep; + +begin + {$ifdef win32} + MessageBeep(0); + {$else} + + {$endif} +end; { Initialization code. } @@ -308,7 +402,11 @@ Finalization end. { $Log$ - Revision 1.46 2000-06-11 07:07:23 peter + Revision 1.47 2000-06-22 18:05:18 michael + + Added ExceptObject, ExceptAddr,ExceptionErrorMessage + ShowException Abort; OutOfMemoryError; Beep; + + Revision 1.46 2000/06/11 07:07:23 peter + TSysCharSet Revision 1.45 2000/04/24 13:34:29 peter @@ -357,4 +455,4 @@ end. Revision 1.29 1999/07/27 13:01:12 peter + filerec,textrec declarations -} +} \ No newline at end of file