development/compilers/freepascal/rtl/objpas/sysutils.inc

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Florian Klaempfl
   5     member of the Free Pascal development team
   6
   7     See the file COPYING.FPC, included in this distribution,
   8     for details about the copyright.
   9
  10     This program is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13
  14  **********************************************************************}
  15
  16   { Read message string definitions }
  17   {
  18    Add a language with IFDEF LANG_NAME
  19    just befor the final ELSE. This way English will always be the default.
  20   }
  21
  22   {$IFDEF LANG_GERMAN}
  23   {$i strg.inc} // Does not exist yet !!
  24   {$ELSE}
  25   {$i stre.inc}
  26   {$ENDIF}
  27
  28   { Read filename handling functions implementation }
  29   {$i fina.inc}
  30
  31   { Read String Handling functions implementation }
  32   {$i sysstr.inc}
  33
  34   { Read date & Time function implementations }
  35   {$i dati.inc}
  36
  37   { Read pchar handling functions implementation }
  38   {$i syspch.inc}
  39
  40
  41     constructor Exception.Create(const msg : string);
  42
  43       begin
  44          inherited create;
  45          fmessage:=msg;
  46       end;
  47
  48
  49     constructor Exception.CreateFmt(const msg : string; const args : array of const);
  50
  51       begin
  52          inherited create;
  53          fmessage:=Format(msg,args);
  54       end;
  55
  56
  57     constructor Exception.CreateRes(ResString: PString);
  58
  59       begin
  60          inherited create;
  61          fmessage:=ResString^;
  62       end;
  63
  64
  65     constructor Exception.CreateResFmt(ResString: PString; const Args: array of const);
  66
  67       begin
  68          inherited create;
  69          fmessage:=Format(ResString^,args);
  70       end;
  71
  72
  73     constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);
  74
  75       begin
  76          inherited create;
  77          fmessage:=Msg;
  78          fhelpcontext:=AHelpContext;
  79       end;
  80
  81
  82     constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;
  83       AHelpContext: Integer);
  84
  85     begin
  86        inherited create;
  87        fmessage:=Format(Msg,args);
  88        fhelpcontext:=AHelpContext;
  89     end;
  90
  91
  92     constructor Exception.CreateResHelp(ResString: PString; AHelpContext: Integer);
  93
  94     begin
  95        inherited create;
  96        fmessage:=ResString^;
  97        fhelpcontext:=AHelpContext;
  98     end;
  99
 100
 101     constructor Exception.CreateResFmtHelp(ResString: PString; const Args: array of const;
 102       AHelpContext: Integer);
 103
 104     begin
 105        inherited create;
 106        fmessage:=Format(ResString^,args);
 107        fhelpcontext:=AHelpContext;
 108     end;
 109
 110
 111
 112 {$ifopt S+}
 113 {$define STACKCHECK_WAS_ON}
 114 {$S-}
 115 {$endif OPT S }
 116 Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);
 117 Var
 118   Message : String;
 119 begin
 120   Writeln(stdout,'An unhandled exception occurred at 0x',HexStr(Longint(Addr),8),' :');
 121   if Obj is exception then
 122    begin
 123      Message:=Exception(Obj).Message;
 124      Writeln(stdout,Message);
 125    end
 126   else
 127    Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
 128   { to get a nice symify }
 129   Writeln(stdout,BackTraceStrFunc(Longint(Addr)));
 130   Dump_Stack(stdout,longint(frame));
 131   Writeln(stdout,'');
 132   Halt(217);
 133 end;
 134
 135
 136 Var OutOfMemory : EOutOfMemory;
 137     InValidPointer : EInvalidPointer;
 138
 139
 140 Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
 141
 142 Var E : Exception;
 143     S : String;
 144
 145 begin
 146   Case Errno of
 147    1,203 : E:=OutOfMemory;
 148    204 : E:=InvalidPointer;
 149    2,3,4,5,6,100,101,102,103,105,106 : { I/O errors }
 150      begin
 151      Case Errno of
 152        2 : S:=SFileNotFound;
 153        3 : S:=SInvalidFileName;
 154        4 : S:=STooManyOpenFiles;
 155        5 : S:=SAccessDenied;
 156        6 : S:=SInvalidFileHandle;
 157        15 : S:=SInvalidDrive;
 158        100 : S:=SEndOfFile;
 159        101 : S:=SDiskFull;
 160        102 : S:=SFileNotAssigned;
 161        103 : S:=SFileNotOpen;
 162        104 : S:=SFileNotOpenForInput;
 163        105 : S:=SFileNotOpenForOutput;
 164        106 : S:=SInvalidInput;
 165      end;
 166      E:=EinOutError.Create (S);
 167      EInoutError(E).ErrorCode:=IOresult; // Clears InOutRes !!
 168      end;
 169   // We don't set abstracterrorhandler, but we do it here.
 170   // Unless the use sets another handler we'll get here anyway...
 171   200 : E:=EDivByZero.Create(SDivByZero);
 172   201 : E:=ERangeError.Create(SRangeError);
 173   205 : E:=EOverflow.Create(SOverflow);
 174   206 : E:=EOverflow.Create(SUnderflow);
 175   207 : E:=EInvalidOp.Create(SInvalidOp);
 176   211 : E:=EAbstractError.Create(SAbstractError);
 177   215 : E:=EIntOverflow.Create(SIntOverflow);
 178   216 : E:=EAccessViolation.Create(SAccessViolation);
 179   219 : E:=EInvalidCast.Create(SInvalidCast);
 180   227 : E:=EAssertionFailed.Create(SAssertionFailed);
 181   else
 182    E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
 183   end;
 184   Raise E at longint(Address){$ifdef ENHANCEDRAISE},longint(Frame){$endif};
 185 end;
 186
 187
 188 Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo,TheAddr : Longint);
 189 Var
 190   S : String;
 191 begin
 192   If Msg='' then
 193     S:=SAssertionFailed
 194   else
 195     S:=Msg;
 196   Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]); // at Pointer(theAddr);
 197 end;
 198
 199 {$ifdef STACKCHECK_WAS_ON}
 200 {$S+}
 201 {$endif}
 202
 203 Procedure InitExceptions;
 204 {
 205   Must install uncaught exception handler (ExceptProc)
 206   and install exceptions for system exceptions or signals.
 207   (e.g: SIGSEGV -> ESegFault or so.)
 208 }
 209 begin
 210   ExceptProc:=@CatchUnhandledException;
 211   // Create objects that may have problems when there is no memory.
 212   OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
 213   InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
 214   AssertErrorProc:=@AssertErrorHandler;
 215   ErrorProc:=@RunErrorToExcept;
 216   OnShowException:=Nil;
 217 end;
 218
 219 { Exception handling routines }
 220
 221 function ExceptObject: TObject;
 222
 223 begin
 224   If RaiseList=Nil then
 225     Result:=Nil
 226   else
 227     Result:=RaiseList^.FObject;
 228 end;
 229
 230 function ExceptAddr: Pointer;
 231
 232 begin
 233   If RaiseList=Nil then
 234     Result:=Nil
 235   else
 236     Result:=RaiseList^.Addr;
 237 end;
 238
 239 function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
 240                                Buffer: PChar; Size: Integer): Integer;
 241
 242 Var
 243   S : AnsiString;
 244   Len : Integer;
 245
 246 begin
 247   S:=Format(SExceptionErrorMessage,[ExceptObject.ClassName,ExceptAddr]);
 248   If ExceptObject is Exception then
 249     S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]);
 250   Len:=Length(S);
 251   If S[Len]<>'.' then
 252     begin
 253     S:=S+'.';
 254     Inc(len);
 255     end;
 256   If Len>Size then
 257     Len:=Size;
 258   Move(S[1],Buffer^,Len);
 259   Result:=Len;
 260 end;
 261
 262 procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
 263
 264 // use shortstring. On exception, the heap may be corrupt.
 265
 266 Var
 267   Buf : ShortString;
 268
 269 begin
 270   SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255));
 271   If IsConsole Then
 272     writeln(Buf)
 273   else
 274     If Assigned(OnShowException) Then
 275       OnShowException (Buf);
 276 end;
 277
 278 procedure Abort;
 279
 280 begin
 281   Raise EAbort.Create(SAbortError) at Get_Caller_addr(Get_Frame)
 282 end;
 283
 284 procedure OutOfMemoryError;
 285
 286 begin
 287   Raise OutOfMemory;
 288 end;
 289
 290 {
 291   $Log$
 292   Revision 1.1  2002/02/19 08:25:47  sasu
 293   Initial revision
 294
 295   Revision 1.1.2.1  2000/08/20 15:07:37  peter
 296     * sysutils.pp moved into target specific directory and merged
 297       disk.inc and filutil.inc in it
 298
 299 }