fpc/compiler/tpexcept.pas

{
    $Id$
    Copyright (c) 1993-98 by Florian Klaempfl

    SetJmp and LongJmp implementation for recovery handling of the
    compiler

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    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.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************}
unit tpexcept;
interface

{$ifndef LINUX}
  {$S-}
{$endif}


type
   jmp_buf = record
{$ifdef TP}
      _ax,_bx,_cx,_dx,_si,_di,_bp,_sp,_ip,flags : word;
      _cs,_ds,_es,_ss : word;
{$else}
      eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
      cs,ds,es,fs,gs,ss : word;
{$endif TP}
   end;

   pjmp_buf = ^jmp_buf;
   
{$ifdef TP}
  function setjmp(var rec : jmp_buf) : integer;
  procedure longjmp(const rec : jmp_buf;return_value : integer);
{$else}
  function setjmp(var rec : jmp_buf) : longint;
  procedure longjmp(const rec : jmp_buf;return_value : longint);
{$endif TP}

  const
     recoverpospointer : pjmp_buf = nil;
     longjump_used : boolean = false;
     
implementation


{*****************************************************************************
                             Exception Helpers
*****************************************************************************}

{$ifdef TP}

    function setjmp(var rec : jmp_buf) : integer;
      begin
         asm
            push di
            push es
            les di,rec
            mov es:[di].jmp_buf._ax,ax
            mov es:[di].jmp_buf._bx,bx
            mov es:[di].jmp_buf._cx,cx
            mov es:[di].jmp_buf._dx,dx
            mov es:[di].jmp_buf._si,si

            { load di }
            mov ax,[bp-4]

            { ... and store it }
            mov es:[di].jmp_buf._di,ax

            { load es }
            mov ax,[bp-6]

            { ... and store it }
            mov es:[di].jmp_buf._es,ax

            { bp ... }
            mov ax,[bp]
            mov es:[di].jmp_buf._bp,ax

            { sp ... }
            mov ax,bp
            add ax,10
            mov es:[di].jmp_buf._sp,ax

            { the return address }
            mov ax,[bp+2]
            mov es:[di].jmp_buf._ip,ax
            mov ax,[bp+4]
            mov es:[di].jmp_buf._cs,ax

            { flags ... }
            pushf
            pop word ptr es:[di].jmp_buf.flags

            mov es:[di].jmp_buf._ds,ds
            mov es:[di].jmp_buf._ss,ss

            { restore es:di }
            pop es
            pop di

            { we come from the initial call }
            xor ax,ax
            leave
            retf 4
         end;
      end;

    procedure longjmp(const rec : jmp_buf;return_value : integer);
      begin
         asm

            { this is the address of rec }
            lds di,rec

            { save return value }
            mov ax,return_value
            mov ds:[di].jmp_buf._ax,ax

            { restore compiler shit }
            pop bp

            { restore some registers }
            mov bx,ds:[di].jmp_buf._bx
            mov cx,ds:[di].jmp_buf._cx
            mov dx,ds:[di].jmp_buf._dx
            mov bp,ds:[di].jmp_buf._bp

            { create a stack frame for the return }
            mov es,ds:[di].jmp_buf._ss
            mov si,ds:[di].jmp_buf._sp

            sub si,12

            { store ds }
            mov ax,ds:[di].jmp_buf._ds
            mov es:[si],ax

            { store di }
            mov ax,ds:[di].jmp_buf._di
            mov es:[si+2],ax

            { store si }
            mov ax,ds:[di].jmp_buf._si
            mov es:[si+4],ax

            { store flags }
            mov ax,ds:[di].jmp_buf.flags
            mov es:[si+6],ax

            { store ip }
            mov ax,ds:[di].jmp_buf._ip
            mov es:[si+8],ax

            { store cs }
            mov ax,ds:[di].jmp_buf._cs
            mov es:[si+10],ax

            { load stack }
            mov ax,es
            mov ss,ax
            mov sp,si

            { load return value }
            mov ax,ds:[di].jmp_buf._ax

            { load old ES }
            mov es,ds:[di].jmp_buf._es

            pop ds
            pop di
            pop si

            popf
            retf
         end;
      end;

{$else}
{$ifdef Delphi}

    function setjmp(var rec : jmp_buf) : longint;

      begin
         result:=0;
      end;

    procedure longjmp(const rec : jmp_buf;return_value : longint);

      begin
      end;
      
{$else Delphi}

    function setjmp(var rec : jmp_buf) : longint;
      begin
         asm
            pushl %edi
            movl rec,%edi
            movl %eax,(%edi)
            movl %ebx,4(%edi)
            movl %ecx,8(%edi)
            movl %edx,12(%edi)
            movl %esi,16(%edi)

            { load edi }
            movl -4(%ebp),%eax

            { ... and store it }
            movl %eax,20(%edi)

            { ebp ... }
            movl (%ebp),%eax
            movl %eax,24(%edi)

            { esp ... }
            movl %esp,%eax
            addl $12,%eax
            movl %eax,28(%edi)

            { the return address }
            movl 4(%ebp),%eax
            movl %eax,32(%edi)

            { flags ... }
            pushfl
            popl 36(%edi)

            { !!!!! the segment registers, not yet needed }
            { you need them if the exception comes from
            an interrupt or a seg_move }
            movw %cs,40(%edi)
            movw %ds,42(%edi)
            movw %es,44(%edi)
            movw %fs,46(%edi)
            movw %gs,48(%edi)
            movw %ss,50(%edi)

            { restore EDI }
            pop %edi

            { we come from the initial call }
            xorl %eax,%eax

            leave
            ret $4
         end;
      end;


    procedure longjmp(const rec : jmp_buf;return_value : longint);
      begin
         asm
            { restore compiler shit }
            popl %ebp
            { this is the address of rec }
            movl 4(%esp),%edi

            { save return value }
            movl 8(%esp),%eax
            movl %eax,0(%edi)

            { !!!!! load segment registers }
            movw 46(%edi),%fs
            movw 48(%edi),%gs

            { ... and some other registers }
            movl 4(%edi),%ebx
            movl 8(%edi),%ecx
            movl 12(%edi),%edx
            movl 24(%edi),%ebp

            { !!!!! movw 50(%edi),%es }
            movl 28(%edi),%esi

            { create a stack frame for the return }
            subl $16,%esi

            {
            movzwl 42(%edi),%eax
             !!!!! es
            movl %eax,(%esi)
            }

            { edi }
            movl 20(%edi),%eax
            { !!!!! es }
            movl %eax,(%esi)

            { esi }
            movl 16(%edi),%eax
            { !!!!! es }
            movl %eax,4(%esi)

            { eip }
            movl 32(%edi),%eax
            { !!!!! es }
            movl %eax,12(%esi)

            { !!!!! cs
            movl 40(%edi),%eax
            es
            movl %eax,16(%esi)
            }

            { load and store flags }
            movl 36(%edi),%eax
            { !!!!!
            es
            }
            movl %eax,8(%esi)

            { load return value }
            movl 0(%edi),%eax

            { load old ES
            !!!!! movw 44(%edi),%es
            }

            { load stack
            !!!!! movw 50(%edi),%ss }
            movl %esi,%esp

            { !!!!
            popl %ds
            }
            popl %edi
            popl %esi

            popfl
            ret
         end;
      end;
{$endif Delphi}
{$endif TP}

end.
{
  $Log$
  Revision 1.6  1999-05-04 21:45:08  florian
    * changes to compile it with Delphi 4.0

  Revision 1.5  1998/10/28 18:26:23  pierre
   * removed some erros after other errors (introduced by useexcept)
   * stabs works again correctly (for how long !)

  Revision 1.4  1998/10/26 22:58:24  florian
    * new introduded problem with classes fix, the parent class wasn't set
      correct, if the class was defined forward before

  Revision 1.3  1998/10/26 17:15:19  pierre
    + added two level of longjump to
      allow clean freeing of used memory on errors

  Revision 1.2  1998/08/28 10:57:03  peter
    * removed warnings

  Revision 1.1  1998/08/10 10:18:36  peter
    + Compiler,Comphook unit which are the new interface units to the
      compiler

}