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

* bug exit('test') + fail for classes

Browse Source
This commit is contained in:
pierre 1999-10-05 22:01:52 +00:00
parent 372ec1abee
commit 781429264d
3 changed files with 41 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
compiler/cg386flw.pas
View File

@ -389,6 +389,13 @@ implementation
do_jmp;
begin
if assigned(p^.left) then
if p^.left^.treetype=assignn then
begin
{ just do a normal assignment followed by exit }
secondpass(p^.left);
emitjmp(C_None,aktexitlabel);
end
else
begin
otlabel:=truelabel;
oflabel:=falselabel;
@ -811,7 +818,10 @@ do_jmp:
end.
{
$Log$
Revision 1.52 1999-09-27 23:44:46 peter
Revision 1.53 1999-10-05 22:01:52 pierre
* bug exit('test') + fail for classes
Revision 1.52 1999/09/27 23:44:46 peter
* procinfo is now a pointer
* support for result setting in sub procedure
@ -1011,4 +1021,3 @@ end.
* splitted cgi386
}

20
compiler/cgai386.pas
View File

@ -3223,10 +3223,19 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
getlabel(okexitlabel);
emitjmp(C_NONE,okexitlabel);
emitlab(faillabel);
emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,12),R_ESI);
emit_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI);
emitcall('FPC_HELP_FAIL');
if procinfo^._class^.is_class then
begin
emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,8),R_ESI);
emitcall('FPC_HELP_FAIL_CLASS');
end
else
begin
emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,12),R_ESI);
emit_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI);
emitcall('FPC_HELP_FAIL');
end;
emitlab(okexitlabel);
emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
emit_reg_reg(A_OR,S_L,R_EAX,R_EAX);
end;
@ -3377,7 +3386,10 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end.
{
$Log$
Revision 1.50 1999-09-29 11:46:18 florian
Revision 1.51 1999-10-05 22:01:52 pierre
* bug exit('test') + fail for classes
Revision 1.50 1999/09/29 11:46:18 florian
* fixed bug 292 from bugs directory
Revision 1.49 1999/09/28 21:07:53 florian

15
compiler/tcflw.pas
View File

@ -322,6 +322,8 @@ implementation
*****************************************************************************}
procedure firstexit(var p : ptree);
var
pt : ptree;
begin
if assigned(p^.left) then
begin
@ -332,6 +334,14 @@ implementation
{ Check the 2 types }
p^.left:=gentypeconvnode(p^.left,p^.resulttype);
firstpass(p^.left);
if ret_in_param(p^.resulttype) then
begin
pt:=genzeronode(funcretn);
pt^.retdef:=p^.resulttype;
pt^.funcretprocinfo:=procinfo;
p^.left:=gennode(assignn,pt,p^.left);
firstpass(p^.left);
end;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
@ -497,7 +507,10 @@ implementation
end.
{
$Log$
Revision 1.22 1999-10-04 20:27:41 peter
Revision 1.23 1999-10-05 22:01:53 pierre
* bug exit('test') + fail for classes
Revision 1.22 1999/10/04 20:27:41 peter
* fixed first pass for if branches if the expression got an error
Revision 1.20 1999/09/27 23:45:01 peter