+ Initial implementation

rtl/i386/setjump.inc

@@ -0,0 +1,55 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    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.
+
+ **********************************************************************}
+
+{**********************************************************************
+           Set_Jmp/Long_jmp
+ **********************************************************************}
+
+{$I386_DIRECT}
+Function SetJmp (Var S : Jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP'];
+
+asm
+  movl 8(%ebp),%eax
+  movl %ebx,(%eax)
+  movl %esi,4(%eax)
+  movl %edi,8(%eax)
+  movl 4(%ebp),%edx
+  movl %edx,20(%eax)
+  movl (%ebp),%edx
+  movl %edx,12(%eax)
+  leal 8(%ebp),%edx
+  movl %edx,16(%eax)
+  xorl %eax,%eax
+end;
+
+Procedure longJmp (Var S : Jmp_buf; value : longint); assembler;[Public, alias : 'FPC_LONGJMP'];
+
+asm
+  movl 8(%ebp),%ecx
+  movl 12(%ebp),%eax
+  testl %eax,%eax
+  jne .nonzero
+  movl $1,%eax
+.nonzero:
+  movl (%ecx),%ebx
+  movl 4(%ecx),%esi
+  movl 8(%ecx),%edi
+  movl 12(%ecx),%ebp
+  movl 16(%ecx),%esp
+  jmp *20(%ecx)
+end;
+
+{$I386_ATT}
+

rtl/i386/setjumph.inc

@@ -0,0 +1,28 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    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.
+
+ **********************************************************************}
+
+{**********************************************************************
+          Declarations for SetJmp/LongJmp
+ **********************************************************************}
+
+Type
+  jmp_buf = record
+    ebx,esi,edi : Longint;
+    bp,sp,pc : Pointer;
+    end;
+  PJmp_buf = ^jmp_buf;
+
+Function Setjmp (Var S : Jmp_buf) : longint;
+Procedure longjmp (Var S : Jmp_buf; value : longint);

rtl/inc/except.inc

@@ -0,0 +1,165 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    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 
+  { 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
+  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);
+
+var 
+    Newobj : PExceptObject;
+    
+begin
+  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;
+
+Function Raiseexcept (Obj : TObject; AnAddr : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
+
+begin
+  PushExceptObj(Obj,AnAddr);
+  longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
+end;
+
+Procedure PopAddrStack ;[Public, Alias : 'FPC_POPADDRSTACK'];
+
+begin
+  If ExceptAddrStack=nil then
+    begin
+    writeln ('At end of ExceptionAddresStack');
+    halt (1);
+    end
+  else
+    ExceptAddrStack:=ExceptAddrStack^.Next;
+end;
+
+Procedure PopObjectStack ;
+
+begin
+  If ExceptObjectStack=nil then
+    begin
+    writeln ('At end of ExceptionObjectStack');
+    halt (1);
+    end
+  else
+    ExceptObjectStack:=ExceptObjectStack^.Next;
+end;
+
+Procedure ReRaise;[Public, Alias : 'FPC_RERAISE'];
+
+begin
+  PopAddrStack;
+  If ExceptAddrStack=Nil then
+    begin
+    writeln ('Re-Raise : At end of address chain.');
+    halt (1);
+    end;
+  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;
+    PopObjectStack;
+    PopAddrStack;
+    end;
+end;
+
+Procedure InitExceptions;
+{
+  Initialize exceptionsupport
+}
+begin
+  ExceptObjectstack:=Nil;
+  ExceptAddrStack:=Nil;
+end;

rtl/m68k/setjump.inc

@@ -0,0 +1,29 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    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.
+
+ **********************************************************************}
+
+{**********************************************************************
+           Set_Jmp/Long_jmp
+ **********************************************************************}
+
+Function SetJmp (Var S : Jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP'];
+
+asm
+end;
+
+Procedure longJmp (Var S : Jmp_buf; value : longint); assembler;[Public, alias : 'FPC_LONGJMP'];
+
+asm
+end;
+

rtl/m68k/setjumph.inc

@@ -0,0 +1,29 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    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.
+
+ **********************************************************************}
+
+{**********************************************************************
+          Declarations for SetJmp/LongJmp
+ **********************************************************************}
+
+Type
+  // CARL, CHANGE THESE TO THE NEEDED VALUES !  (MVC)
+  jmp_buf = record
+    ebx,esi,edi : Longint;
+    bp,sp,pc : Pointer;
+    end;
+  PJmp_buf = ^jmp_buf;
+
+Function Setjmp (Var S : Jmp_buf) : longint;
+Procedure longjmp (Var S : Jmp_buf; value : longint);