paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 03:29:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Initial implementation

Browse Source
This commit is contained in:
michael 1998-07-28 20:36:41 +00:00
parent 3fc40cebb2
commit 11cbb1fd82
5 changed files with 306 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
rtl/i386/setjump.inc Normal file
View File

@ -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}

28
rtl/i386/setjumph.inc Normal file
View File

@ -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);

165
rtl/inc/except.inc Normal file
View File

@ -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;

29
rtl/m68k/setjump.inc Normal file
View File

@ -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;

29
rtl/m68k/setjumph.inc Normal file
View File

@ -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);