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

* merged

Browse Source
This commit is contained in:
peter 1999-06-15 18:58:33 +00:00
parent 7a22facf6d
commit c36ae78617
3 changed files with 236 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
compiler/pexpr.pas
View File

@ -109,6 +109,29 @@ unit pexpr;
end;
procedure check_tp_procvar(var p : ptree);
var
p1 : ptree;
begin
if (m_tp_procvar in aktmodeswitches) and
{ (not afterassignment) and }
(not in_args) and
(p^.treetype in [loadn]) then
begin
{ support if procvar then for tp7 and many other expression like this }
firstpass(p);
if p^.resulttype^.deftype=procvardef then
begin
p1:=gencallnode(nil,nil);
p1^.right:=p;
p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
firstpass(p1);
p:=p1;
end;
end;
end;
function statement_syssym(l : longint;var pd : pdef) : ptree;
var
p1,p2,paras : ptree;
@ -539,21 +562,14 @@ unit pexpr;
var
hp : ptree;
begin
hp:=nil;
if ((procvar^.options and pomethodpointer)<>0) then
begin
if assigned(t^.methodpointer) and
(t^.methodpointer^.resulttype^.deftype=objectdef) and
(pobjectdef(t^.methodpointer^.resulttype)^.isclass) and
(proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
else
Message(type_e_mismatch);
end
else if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,getprocvardef)) then
begin
hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
end;
hp:=nil;
if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
begin
if ((procvar^.options and pomethodpointer)<>0) then
hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
else
hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
end;
if assigned(hp) then
begin
disposetree(t);
@ -606,10 +622,16 @@ unit pexpr;
{ read the expression }
getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
p2:=comp_expr(true);
if (p2^.treetype<>errorn) and getprocvar then
handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2);
if getprocvar then
begin
if (p2^.treetype=calln) then
handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2)
else
if (p2^.treetype=typeconvn) and
(p2^.left^.treetype=calln) then
handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2^.left);
end;
p1^.left:=gencallparanode(p2,p1^.left);
{ firstcallparan(p1^.left,nil); }
getprocvar:=false;
end
else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
@ -1763,6 +1785,9 @@ unit pexpr;
{ generate error node if no node is created }
if not assigned(p1) then
p1:=genzeronode(errorn);
{ tp7 procvar handling }
if (m_tp_procvar in aktmodeswitches) then
check_tp_procvar(p1);
factor:=p1;
check_tokenpos;
end;
@ -1858,27 +1883,6 @@ unit pexpr;
sub_expr:=p1;
end;
procedure check_tp_procvar(var p : ptree);
var
p1 : ptree;
begin
if (m_tp_procvar in aktmodeswitches) and
(not afterassignment) and
(not in_args) and (p^.treetype=loadn) then
begin
{ support if procvar then for tp7 and many other expression like this }
firstpass(p);
if p^.resulttype^.deftype=procvardef then
begin
p1:=gencallnode(nil,nil);
p1^.right:=p;
p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
firstpass(p1);
p:=p1;
end;
end;
end;
function comp_expr(accept_equal : boolean):Ptree;
var
@ -1889,8 +1893,6 @@ unit pexpr;
afterassignment:=true;
p1:=sub_expr(opcompare,accept_equal);
afterassignment:=oldafterassignment;
if (m_tp_procvar in aktmodeswitches) then
check_tp_procvar(p1);
comp_expr:=p1;
end;
@ -1929,12 +1931,16 @@ unit pexpr;
getprocvardef:=pprocvardef(p1^.resulttype);
end;
p2:=sub_expr(opcompare,true);
if getprocvar and (p2^.treetype=calln) then
handle_procvar(getprocvardef,p2);
{ also allow p:= proc(t); !! (PM) }
if getprocvar and (p2^.treetype=typeconvn) and
(p2^.left^.treetype=calln) then
handle_procvar(getprocvardef,p2^.left);
if getprocvar then
begin
if (p2^.treetype=calln) then
handle_procvar(getprocvardef,p2)
else
{ also allow p:= proc(t); !! (PM) }
if (p2^.treetype=typeconvn) and
(p2^.left^.treetype=calln) then
handle_procvar(getprocvardef,p2^.left);
end;
getprocvar:=false;
p1:=gennode(assignn,p1,p2);
end;
@ -2018,9 +2024,15 @@ unit pexpr;
end.
{
$Log$
Revision 1.113 1999-06-13 22:41:05 peter
Revision 1.114 1999-06-15 18:58:33 peter
* merged
Revision 1.113 1999/06/13 22:41:05 peter
* merged from fixes
Revision 1.112.2.2 1999/06/15 18:54:52 peter
* more procvar fixes
Revision 1.112.2.1 1999/06/13 22:38:09 peter
* tp_procvar check for loading of procvars when getaddr=false

329
compiler/tccnv.pas
View File

@ -643,182 +643,181 @@ implementation
own resulttype. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we
use an extra check for them.}
if (p^.resulttype^.deftype=procvardef) and
((m_tp_procvar in aktmodeswitches) or
{ method pointer use always the TP syntax }
((pprocvardef(p^.resulttype)^.options and pomethodpointer)<>0)
) and
((is_procsym_load(p^.left) or is_procsym_call(p^.left))) then
begin
if is_procsym_call(p^.left) then
if (m_tp_procvar in aktmodeswitches) then
begin
if (p^.resulttype^.deftype=procvardef) and
(is_procsym_load(p^.left) or is_procsym_call(p^.left)) then
begin
if is_procsym_call(p^.left) then
begin
if p^.left^.right=nil then
begin
p^.left^.treetype:=loadn;
{ are at same offset so this could be spared, but
it more secure to do it anyway }
p^.left^.symtableentry:=p^.left^.symtableprocentry;
p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
aprocdef:=pprocdef(p^.left^.resulttype);
end
else
begin
p^.left^.right^.treetype:=loadn;
p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
hp:=p^.left^.right;
putnode(p^.left);
p^.left:=hp;
{ should we do that ? }
firstpass(p^.left);
if not is_equal(p^.left^.resulttype,p^.resulttype) then
begin
CGMessage(type_e_mismatch);
exit;
end
else
begin
hp:=p;
p:=p^.left;
p^.resulttype:=hp^.resulttype;
putnode(hp);
exit;
end;
end;
if p^.left^.right=nil then
begin
p^.left^.treetype:=loadn;
{ are at same offset so this could be spared, but
it more secure to do it anyway }
p^.left^.symtableentry:=p^.left^.symtableprocentry;
p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
aprocdef:=pprocdef(p^.left^.resulttype);
end
else
begin
p^.left^.right^.treetype:=loadn;
p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
hp:=p^.left^.right;
putnode(p^.left);
p^.left:=hp;
{ should we do that ? }
firstpass(p^.left);
if not is_equal(p^.left^.resulttype,p^.resulttype) then
begin
CGMessage(type_e_mismatch);
exit;
end
else
begin
hp:=p;
p:=p^.left;
p^.resulttype:=hp^.resulttype;
putnode(hp);
exit;
end;
end;
end
else
else
begin
if (p^.left^.treetype<>addrn) then
aprocdef:=pprocsym(p^.left^.symtableentry)^.definition;
end;
p^.convtyp:=tc_proc_2_procvar;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if assigned(aprocdef) then
p^.convtyp:=tc_proc_2_procvar;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if assigned(aprocdef) then
begin
if proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then
if not proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then
CGMessage2(type_e_incompatible_types,aprocdef^.typename,p^.resulttype^.typename);
firstconvert[p^.convtyp](p);
end
else
else
CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
exit;
end
else
begin
if p^.explizit then
exit;
end;
end;
if p^.explizit then
begin
{ boolean to byte are special because the
location can be different }
if is_integer(p^.resulttype) and
is_boolean(p^.left^.resulttype) then
begin
p^.convtyp:=tc_bool_2_int;
firstconvert[p^.convtyp](p);
exit;
end;
{ ansistring to pchar }
if is_pchar(p^.resulttype) and
is_ansistring(p^.left^.resulttype) then
begin
p^.convtyp:=tc_ansistring_2_pchar;
firstconvert[p^.convtyp](p);
exit;
end;
{ do common tc_equal cast }
p^.convtyp:=tc_equal;
{ enum to ordinal will always be s32bit }
if (p^.left^.resulttype^.deftype=enumdef) and
is_ordinal(p^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
{ boolean to byte are special because the
location can be different }
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
else
begin
if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
if is_integer(p^.resulttype) and
is_boolean(p^.left^.resulttype) then
begin
p^.convtyp:=tc_bool_2_int;
firstconvert[p^.convtyp](p);
exit;
end;
if is_pchar(p^.resulttype) and
is_ansistring(p^.left^.resulttype) then
begin
p^.convtyp:=tc_ansistring_2_pchar;
firstconvert[p^.convtyp](p);
exit;
end;
{ do common tc_equal cast }
p^.convtyp:=tc_equal;
{ wenn Aufz„hltyp nach Ordinal konvertiert werden soll }
{ dann Aufz„hltyp=s32bit }
if (p^.left^.resulttype^.deftype=enumdef) and
is_ordinal(p^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
else
begin
if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
{ ordinal to enumeration }
else
if (p^.resulttype^.deftype=enumdef) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
else
begin
if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
{Are we typecasting an ordconst to a char?}
else
if is_char(p^.resulttype) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
firstpass(hp);
disposetree(p);
p:=hp;
exit;
end
else
begin
{ this is wrong because it converts to a 4 byte long var !!
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then }
if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
{ only if the same size or formal def }
{ why do we allow typecasting of voiddef ?? (PM) }
else
begin
if not(
(p^.left^.resulttype^.deftype=formaldef) or
(p^.left^.resulttype^.size=p^.resulttype^.size) or
(is_equal(p^.left^.resulttype,voiddef) and
(p^.left^.treetype=derefn))
) then
CGMessage(cg_e_illegal_type_conversion);
if ((p^.left^.resulttype^.deftype=orddef) and
(p^.resulttype^.deftype=pointerdef)) or
((p^.resulttype^.deftype=orddef) and
(p^.left^.resulttype^.deftype=pointerdef))
{$ifdef extdebug}and (p^.firstpasscount=0){$endif} then
CGMessage(cg_d_pointer_to_longint_conv_not_portable);
end;
{ the conversion into a strutured type is only }
{ possible, if the source is no register }
if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or
((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.isclass))
) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
{it also works if the assignment is overloaded }
not is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
CGMessage(cg_e_illegal_type_conversion);
end
{ ordinal to enumeration }
else
CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
end
if (p^.resulttype^.deftype=enumdef) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
else
begin
if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
{Are we typecasting an ordconst to a char?}
else
if is_char(p^.resulttype) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
firstpass(hp);
disposetree(p);
p:=hp;
exit;
end
else
begin
{ this is wrong because it converts to a 4 byte long var !!
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then }
if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then
CGMessage(cg_e_illegal_type_conversion);
end;
end
{ only if the same size or formal def }
{ why do we allow typecasting of voiddef ?? (PM) }
else
begin
if not(
(p^.left^.resulttype^.deftype=formaldef) or
(p^.left^.resulttype^.size=p^.resulttype^.size) or
(is_equal(p^.left^.resulttype,voiddef) and
(p^.left^.treetype=derefn))
) then
CGMessage(cg_e_illegal_type_conversion);
if ((p^.left^.resulttype^.deftype=orddef) and
(p^.resulttype^.deftype=pointerdef)) or
((p^.resulttype^.deftype=orddef) and
(p^.left^.resulttype^.deftype=pointerdef))
{$ifdef extdebug}and (p^.firstpasscount=0){$endif} then
CGMessage(cg_d_pointer_to_longint_conv_not_portable);
end;
{ the conversion into a strutured type is only }
{ possible, if the source is no register }
if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or
((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.isclass))
) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
{it also works if the assignment is overloaded }
not is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
CGMessage(cg_e_illegal_type_conversion);
end
else
CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename);
end;
{ ordinal contants can be directly converted }
if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then
begin
@ -913,9 +912,15 @@ implementation
end.
{
$Log$
Revision 1.36 1999-06-13 22:41:06 peter
Revision 1.37 1999-06-15 18:58:35 peter
* merged
Revision 1.36 1999/06/13 22:41:06 peter
* merged from fixes
Revision 1.35.2.2 1999/06/15 18:54:53 peter
* more procvar fixes
Revision 1.35.2.1 1999/06/13 22:39:19 peter
* use proc_to_procvar_equal

12
compiler/tcinl.pas
View File

@ -612,8 +612,8 @@ implementation
if assigned(hp^.left^.resulttype) then
begin
isreal:=false;
{ support writeln(procvar) for tp7 }
if (m_tp_procvar in aktmodeswitches) and (hp^.left^.resulttype^.deftype=procvardef) then
{ support writeln(procvar) }
if (hp^.left^.resulttype^.deftype=procvardef) then
begin
p1:=gencallnode(nil,nil);
p1^.right:=hp^.left;
@ -1101,7 +1101,13 @@ implementation
end.
{
$Log$
Revision 1.35 1999-05-27 19:45:19 peter
Revision 1.36 1999-06-15 18:58:36 peter
* merged
Revision 1.35.2.1 1999/06/15 18:54:54 peter
* more procvar fixes
Revision 1.35 1999/05/27 19:45:19 peter
* removed oldasm
* plabel -> pasmlabel
* -a switches to source writing automaticly