fpc/rtl/inc/except.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1998 by Michael Van Canneyt
    member of the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{****************************************************************************
                                Exception support
****************************************************************************}


Const
  { Type of exception. Currently only one. }
  FPC_EXCEPTION   = 1;

  { types of frames for the exception address stack }
  cExceptionFrame = 1;
  cFinalizeFrame  = 2;

Type
  PExceptAddr = ^TExceptAddr;
  TExceptAddr = record
    buf       : pjmp_buf;
    frametype : Longint;
    next      : PExceptAddr;
  end;

  PExceptObject = ^TExceptObject;
  TExceptObject = record
    FObject : TObject;
    Addr    : pointer;
    Next    : PExceptObject;
  end;

  TExceptObjectClass = Class of TObject;

Const
  CatchAllExceptions = -1;

Var
  ExceptAddrStack   : PExceptAddr;
  ExceptObjectStack : PExceptObject;


Function PushExceptAddr (Ft: Longint): PJmp_buf ;[Public, Alias : 'FPC_PUSHEXCEPTADDR'];
var
  Buf : PJmp_buf;
  NewAddr : PExceptAddr;
begin
{$ifdef excdebug}
  writeln ('In PushExceptAddr');
{$endif}
  If ExceptAddrstack=Nil then
    begin
      New(ExceptAddrStack);
      ExceptAddrStack^.Next:=Nil;
    end
  else
    begin
      New(NewAddr);
      NewAddr^.Next:=ExceptAddrStack;
      ExceptAddrStack:=NewAddr;
    end;
  new(buf);
  ExceptAddrStack^.Buf:=Buf;
  ExceptAddrStack^.FrameType:=ft;
  PushExceptAddr:=Buf;
end;


Procedure PushExceptObj (Obj : TObject; AnAddr : Pointer); [Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];
var
  Newobj : PExceptObject;
begin
{$ifdef excdebug}
  writeln ('In PushExceptObject');
{$endif}
  If ExceptObjectStack=Nil then
    begin
      New(ExceptObjectStack);
      ExceptObjectStack^.Next:=Nil;
    end
  else
    begin
      New(NewObj);
      NewObj^.Next:=ExceptObjectStack;
      ExceptObjectStack:=NewObj;
    end;
  ExceptObjectStack^.FObject:=Obj;
  ExceptObjectStack^.Addr:=AnAddr;
end;


Procedure DoUnHandledException;
begin
  If ExceptProc<>Nil then
    If ExceptObjectStack<>Nil then
      TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr);
  RunError(217);
end;


Function Raiseexcept (Obj : TObject; AnAddr : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
begin
{$ifdef excdebug}
  writeln ('In RaiseException');
{$endif}
  Raiseexcept:=nil;
  PushExceptObj(Obj,AnAddr);
  If ExceptAddrStack=Nil then
    DoUnhandledException;
  longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
end;


Procedure PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK'];
var
  hp : PExceptAddr;
begin
{$ifdef excdebug}
  writeln ('In Popaddrstack');
{$endif}
  If ExceptAddrStack=nil then
    begin
      writeln ('At end of ExceptionAddresStack');
      halt (255);
    end
  else
    begin
      hp:=ExceptAddrStack;
      ExceptAddrStack:=ExceptAddrStack^.Next;
      dispose(hp^.buf);
      dispose(hp);
    end;
end;


Procedure PopObjectStack;[Public, Alias : 'FPC_POPOBJECTSTACK'];
var
  hp : PExceptObject;
begin
{$ifdef excdebug}
  writeln ('In PopObjectstack');
{$endif}
  If ExceptObjectStack=nil then
    begin
    writeln ('At end of ExceptionObjectStack');
    halt (1);
    end
  else
    begin
       hp:=ExceptObjectStack;
       ExceptObjectStack:=ExceptObjectStack^.next;
       dispose(hp);
    end;
end;


Procedure ReRaise;[Public, Alias : 'FPC_RERAISE'];
begin
{$ifdef excdebug}
  writeln ('In reraise');
{$endif}
  PopAddrStack;
  If ExceptAddrStack=Nil then
    DoUnHandledException;
  longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
end;


Function Catches(Objtype : TExceptObjectClass) : TObject;[Public, Alias : 'FPC_CATCHES'];
begin
  If ExceptObjectStack=Nil then
   begin
     Writeln ('Internal error.');
     halt (255);
   end;
  if Not ((Objtype = TExceptObjectClass(CatchAllExceptions)) or
         (ExceptObjectStack^.FObject is ObjType)) then
    Catches:=Nil
  else
    begin
      // catch !
      Catches:=ExceptObjectStack^.FObject;
      { this can't be done, because there could be a reraise (PFV)
       PopObjectStack; }
      PopAddrStack;
    end;
end;

Procedure DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION'];
begin
  o.Destroy;
end;


Procedure InitExceptions;
{
  Initialize exceptionsupport
}
begin
  ExceptObjectstack:=Nil;
  ExceptAddrStack:=Nil;
end;
{
  $Log$
  Revision 1.11  1999-06-14 00:47:35  peter
    * merged

  Revision 1.10.2.1  1999/06/14 00:38:18  peter
    * don't pop object stack in catches, because it's needed for reraise

  Revision 1.10  1999/05/13 18:38:26  florian
    * more memory leaks fixed:
         - exceptaddrobject is now properly disposed
         - after the end of the on ... do block the exception
           class instance is disposed

  Revision 1.9  1999/05/13 16:30:18  florian
    * popaddrstack didn't release any memory, fixed
}