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

+ TEST_FUNCRET now default (old code removed)

Browse Source 
works also for m68k (at least compiles)
This commit is contained in:
pierre 1998-08-21 14:08:39 +00:00
parent ddd859e835
commit b61cd6cd0e
11 changed files with 156 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
compiler/assemble.pas
View File

@ -390,7 +390,7 @@ begin
case aktoutputformat of case aktoutputformat of
{$ifdef i386} {$ifdef i386}
{$ifndef NoAg386Att} {$ifndef NoAg386Att}
as_o : a:=new(pi386attasmlist,Init); as_o,as_o_aout,as_asw : a:=new(pi386attasmlist,Init);
{$endif NoAg386Att} {$endif NoAg386Att}
{$ifndef NoAg386Nsm} {$ifndef NoAg386Nsm}
as_nasmcoff, as_nasmcoff,
@ -437,7 +437,11 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.17 1998-08-17 09:17:43 peter Revision 1.18 1998-08-21 14:08:39 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.17 1998/08/17 09:17:43 peter
* static/shared linking updates * static/shared linking updates
Revision 1.16 1998/08/14 21:56:30 peter Revision 1.16 1998/08/14 21:56:30 peter

16
compiler/cg386ld.pas
View File

@ -514,18 +514,11 @@ implementation
procedure secondfuncret(var p : ptree); procedure secondfuncret(var p : ptree);
var var
hr : tregister; hr : tregister;
{$ifdef TEST_FUNCRET}
hp : preference; hp : preference;
pp : pprocinfo; pp : pprocinfo;
hr_valid : boolean; hr_valid : boolean;
{$endif TEST_FUNCRET}
begin begin
clear_reference(p^.location.reference); clear_reference(p^.location.reference);
{$ifndef TEST_FUNCRET}
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(procinfo.retdef) then
{$else TEST_FUNCRET}
hr_valid:=false; hr_valid:=false;
if @procinfo<>pprocinfo(p^.funcretprocinfo) then if @procinfo<>pprocinfo(p^.funcretprocinfo) then
begin begin
@ -549,11 +542,8 @@ implementation
p^.location.reference.base:=procinfo.framepointer; p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset; p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(p^.retdef) then if ret_in_param(p^.retdef) then
{$endif TEST_FUNCRET}
begin begin
{$ifdef TEST_FUNCRET}
if not hr_valid then if not hr_valid then
{$endif TEST_FUNCRET}
hr:=getregister32; hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr))); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr)));
p^.location.reference.base:=hr; p^.location.reference.base:=hr;
@ -565,7 +555,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.9 1998-08-20 09:26:37 pierre Revision 1.10 1998-08-21 14:08:40 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.9 1998/08/20 09:26:37 pierre
+ funcret setting in underproc testing + funcret setting in underproc testing
compile with _dTEST_FUNCRET compile with _dTEST_FUNCRET

42
compiler/cga68k.pas
View File

@ -1195,19 +1195,41 @@ end;
end; end;
procedure secondfuncret(var p : ptree); procedure secondfuncret(var p : ptree);
var var
hregister : tregister; hr : tregister;
hp : preference;
pp : pprocinfo;
hr_valid : boolean;
begin begin
clear_reference(p^.location.reference); clear_reference(p^.location.reference);
hr_valid:=false;
if @procinfo<>pprocinfo(p^.funcretprocinfo) then
begin
hr:=getaddressreg;
hr_valid:=true;
hp:=new_reference(procinfo.framepointer,
procinfo.framepointer_offset);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,hp,hr)));
pp:=procinfo.parent;
{ walk up the stack frame }
while pp<>pprocinfo(p^.funcretprocinfo) do
begin
hp:=new_reference(hr,
pp^.framepointer_offset);
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,hp,hr)));
pp:=pp^.parent;
end;
p^.location.reference.base:=hr;
end
else
p^.location.reference.base:=procinfo.framepointer; p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset; p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(procinfo.retdef) then if ret_in_param(p^.retdef) then
begin begin
hregister:=getaddressreg; if not hr_valid then
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,newreference(p^.location.reference),hregister))); hr:=getaddressreg;
p^.location.reference.base:=hregister; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,newreference(p^.location.reference),hr)));
p^.location.reference.base:=hr;
p^.location.reference.offset:=0; p^.location.reference.offset:=0;
end; end;
end; end;
@ -1215,7 +1237,11 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.9 1998-08-17 10:10:04 peter Revision 1.10 1998-08-21 14:08:41 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.9 1998/08/17 10:10:04 peter
- removed OLDPPU - removed OLDPPU
Revision 1.8 1998/08/10 14:43:16 peter Revision 1.8 1998/08/10 14:43:16 peter

8
compiler/hcodegen.pas
View File

@ -54,10 +54,8 @@ unit hcodegen;
retdef : pdef; retdef : pdef;
{ return type } { return type }
sym : pprocsym; sym : pprocsym;
{$ifdef TEST_FUNCRET }
{ symbol of the function } { symbol of the function }
funcretsym : pfuncretsym; funcretsym : pfuncretsym;
{$endif TEST_FUNCRET }
{ the definition of the proc itself } { the definition of the proc itself }
{ why was this a pdef only ?? PM } { why was this a pdef only ?? PM }
def : pprocdef; def : pprocdef;
@ -409,7 +407,11 @@ end.
{ {
$Log$ $Log$
Revision 1.13 1998-08-20 09:26:38 pierre Revision 1.14 1998-08-21 14:08:43 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.13 1998/08/20 09:26:38 pierre
+ funcret setting in underproc testing + funcret setting in underproc testing
compile with _dTEST_FUNCRET compile with _dTEST_FUNCRET

20
compiler/m68k.pas
View File

@ -359,6 +359,8 @@ type
function newreference(const r : treference) : preference; function newreference(const r : treference) : preference;
function new_reference(base : tregister;offset : longint) : preference;
function reg2str(r : tregister) : string; function reg2str(r : tregister) : string;
{ generates an help record for constants } { generates an help record for constants }
@ -897,6 +899,18 @@ type
end; end;
end; end;
function new_reference(base : tregister;offset : longint) : preference;
var
r : preference;
begin
new(r);
reset_reference(r^);
r^.base:=base;
r^.offset:=offset;
new_reference:=r;
end;
procedure clear_reference(var ref : treference); procedure clear_reference(var ref : treference);
begin begin
@ -1565,7 +1579,11 @@ type
end. end.
{ {
$Log$ $Log$
Revision 1.5 1998-06-04 23:51:45 peter Revision 1.6 1998-08-21 14:08:44 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.5 1998/06/04 23:51:45 peter
* m68k compiles * m68k compiles
+ .def file creation moved to gendef.pas so it could also be used + .def file creation moved to gendef.pas so it could also be used
for win32 for win32

13
compiler/makefile
View File

@ -196,6 +196,7 @@ COMPILER=$(PP) $(PPOPTS)
PPEXENAME=pp$(EXEEXT) PPEXENAME=pp$(EXEEXT)
EXENAME=ppc386$(EXEEXT) EXENAME=ppc386$(EXEEXT)
M68KEXENAME=ppc68k$(EXEEXT)
TEMPNAME=ppc$(EXEEXT) TEMPNAME=ppc$(EXEEXT)
TEMPNAME1=ppc1$(EXEEXT) TEMPNAME1=ppc1$(EXEEXT)
TEMPNAME2=ppc2$(EXEEXT) TEMPNAME2=ppc2$(EXEEXT)
@ -441,10 +442,20 @@ rtl :
rtlclean : rtlclean :
make -C $(UNITDIR) clean make -C $(UNITDIR) clean
# just a quick way to get ppc68k
$(M68KEXENAME):
make clean
$(PP) -uI386 -uSUPPORT_MMX -dm68k -o$(M68KEXENAME) pp
make clean
# Test of log at the end # Test of log at the end
# does CVS add # at start of each line ?? # does CVS add # at start of each line ??
# $Log$ # $Log$
# Revision 1.25 1998-08-18 09:24:41 pierre # Revision 1.26 1998-08-21 14:08:46 pierre
# + TEST_FUNCRET now default (old code removed)
# works also for m68k (at least compiles)
#
# Revision 1.25 1998/08/18 09:24:41 pierre
# * small warning position bug fixed # * small warning position bug fixed
# * support_mmx switches splitting was missing # * support_mmx switches splitting was missing
# * rhide error and warning output corrected # * rhide error and warning output corrected

20
compiler/pass_1.pas
View File

@ -585,7 +585,6 @@ unit pass_1;
p^.registersmmx:=0; p^.registersmmx:=0;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
clear_reference(p^.location.reference); clear_reference(p^.location.reference);
{$ifdef TEST_FUNCRET}
if p^.symtableentry^.typ=funcretsym then if p^.symtableentry^.typ=funcretsym then
begin begin
putnode(p); putnode(p);
@ -595,7 +594,6 @@ unit pass_1;
firstpass(p); firstpass(p);
exit; exit;
end; end;
{$endif TEST_FUNCRET}
if p^.symtableentry^.typ=absolutesym then if p^.symtableentry^.typ=absolutesym then
begin begin
p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition; p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition;
@ -3619,7 +3617,6 @@ unit pass_1;
procedure firstfuncret(var p : ptree); procedure firstfuncret(var p : ptree);
begin begin
{$ifdef TEST_FUNCRET}
p^.resulttype:=p^.retdef; p^.resulttype:=p^.retdef;
p^.location.loc:=LOC_REFERENCE; p^.location.loc:=LOC_REFERENCE;
if ret_in_param(p^.retdef) or if ret_in_param(p^.retdef) or
@ -3632,17 +3629,6 @@ unit pass_1;
Message(sym_w_function_result_not_set); Message(sym_w_function_result_not_set);
if count_ref then if count_ref then
pprocinfo(p^.funcretprocinfo)^.funcret_is_valid:=true; pprocinfo(p^.funcretprocinfo)^.funcret_is_valid:=true;
{$else TEST_FUNCRET}
p^.resulttype:=procinfo.retdef;
p^.location.loc:=LOC_REFERENCE;
if ret_in_param(procinfo.retdef) then
p^.registers32:=1;
if must_be_valid and
not(procinfo.funcret_is_valid) {and
((procinfo.flags and pi_uses_asm)=0)} then
Message(sym_w_function_result_not_set);
if count_ref then procinfo.funcret_is_valid:=true;
{$endif TEST_FUNCRET}
end; end;
@ -5248,7 +5234,11 @@ unit pass_1;
end. end.
{ {
$Log$ $Log$
Revision 1.60 1998-08-20 12:59:57 peter Revision 1.61 1998-08-21 14:08:47 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.60 1998/08/20 12:59:57 peter
- removed obsolete in_* - removed obsolete in_*
Revision 1.59 1998/08/20 09:26:39 pierre Revision 1.59 1998/08/20 09:26:39 pierre

117
compiler/pexpr.pas
View File

@ -667,6 +667,53 @@ unit pexpr;
propsym : ppropertysym; propsym : ppropertysym;
filepos : tfileposinfo; filepos : tfileposinfo;
{---------------------------------------------
Is_func_ret
---------------------------------------------}
function is_func_ret(sym : psym) : boolean;
var
p : pprocinfo;
storesymtablestack : psymtable;
begin
is_func_ret:=false;
if (sym^.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0) then
exit;
p:=@procinfo;
while assigned(p) do
begin
{ is this an access to a function result ? }
if assigned(p^.funcretsym) and
((sym=p^.funcretsym) or
((pvarsym(sym)=opsym) and
((p^.flags and pi_operator)<>0))) and
(p^.retdef<>pdef(voiddef)) and
(token<>LKLAMMER) and
(not ((cs_tp_compatible in aktmoduleswitches) and
(afterassignment or in_args))) then
begin
p1:=genzeronode(funcretn);
pd:=p^.retdef;
p1^.funcretprocinfo:=p;
p1^.retdef:=pd;
is_func_ret:=true;
exit;
end;
p:=p^.parent;
end;
{ we must use the function call }
if(sym^.typ=funcretsym) then
begin
storesymtablestack:=symtablestack;
symtablestack:=srsymtable^.next;
getsym(sym^.name,true);
if srsym^.typ<>procsym then
Message(cg_e_illegal_expression);
symtablestack:=storesymtablestack;
end;
end;
{--------------------------------------------- {---------------------------------------------
Factor_read_id Factor_read_id
---------------------------------------------} ---------------------------------------------}
@ -683,10 +730,8 @@ unit pexpr;
consume(ID); consume(ID);
p1:=genzeronode(funcretn); p1:=genzeronode(funcretn);
pd:=procinfo.retdef; pd:=procinfo.retdef;
{$ifdef TEST_FUNCRET}
p1^.funcretprocinfo:=pointer(@procinfo); p1^.funcretprocinfo:=pointer(@procinfo);
p1^.retdef:=pd; p1^.retdef:=pd;
{$endif TEST_FUNCRET}
end end
else else
begin begin
@ -699,24 +744,7 @@ unit pexpr;
else else
getsym(pattern,true); getsym(pattern,true);
consume(ID); consume(ID);
{$ifndef TEST_FUNCRET}
{ is this an access to a function result ? }
if assigned(aktprocsym) and
((srsym^.name=aktprocsym^.name){ or
((pvarsym(srsym)=opsym) and
((procinfo.flags and pi_operator)<>0))}) and
(procinfo.retdef<>pdef(voiddef)) and
(token<>LKLAMMER) and
(not ((cs_tp_compatible in aktmoduleswitches) and
(afterassignment or in_args))) then
begin
p1:=genzeronode(funcretn);
pd:=procinfo.retdef;
end
else
{$else TEST_FUNCRET}
if not is_func_ret(srsym) then if not is_func_ret(srsym) then
{$endif TEST_FUNCRET}
{ else it's a normal symbol } { else it's a normal symbol }
begin begin
{ is it defined like UNIT.SYMBOL ? } { is it defined like UNIT.SYMBOL ? }
@ -1112,51 +1140,6 @@ unit pexpr;
end; end;
{$ifdef TEST_FUNCRET}
function is_func_ret(sym : psym) : boolean;
var
p : pprocinfo;
storesymtablestack : psymtable;
begin
is_func_ret:=false;
if (sym^.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0) then
exit;
p:=@procinfo;
while assigned(p) do
begin
{ is this an access to a function result ? }
if assigned(p^.funcretsym) and
((sym=p^.funcretsym) or
((pvarsym(sym)=opsym) and
((p^.flags and pi_operator)<>0))) and
(p^.retdef<>pdef(voiddef)) and
(token<>LKLAMMER) and
(not ((cs_tp_compatible in aktmoduleswitches) and
(afterassignment or in_args))) then
begin
p1:=genzeronode(funcretn);
pd:=p^.retdef;
p1^.funcretprocinfo:=p;
p1^.retdef:=pd;
is_func_ret:=true;
exit;
end;
p:=p^.parent;
end;
{ we must use the function call }
if(sym^.typ=funcretsym) then
begin
storesymtablestack:=symtablestack;
symtablestack:=srsymtable^.next;
getsym(sym^.name,true);
if srsym^.typ<>procsym then
Message(cg_e_illegal_expression);
symtablestack:=storesymtablestack;
end;
end;
{$endif TEST_FUNCRET}
{--------------------------------------------- {---------------------------------------------
PostFixOperators PostFixOperators
@ -1873,7 +1856,11 @@ unit pexpr;
end. end.
{ {
$Log$ $Log$
Revision 1.41 1998-08-20 21:36:39 peter Revision 1.42 1998-08-21 14:08:50 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.41 1998/08/20 21:36:39 peter
* fixed 'with object do' bug * fixed 'with object do' bug
Revision 1.40 1998/08/20 09:26:41 pierre Revision 1.40 1998/08/20 09:26:41 pierre

17
compiler/pstatmnt.pas
View File

@ -1083,13 +1083,10 @@ unit pstatmnt;
function block(islibrary : boolean) : ptree; function block(islibrary : boolean) : ptree;
{$ifdef TEST_FUNCRET }
var var
funcretsym : pfuncretsym; funcretsym : pfuncretsym;
{$endif TEST_FUNCRET }
begin begin
{$ifdef TEST_FUNCRET }
if procinfo.retdef<>pdef(voiddef) then if procinfo.retdef<>pdef(voiddef) then
begin begin
{ if the current is a function aktprocsym is non nil } { if the current is a function aktprocsym is non nil }
@ -1101,7 +1098,6 @@ unit pstatmnt;
procinfo.retoffset:=-funcretsym^.address; procinfo.retoffset:=-funcretsym^.address;
procinfo.funcretsym:=funcretsym; procinfo.funcretsym:=funcretsym;
end; end;
{$endif TEST_FUNCRET }
read_declarations(islibrary); read_declarations(islibrary);
{ temporary space is set, while the BEGIN of the procedure } { temporary space is set, while the BEGIN of the procedure }
@ -1126,15 +1122,8 @@ unit pstatmnt;
(psetdef(procinfo.retdef)^.settype=smallset) (psetdef(procinfo.retdef)^.settype=smallset)
) then } ) then }
begin begin
{$ifdef TEST_FUNCRET }
{ the space has been set in the local symtable } { the space has been set in the local symtable }
procinfo.retoffset:=-funcretsym^.address; procinfo.retoffset:=-funcretsym^.address;
{$else TEST_FUNCRET }
{ align func result at 4 byte }
procinfo.retoffset:=
-((-procinfo.firsttemp+(procinfo.retdef^.size+3)) div 4)*4;
procinfo.firsttemp:=procinfo.retoffset;
{$endif TEST_FUNCRET }
if (procinfo.flags and pi_operator)<>0 then if (procinfo.flags and pi_operator)<>0 then
{opsym^.address:=procinfo.call_offset; is wrong PM } {opsym^.address:=procinfo.call_offset; is wrong PM }
opsym^.address:=-procinfo.retoffset; opsym^.address:=-procinfo.retoffset;
@ -1238,7 +1227,11 @@ unit pstatmnt;
end. end.
{ {
$Log$ $Log$
Revision 1.36 1998-08-20 21:36:41 peter Revision 1.37 1998-08-21 14:08:52 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.36 1998/08/20 21:36:41 peter
* fixed 'with object do' bug * fixed 'with object do' bug
Revision 1.35 1998/08/20 09:26:42 pierre Revision 1.35 1998/08/20 09:26:42 pierre

8
compiler/symsym.inc
View File

@ -595,7 +595,6 @@
TFUNCRETSYM TFUNCRETSYM
****************************************************************************} ****************************************************************************}
{$ifdef TEST_FUNCRET}
constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo}); constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});
begin begin
@ -615,7 +614,6 @@
end; end;
{$endif GDB} {$endif GDB}
{$endif TEST_FUNCRET}
{**************************************************************************** {****************************************************************************
TABSOLUTESYM TABSOLUTESYM
@ -1554,7 +1552,11 @@
{ {
$Log$ $Log$
Revision 1.33 1998-08-20 12:53:27 peter Revision 1.34 1998-08-21 14:08:53 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.33 1998/08/20 12:53:27 peter
* object_options are always written for object syms * object_options are always written for object syms
Revision 1.32 1998/08/20 09:26:46 pierre Revision 1.32 1998/08/20 09:26:46 pierre

10
compiler/tree.pas
View File

@ -211,9 +211,7 @@ unit tree;
ordconstn : (value : longint); ordconstn : (value : longint);
realconstn : (valued : bestreal;labnumber : longint;realtyp : tait); realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint); fixconstn : (valuef: longint);
{$ifdef TEST_FUNCRET}
funcretn : (funcretprocinfo : pointer;retdef : pdef); funcretn : (funcretprocinfo : pointer;retdef : pdef);
{$endif TEST_FUNCRET}
subscriptn : (vs : pvarsym); subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean); vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); } { stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
@ -1385,9 +1383,7 @@ unit tree;
end; end;
(*realconstn : (valued : bestreal;labnumber : longint;realtyp : tait); (*realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint); fixconstn : (valuef: longint);
{$ifdef TEST_FUNCRET}
funcretn : (funcretprocinfo : pointer;retdef : pdef); funcretn : (funcretprocinfo : pointer;retdef : pdef);
{$endif TEST_FUNCRET}
subscriptn : (vs : pvarsym); subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean); vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); } { stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
@ -1557,7 +1553,11 @@ unit tree;
end. end.
{ {
$Log$ $Log$
Revision 1.30 1998-08-18 09:24:47 pierre Revision 1.31 1998-08-21 14:08:58 pierre
+ TEST_FUNCRET now default (old code removed)
works also for m68k (at least compiles)
Revision 1.30 1998/08/18 09:24:47 pierre
* small warning position bug fixed * small warning position bug fixed
* support_mmx switches splitting was missing * support_mmx switches splitting was missing
* rhide error and warning output corrected * rhide error and warning output corrected