paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 17:29:20 +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
{$ifdef i386}
{$ifndef NoAg386Att}
as_o : a:=new(pi386attasmlist,Init);
as_o,as_o_aout,as_asw : a:=new(pi386attasmlist,Init);
{$endif NoAg386Att}
{$ifndef NoAg386Nsm}
as_nasmcoff,
@ -437,7 +437,11 @@ end;
end.
{
$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
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);
var
hr : tregister;
{$ifdef TEST_FUNCRET}
hp : preference;
pp : pprocinfo;
hr_valid : boolean;
{$endif TEST_FUNCRET}
begin
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;
if @procinfo<>pprocinfo(p^.funcretprocinfo) then
begin
@ -549,11 +542,8 @@ implementation
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(p^.retdef) then
{$endif TEST_FUNCRET}
begin
{$ifdef TEST_FUNCRET}
if not hr_valid then
{$endif TEST_FUNCRET}
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr)));
p^.location.reference.base:=hr;
@ -565,7 +555,11 @@ implementation
end.
{
$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
compile with _dTEST_FUNCRET

48
compiler/cga68k.pas
View File

@ -1182,7 +1182,7 @@ end;
{ the following check is appropriate, because all }
{ 4 registers are rarely used and it is thereby }
{ achieved that the extra code is being dropped }
{ achieved that the extra code is being dropped }
{ by exchanging not commutative operators }
and (p^.right^.registers32<=4) then
begin
@ -1195,19 +1195,41 @@ end;
end;
procedure secondfuncret(var p : ptree);
var
hregister : tregister;
hr : tregister;
hp : preference;
pp : pprocinfo;
hr_valid : boolean;
begin
clear_reference(p^.location.reference);
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(procinfo.retdef) then
hr_valid:=false;
if @procinfo<>pprocinfo(p^.funcretprocinfo) then
begin
hregister:=getaddressreg;
exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,newreference(p^.location.reference),hregister)));
p^.location.reference.base:=hregister;
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.offset:=procinfo.retoffset;
if ret_in_param(p^.retdef) then
begin
if not hr_valid then
hr:=getaddressreg;
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;
end;
end;
@ -1215,7 +1237,11 @@ end;
end.
{
$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
Revision 1.8 1998/08/10 14:43:16 peter

8
compiler/hcodegen.pas
View File

@ -54,10 +54,8 @@ unit hcodegen;
retdef : pdef;
{ return type }
sym : pprocsym;
{$ifdef TEST_FUNCRET }
{ symbol of the function }
funcretsym : pfuncretsym;
{$endif TEST_FUNCRET }
{ the definition of the proc itself }
{ why was this a pdef only ?? PM }
def : pprocdef;
@ -409,7 +407,11 @@ end.
{
$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
compile with _dTEST_FUNCRET

20
compiler/m68k.pas
View File

@ -359,6 +359,8 @@ type
function newreference(const r : treference) : preference;
function new_reference(base : tregister;offset : longint) : preference;
function reg2str(r : tregister) : string;
{ generates an help record for constants }
@ -897,6 +899,18 @@ type
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);
begin
@ -1565,7 +1579,11 @@ type
end.
{
$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
+ .def file creation moved to gendef.pas so it could also be used
for win32

13
compiler/makefile
View File

@ -196,6 +196,7 @@ COMPILER=$(PP) $(PPOPTS)
PPEXENAME=pp$(EXEEXT)
EXENAME=ppc386$(EXEEXT)
M68KEXENAME=ppc68k$(EXEEXT)
TEMPNAME=ppc$(EXEEXT)
TEMPNAME1=ppc1$(EXEEXT)
TEMPNAME2=ppc2$(EXEEXT)
@ -441,10 +442,20 @@ rtl :
rtlclean :
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
# does CVS add # at start of each line ??
# $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
# * support_mmx switches splitting was missing
# * rhide error and warning output corrected

20
compiler/pass_1.pas
View File

@ -585,7 +585,6 @@ unit pass_1;
p^.registersmmx:=0;
{$endif SUPPORT_MMX}
clear_reference(p^.location.reference);
{$ifdef TEST_FUNCRET}
if p^.symtableentry^.typ=funcretsym then
begin
putnode(p);
@ -595,7 +594,6 @@ unit pass_1;
firstpass(p);
exit;
end;
{$endif TEST_FUNCRET}
if p^.symtableentry^.typ=absolutesym then
begin
p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition;
@ -3619,7 +3617,6 @@ unit pass_1;
procedure firstfuncret(var p : ptree);
begin
{$ifdef TEST_FUNCRET}
p^.resulttype:=p^.retdef;
p^.location.loc:=LOC_REFERENCE;
if ret_in_param(p^.retdef) or
@ -3632,17 +3629,6 @@ unit pass_1;
Message(sym_w_function_result_not_set);
if count_ref then
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;
@ -5248,7 +5234,11 @@ unit pass_1;
end.
{
$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_*
Revision 1.59 1998/08/20 09:26:39 pierre

117
compiler/pexpr.pas
View File

@ -667,6 +667,53 @@ unit pexpr;
propsym : ppropertysym;
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
---------------------------------------------}
@ -683,10 +730,8 @@ unit pexpr;
consume(ID);
p1:=genzeronode(funcretn);
pd:=procinfo.retdef;
{$ifdef TEST_FUNCRET}
p1^.funcretprocinfo:=pointer(@procinfo);
p1^.retdef:=pd;
{$endif TEST_FUNCRET}
end
else
begin
@ -699,24 +744,7 @@ unit pexpr;
else
getsym(pattern,true);
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
{$endif TEST_FUNCRET}
{ else it's a normal symbol }
begin
{ is it defined like UNIT.SYMBOL ? }
@ -1112,51 +1140,6 @@ unit pexpr;
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
@ -1873,7 +1856,11 @@ unit pexpr;
end.
{
$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
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;
{$ifdef TEST_FUNCRET }
var
funcretsym : pfuncretsym;
{$endif TEST_FUNCRET }
begin
{$ifdef TEST_FUNCRET }
if procinfo.retdef<>pdef(voiddef) then
begin
{ if the current is a function aktprocsym is non nil }
@ -1101,7 +1098,6 @@ unit pstatmnt;
procinfo.retoffset:=-funcretsym^.address;
procinfo.funcretsym:=funcretsym;
end;
{$endif TEST_FUNCRET }
read_declarations(islibrary);
{ temporary space is set, while the BEGIN of the procedure }
@ -1126,15 +1122,8 @@ unit pstatmnt;
(psetdef(procinfo.retdef)^.settype=smallset)
) then }
begin
{$ifdef TEST_FUNCRET }
{ the space has been set in the local symtable }
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
{opsym^.address:=procinfo.call_offset; is wrong PM }
opsym^.address:=-procinfo.retoffset;
@ -1238,7 +1227,11 @@ unit pstatmnt;
end.
{
$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
Revision 1.35 1998/08/20 09:26:42 pierre

8
compiler/symsym.inc
View File

@ -595,7 +595,6 @@
TFUNCRETSYM
****************************************************************************}
{$ifdef TEST_FUNCRET}
constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});
begin
@ -615,7 +614,6 @@
end;
{$endif GDB}
{$endif TEST_FUNCRET}
{****************************************************************************
TABSOLUTESYM
@ -1554,7 +1552,11 @@
{
$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
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);
realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint);
{$ifdef TEST_FUNCRET}
funcretn : (funcretprocinfo : pointer;retdef : pdef);
{$endif TEST_FUNCRET}
subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
@ -1385,9 +1383,7 @@ unit tree;
end;
(*realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint);
{$ifdef TEST_FUNCRET}
funcretn : (funcretprocinfo : pointer;retdef : pdef);
{$endif TEST_FUNCRET}
subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
@ -1557,7 +1553,11 @@ unit tree;
end.
{
$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
* support_mmx switches splitting was missing
* rhide error and warning output corrected