paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 22:49:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ implementation of raise and try..finally

Browse Source 
+ some misc. exception stuff
This commit is contained in:
florian 1998-07-28 21:52:49 +00:00
parent 8cc8cb80b2
commit 25b34c1c6c
6 changed files with 175 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
compiler/cg386flw.pas
View File

@ -484,6 +484,7 @@ do_jmp:
*****************************************************************************}
procedure secondgoto(var p : ptree);
begin
emitl(A_JMP,p^.labelnr);
end;
@ -506,8 +507,10 @@ do_jmp:
*****************************************************************************}
procedure secondraise(var p : ptree);
var
a : plabel;
begin
if assigned(p^.left) then
begin
@ -515,13 +518,13 @@ do_jmp:
if assigned(p^.right) then
begin
secondpass(p^.right);
if codegenerror then
exit;
if codegenerror then
exit;
end
else
begin
begin
getlabel(a);
emitl(A_LABEL,a);
emitl(A_LABEL,a);
exprasmlist^.concat(new(pai386,
op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0))));
end;
@ -536,10 +539,12 @@ do_jmp:
p^.left^.location.register)));
else Message(sym_e_type_mismatch);
end;
emitcall('DO_RAISE',true);
emitcall('FPC_RAISEEXCEPTION',true);
end
else
emitcall('DO_RERAISE',true);
begin
emitcall('FPC_RERAISE',true);
end;
end;
@ -548,16 +553,118 @@ do_jmp:
*****************************************************************************}
procedure secondtryexcept(var p : ptree);
begin
end;
var
exceptlabel,doexceptlabel,endexceptlabel,
nextonlabel,lastonlabel : plabel;
begin
{ we modify EAX }
usedinproc:=usedinproc or ($80 shr byte(R_EAX));
getlabel(exceptlabel);
getlabel(doexceptlabel);
getlabel(endexceptlabel);
getlabel(lastonlabel);
emitcall('FPC_PUSHEXCEPTADDR',true);
exprasmlist^.concat(new(pai386,
op_reg(A_PUSH,S_L,R_EAX)));
emitcall('FPC_SETJMP',true);
exprasmlist^.concat(new(pai386,
op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.concat(new(pai386,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitl(A_JNE,exceptlabel);
{ try code }
secondpass(p^.left);
if codegenerror then
exit;
emitl(A_LABEL,exceptlabel);
exprasmlist^.concat(new(pai386,
op_reg(A_POP,S_L,R_EAX)));
exprasmlist^.concat(new(pai386,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitl(A_JNE,doexceptlabel);
emitcall('FPC_POPADDRSTACK',true);
emitl(A_JMP,endexceptlabel);
emitl(A_LABEL,doexceptlabel);
{ for each object: }
while false do
begin
getlabel(nextonlabel);
end;
{
for each 'on object' do :
----------------
pushl objectclass; // pass object class, or -1 if no class specified.
call FPC_CATCHES // Does this object tacth the exception ?
testl %eax,%eax
je .nexton // No, jump to next on...
... code for on handler...
.nexton
...
}
emitl(A_LABEL,lastonlabel);
{ default handling }
if assigned(p^.t1) then
secondpass(p^.t1)
else
emitcall('FPC_RERAISE',true);
emitl(A_LABEL,endexceptlabel);
end;
{*****************************************************************************
SecondTryFinally
*****************************************************************************}
procedure secondtryfinally(var p : ptree);
var
finallylabel,noreraiselabel,endfinallylabel : plabel;
begin
{ we modify EAX }
usedinproc:=usedinproc or ($80 shr byte(R_EAX));
getlabel(finallylabel);
getlabel(noreraiselabel);
getlabel(endfinallylabel);
emitcall('FPC_PUSHEXCEPTADDR',true);
exprasmlist^.concat(new(pai386,
op_reg(A_PUSH,S_L,R_EAX)));
emitcall('FPC_SETJMP',true);
exprasmlist^.concat(new(pai386,
op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.concat(new(pai386,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitl(A_JNE,finallylabel);
{ try code }
secondpass(p^.left);
if codegenerror then
exit;
emitl(A_LABEL,finallylabel);
{ finally code }
secondpass(p^.right);
if codegenerror then
exit;
exprasmlist^.concat(new(pai386,
op_reg(A_POP,S_L,R_EAX)));
exprasmlist^.concat(new(pai386,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitl(A_JE,noreraiselabel);
emitcall('FPC_RERAISE',true);
emitl(A_JMP,endfinallylabel);
emitl(A_LABEL,noreraiselabel);
emitcall('FPC_POPADDRSTACK',true);
emitl(A_LABEL,endfinallylabel);
end;
@ -590,7 +697,11 @@ do_jmp:
end.
{
$Log$
Revision 1.4 1998-07-24 22:16:53 florian
Revision 1.5 1998-07-28 21:52:49 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.4 1998/07/24 22:16:53 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.

13
compiler/cgi386.pas
View File

@ -316,15 +316,17 @@ implementation
end;
end;
procedure generatecode(var p : ptree);
var
i : longint;
regsize : topsize;
regi : tregister;
hr : preference;
label
nextreg;
begin
cleartempgen;
{ when size optimization only count occurrence }
@ -353,8 +355,9 @@ implementation
begin
{ max. optimizations }
{ only if no asm is used }
{ and no try statement }
if (cs_maxoptimieren in aktswitches) and
((procinfo.flags and pi_uses_asm)=0) then
((procinfo.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
begin
{ can we omit the stack frame ? }
{ conditions:
@ -502,7 +505,11 @@ implementation
end.
{
$Log$
Revision 1.42 1998-07-15 16:06:44 jonas
Revision 1.43 1998-07-28 21:52:50 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.42 1998/07/15 16:06:44 jonas
* fixed bug that caused the stackframe never to be omitted
Revision 1.41 1998/07/14 14:46:44 peter

8
compiler/hcodegen.pas
View File

@ -40,6 +40,8 @@ unit hcodegen;
pi_do_call = $4; { set, if the procedure does a call }
pi_operator = $8; { set, if the procedure is an operator }
pi_C_import = $10; { set, if the procedure is an external C function }
pi_uses_exceptions = $20;{ set, if the procedure has a try statement => }
{ no register variables }
type
pprocinfo = ^tprocinfo;
@ -403,7 +405,11 @@ end.
{
$Log$
Revision 1.10 1998-07-20 18:40:13 florian
Revision 1.11 1998-07-28 21:52:51 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.10 1998/07/20 18:40:13 florian
* handling of ansi string constants should now work
Revision 1.9 1998/06/05 16:13:34 pierre

20
compiler/pass_1.pas
View File

@ -4769,6 +4769,20 @@ unit pass_1;
procedure firsttryfinally(var p : ptree);
begin
cleartempgen;
must_be_valid:=true;
firstpass(p^.left);
cleartempgen;
must_be_valid:=true;
firstpass(p^.right);
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
end;
procedure firstis(var p : ptree);
@ -5100,7 +5114,11 @@ unit pass_1;
end.
{
$Log$
Revision 1.45 1998-07-26 21:58:59 florian
Revision 1.46 1998-07-28 21:52:52 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.45 1998/07/26 21:58:59 florian
+ better support for switch $H
+ index access to ansi strings added
+ assigment of data (records/arrays) containing ansi strings

8
compiler/pexpr.pas
View File

@ -683,7 +683,7 @@ unit pexpr;
procedure postfixoperators;
begin
check_tokenpos;
check_tokenpos;
while again do
begin
case token of
@ -1788,7 +1788,11 @@ unit pexpr;
end.
{
$Log$
Revision 1.29 1998-07-27 21:57:13 florian
Revision 1.30 1998-07-28 21:52:54 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.29 1998/07/27 21:57:13 florian
* fix to allow tv like stream registration:
@tmenu.load doesn't work if load had parameters or if load was only
declared in an anchestor class of tmenu

19
compiler/pstatmnt.pas
View File

@ -483,6 +483,9 @@ unit pstatmnt;
old_in_except_block : boolean;
begin
procinfo.flags:=procinfo.flags or
pi_uses_exceptions;
p_default:=nil;
p_specific:=nil;
@ -541,11 +544,11 @@ unit pstatmnt;
{ !!!!! }
end;
consume(_DO);
statement;
if token<>SEMICOLON then
break;
emptystats;
until false;
statement;
if token<>SEMICOLON then
break;
emptystats;
until false;
if token=_ELSE then
{ catch the other exceptions }
begin
@ -1168,7 +1171,11 @@ unit pstatmnt;
end.
{
$Log$
Revision 1.26 1998-07-27 21:57:14 florian
Revision 1.27 1998-07-28 21:52:55 florian
+ implementation of raise and try..finally
+ some misc. exception stuff
Revision 1.26 1998/07/27 21:57:14 florian
* fix to allow tv like stream registration:
@tmenu.load doesn't work if load had parameters or if load was only
declared in an anchestor class of tmenu