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

* merged methodpointer fixes from 1.0.x

Browse Source
This commit is contained in:
peter 2003-01-15 01:44:32 +00:00
parent 14bfc9eeba
commit 00e2ee165b
6 changed files with 89 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
compiler/defcmp.pas
View File

@ -107,7 +107,7 @@ interface
{ True if a function can be assigned to a procvar }
{ changed first argument type to pabstractprocdef so that it can also be }
{ used to test compatibility between two pprocvardefs (JM) }
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype;
implementation
@ -765,7 +765,7 @@ implementation
{ proc -> procvar }
if (m_tp_procvar in aktmodeswitches) then
begin
subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to));
subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),true);
if subeq>te_incompatible then
begin
doconv:=tc_proc_2_procvar;
@ -776,7 +776,7 @@ implementation
procvardef :
begin
{ procvar -> procvar }
eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to));
eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),true);
end;
pointerdef :
begin
@ -1127,9 +1127,8 @@ implementation
end;
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype;
var
ismethod : boolean;
eq : tequaltype;
po_comp : tprocoptions;
begin
@ -1137,19 +1136,11 @@ implementation
if not(assigned(def1)) or not(assigned(def2)) then
exit;
{ check for method pointer }
if def1.deftype=procvardef then
if (def1.is_methodpointer xor def2.is_methodpointer) or
(def1.is_addressonly xor def2.is_addressonly) then
begin
ismethod:=(po_methodpointer in def1.procoptions);
end
else
begin
ismethod:=assigned(def1.owner) and
(def1.owner.symtabletype=objectsymtable);
end;
if (ismethod and not (po_methodpointer in def2.procoptions)) or
(not(ismethod) and (po_methodpointer in def2.procoptions)) then
begin
Message(type_e_no_method_and_procedure_not_compatible);
if methoderr then
Message(type_e_no_method_and_procedure_not_compatible);
exit;
end;
{ check return value and options, methodpointer is already checked }
@ -1188,7 +1179,10 @@ implementation
end.
{
$Log$
Revision 1.17 2003-01-09 21:43:39 peter
Revision 1.18 2003-01-15 01:44:32 peter
* merged methodpointer fixes from 1.0.x
Revision 1.17 2003/01/09 21:43:39 peter
* constant string conversion fixed, it's now equal to both
shortstring, ansistring and the typeconvnode will return
te_equal but still return convtype to change the constnode

7
compiler/ncal.pas
View File

@ -431,7 +431,7 @@ type
{ in tp7 mode proc -> procvar is allowed }
if (m_tp_procvar in aktmodeswitches) and
(p.left.nodetype=calln) and
(proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to))>=te_equal) then
(proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),true)>=te_equal) then
eq:=te_equal;
end;
end;
@ -2375,7 +2375,10 @@ begin
end.
{
$Log$
Revision 1.125 2003-01-12 17:52:07 peter
Revision 1.126 2003-01-15 01:44:32 peter
* merged methodpointer fixes from 1.0.x
Revision 1.125 2003/01/12 17:52:07 peter
* only check for auto inherited in objectsymtable
Revision 1.124 2003/01/09 21:45:46 peter

9
compiler/ncnv.pas
View File

@ -1102,7 +1102,7 @@ implementation
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if proc_to_procvar_equal(tprocsym(tloadnode(left).symtableentry).first_procdef,
tprocvardef(resulttype.def))=te_incompatible then
tprocvardef(resulttype.def),true)=te_incompatible then
CGMessage2(type_e_incompatible_types,tprocsym(tloadnode(left).symtableentry).first_procdef.typename,resulttype.def.typename);
exit;
end;
@ -1129,7 +1129,7 @@ implementation
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if proc_to_procvar_equal(tprocdef(left.resulttype.def),
tprocvardef(resulttype.def))=te_incompatible then
tprocvardef(resulttype.def),true)=te_incompatible then
CGMessage2(type_e_incompatible_types,tprocdef(left.resulttype.def).typename,resulttype.def.typename);
exit;
end;
@ -2024,7 +2024,10 @@ begin
end.
{
$Log$
Revision 1.99 2003-01-09 21:43:39 peter
Revision 1.100 2003-01-15 01:44:32 peter
* merged methodpointer fixes from 1.0.x
Revision 1.99 2003/01/09 21:43:39 peter
* constant string conversion fixed, it's now equal to both
shortstring, ansistring and the typeconvnode will return
te_equal but still return convtype to change the constnode

4
compiler/pexpr.pas
View File

@ -2320,8 +2320,8 @@ implementation
end.
{
$Log$
Revision 1.99 2003-01-14 23:48:09 peter
* fixed tw2273
Revision 1.100 2003-01-15 01:44:32 peter
* merged methodpointer fixes from 1.0.x
Revision 1.98 2003/01/12 17:51:42 peter
* tp procvar handling fix for tb0448

67
compiler/symdef.pas
View File

@ -437,6 +437,8 @@ interface
function para_size(alignsize:longint) : longint;
function typename_paras : string;
procedure test_if_fpu_result;
function is_methodpointer:boolean;virtual;
function is_addressonly:boolean;virtual;
{ debug }
{$ifdef GDB}
function stabstring : pchar;override;
@ -449,8 +451,10 @@ interface
constructor ppuload(ppufile:tcompilerppufile);
procedure ppuwrite(ppufile:tcompilerppufile);override;
function size : longint;override;
function gettypename:string;override;
function is_publishable : boolean;override;
function gettypename:string;override;
function is_publishable : boolean;override;
function is_methodpointer:boolean;override;
function is_addressonly:boolean;override;
{ debug }
{$ifdef GDB}
function stabstring : pchar;override;
@ -534,8 +538,10 @@ interface
}
procedure insert_localst;
function fullprocname:string;
function fullprocnamewithret:string;
function fullprocnamewithret:string;
function cplusplusmangledname : string;
function is_methodpointer:boolean;override;
function is_addressonly:boolean;override;
{ debug }
{$ifdef GDB}
function stabstring : pchar;override;
@ -903,6 +909,7 @@ implementation
function tstoreddef.getcopy : tstoreddef;
begin
Message(sym_e_cant_create_unique_type);
getcopy:=nil;
end;
procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
@ -3313,6 +3320,18 @@ implementation
end;
function tabstractprocdef.is_methodpointer:boolean;
begin
result:=false;
end;
function tabstractprocdef.is_addressonly:boolean;
begin
result:=true;
end;
{$ifdef GDB}
function tabstractprocdef.stabstring : pchar;
begin
@ -3594,6 +3613,19 @@ implementation
end;
function tprocdef.is_methodpointer:boolean;
begin
result:=assigned(owner) and
(owner.symtabletype=objectsymtable);
end;
function tprocdef.is_addressonly:boolean;
begin
result:=true;
end;
function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
begin
case t of
@ -4020,6 +4052,19 @@ implementation
end;
function tprocvardef.is_methodpointer:boolean;
begin
result:=(po_methodpointer in procoptions);
end;
function tprocvardef.is_addressonly:boolean;
begin
result:=not(po_methodpointer in procoptions) or
(po_addressonly in procoptions);
end;
{$ifdef GDB}
function tprocvardef.stabstring : pchar;
var
@ -4134,14 +4179,17 @@ implementation
begin
s:='<';
if po_classmethod in procoptions then
s := s+'class method'
s := s+'class method type of'
else
s := s+'procedure variable';
if po_addressonly in procoptions then
s := s+'address of'
else
s := s+'procedure variable type of';
if assigned(rettype.def) and
(rettype.def<>voidtype.def) then
s:=s+' type of function'+typename_paras+':'+rettype.def.gettypename
s:=s+' function'+typename_paras+':'+rettype.def.gettypename
else
s:=s+' type of procedure'+typename_paras;
s:=s+' procedure'+typename_paras;
if po_methodpointer in procoptions then
s := s+' of object';
gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
@ -5599,7 +5647,10 @@ implementation
end.
{
$Log$
Revision 1.124 2003-01-09 21:52:37 peter
Revision 1.125 2003-01-15 01:44:33 peter
* merged methodpointer fixes from 1.0.x
Revision 1.124 2003/01/09 21:52:37 peter
* merged some verbosity options.
* V_LineInfo is a verbosity flag to include line info

7
compiler/symsym.pas
View File

@ -1062,7 +1062,7 @@ implementation
pd:=pdlistfirst;
while assigned(pd) do
begin
eq:=proc_to_procvar_equal(pd^.def,d);
eq:=proc_to_procvar_equal(pd^.def,d,false);
if eq>=te_equal then
begin
{ multiple procvars with the same equal level }
@ -2563,7 +2563,10 @@ implementation
end.
{
$Log$
Revision 1.92 2003-01-09 21:52:38 peter
Revision 1.93 2003-01-15 01:44:33 peter
* merged methodpointer fixes from 1.0.x
Revision 1.92 2003/01/09 21:52:38 peter
* merged some verbosity options.
* V_LineInfo is a verbosity flag to include line info