paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-04 04:17:53 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ support for "univ" in macpas mode: a parameter modifier that allows

Browse Source 
passing any value to that parameter which has the same size as the
    parameter (it basically acts as if there is an explicit type conversion
    to the parameter type around the value at the caller side). If a procvar
    has an univ parameter, all procvars whose corresponding parameter
    has the same size as that univ parameter are similarly compatible.

    This transparent compatibility can however cause crashes in case of
    of the procvars when one of the types is passed on the stack and the
    other isn't (because then the called routine will a) load the parameter
    from a wrong location and b) pop the wrong amount off of the stack at
    then end). Therefore FPC will warn in most cases where this can happen.
    (mantis #15777)

git-svn-id: trunk@15010 -
This commit is contained in:
Jonas Maebe 2010-03-13 22:13:20 +00:00
parent f39e9ba873
commit 0cfc6e1cac
18 changed files with 1018 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -9641,6 +9641,7 @@ tests/webtbf/tw15447.pp svneol=native#text/plain
tests/webtbf/tw15594a.pp svneol=native#text/plain
tests/webtbf/tw15594b.pp svneol=native#text/plain
tests/webtbf/tw15727b.pp svneol=native#text/plain
tests/webtbf/tw15777b.pp svneol=native#text/plain
tests/webtbf/tw1599.pp svneol=native#text/plain
tests/webtbf/tw1599b.pp svneol=native#text/plain
tests/webtbf/tw1633.pp svneol=native#text/plain
@ -10303,6 +10304,9 @@ tests/webtbs/tw15694.pp svneol=native#text/plain
tests/webtbs/tw15727a.pp svneol=native#text/plain
tests/webtbs/tw15728.pp svneol=native#text/plain
tests/webtbs/tw1573.pp svneol=native#text/plain
tests/webtbs/tw15777a.pp svneol=native#text/plain
tests/webtbs/tw15777c.pp svneol=native#text/plain
tests/webtbs/tw15777d.pp svneol=native#text/plain
tests/webtbs/tw15812.pp svneol=native#text/plain
tests/webtbs/tw1592.pp svneol=native#text/plain
tests/webtbs/tw1617.pp svneol=native#text/plain

94
compiler/defcmp.pas
View File

@ -34,10 +34,10 @@ interface
type
{ if acp is cp_all the var const or nothing are considered equal }
tcompare_paras_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar);
tcompare_paras_option = (cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert,cpo_comparedefaultvalue,cpo_openequalisexact);
tcompare_paras_option = (cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert,cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv,cpo_warn_incompatible_univ);
tcompare_paras_options = set of tcompare_paras_option;
tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant,cdo_parameter);
tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant,cdo_parameter,cdo_warn_incompatible_univ);
tcompare_defs_options = set of tcompare_defs_option;
tconverttype = (tc_none,
@ -100,10 +100,13 @@ interface
function is_subequal(def1, def2: tdef): boolean;
{# true, if two parameter lists are equal
if acp is cp_none, all have to match exactly
if acp is cp_all, all have to match exactly
if acp is cp_value_equal_const call by value
and call by const parameter are assumed as
equal
if acp is cp_procvar then the varspez have to match,
and all parameter types must be at least te_equal
if acp is cp_none, then we don't check the varspez at all
allowdefaults indicates if default value parameters
are allowed (in this case, the search order will first
search for a routine with default parameters, before
@ -114,7 +117,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;checkincompatibleuniv: boolean):tequaltype;
{ Parentdef is the definition of a method defined in a parent class or interface }
{ Childdef is the definition of a method defined in a child class, interface or }
@ -1186,7 +1189,7 @@ implementation
if (m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches) then
begin
subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to));
subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
if subeq>te_incompatible then
begin
doconv:=tc_proc_2_procvar;
@ -1197,7 +1200,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),cdo_warn_incompatible_univ in cdoptions);
end;
pointerdef :
begin
@ -1533,6 +1536,39 @@ implementation
end;
function potentially_incompatible_univ_paras(def1, def2: tdef): boolean;
begin
result :=
{ not entirely safe: different records can be passed differently
depending on the types of their fields, but they're hard to compare
(variant records, bitpacked vs non-bitpacked) }
((def1.typ in [floatdef,recorddef,arraydef,filedef,variantdef]) and
(def1.typ<>def2.typ)) or
{ pointers, ordinals and small sets are all passed the same}
(((def1.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
(is_class_or_interface_or_objc(def1)) or
is_dynamic_array(def1) or
is_smallset(def1) or
is_ansistring(def1) or
is_unicodestring(def1)) <>
(def2.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
(is_class_or_interface_or_objc(def2)) or
is_dynamic_array(def2) or
is_smallset(def2) or
is_ansistring(def2) or
is_unicodestring(def2)) or
{ shortstrings }
(is_shortstring(def1)<>
is_shortstring(def2)) or
{ winlike widestrings }
(is_widestring(def1)<>
is_widestring(def2)) or
{ TP-style objects }
(is_object(def1) <>
is_object(def2));
end;
function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
var
currpara1,
@ -1594,6 +1630,10 @@ implementation
case acp of
cp_value_equal_const :
begin
{ this one is used for matching parameters from a call
statement to a procdef -> univ state can't be equal
in any case since the call statement does not contain
any information about that }
if (
(currpara1.varspez<>currpara2.varspez) and
((currpara1.varspez in [vs_var,vs_out]) or
@ -1605,7 +1645,10 @@ implementation
end;
cp_all :
begin
if (currpara1.varspez<>currpara2.varspez) then
{ used to resolve forward definitions -> headers must
match exactly, including the "univ" specifier }
if (currpara1.varspez<>currpara2.varspez) or
(currpara1.univpara<>currpara2.univpara) then
exit;
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
convtype,hpd,cdoptions);
@ -1614,6 +1657,10 @@ implementation
begin
if (currpara1.varspez<>currpara2.varspez) then
exit;
{ "univ" state doesn't matter here: from univ to non-univ
matches if the types are compatible (i.e., as usual),
from from non-univ to univ also matches if the types
have the same size (checked below) }
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
convtype,hpd,cdoptions);
{ Parameters must be at least equal otherwise the are incompatible }
@ -1627,7 +1674,30 @@ implementation
end;
{ check type }
if eq=te_incompatible then
exit;
begin
{ special case: "univ" parameters match if their size is equal }
if not(cpo_ignoreuniv in cpoptions) and
currpara2.univpara and
is_valid_univ_para_type(currpara1.vardef) and
(currpara1.vardef.size=currpara2.vardef.size) then
begin
{ only pick as last choice }
eq:=te_convert_l5;
if (acp=cp_procvar) and
(cpo_warn_incompatible_univ in cpoptions) then
begin
{ if the types may be passed in different ways by the
calling convention then this can lead to crashes
(note: not an exhaustive check, and failing this
this check does not mean things will crash on all
platforms) }
if potentially_incompatible_univ_paras(currpara1.vardef,currpara2.vardef) then
Message2(type_w_procvar_univ_conflicting_para,currpara1.vardef.typename,currpara2.vardef.typename)
end;
end
else
exit;
end;
{ open strings can never match exactly, since you cannot define }
{ a separate "open string" type -> we have to be able to }
{ consider those as exact when resolving forward definitions. }
@ -1676,10 +1746,11 @@ implementation
end;
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef; checkincompatibleuniv: boolean):tequaltype;
var
eq : tequaltype;
po_comp : tprocoptions;
pa_comp: tcompare_paras_options;
begin
proc_to_procvar_equal:=te_incompatible;
if not(assigned(def1)) or not(assigned(def2)) then
@ -1688,6 +1759,9 @@ implementation
if (def1.is_methodpointer xor def2.is_methodpointer) or
(def1.is_addressonly xor def2.is_addressonly) then
exit;
pa_comp:=[];
if checkincompatibleuniv then
include(pa_comp,cpo_warn_incompatible_univ);
{ check return value and options, methodpointer is already checked }
po_comp:=[po_staticmethod,po_interrupt,
po_iocheck,po_varargs];
@ -1700,7 +1774,7 @@ implementation
{ return equal type based on the parameters, but a proc->procvar
is never exact, so map an exact match of the parameters to
te_equal }
eq:=compare_paras(def1.paras,def2.paras,cp_procvar,[]);
eq:=compare_paras(def1.paras,def2.paras,cp_procvar,pa_comp);
if eq=te_exact then
eq:=te_equal;
proc_to_procvar_equal:=eq;

13
compiler/defutil.pas
View File

@ -254,6 +254,10 @@ interface
signdness, the result will also get that signdness }
function get_common_intdef(ld, rd: torddef; keep_sign_if_equal: boolean): torddef;
{ # returns whether the type is potentially a valid type of/for an "univ" parameter
(basically: it must have a compile-time size) }
function is_valid_univ_para_type(def: tdef): boolean;
implementation
uses
@ -1107,4 +1111,13 @@ implementation
end;
end;
function is_valid_univ_para_type(def: tdef): boolean;
begin
result:=
not is_open_array(def) and
not is_void(def) and
(def.typ<>formaldef);
end;
end.

15
compiler/htypechk.pas
View File

@ -1590,7 +1590,7 @@ implementation
if ((m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches)) 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),false)>=te_equal) then
eq:=te_equal
else
if (m_mac_procvar in current_settings.modeswitches) and
@ -1615,7 +1615,7 @@ implementation
(eq<>te_incompatible) do
begin
if (acn.left.nodetype=calln) then
tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef))
tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef),false)
else
tmpeq:=compare_defs(acn.left.resultdef,tarraydef(def_to).elementdef,acn.left.nodetype);
if tmpeq<eq then
@ -2206,7 +2206,16 @@ implementation
end;
end;
{ when a procvar was changed to a call an exact much is
{ univ parameters match if the size matches (don't override the
comparison result if it was ok, since a match based on the
"univ" character is the lowest possible match) }
if (eq=te_incompatible) and
currpara.univpara and
is_valid_univ_para_type(def_from) and
(def_from.size=def_to.size) then
eq:=te_convert_l5;
{ when a procvar was changed to a call an exact match is
downgraded to equal. This way an overload call with the
procvar is choosen. See tb0471 (PFV) }
if (pt<>currpt) and (eq=te_exact) then

35
compiler/msg/errore.msg
View File

@ -368,7 +368,7 @@ scanner_w_illegal_warn_identifier=02087_W_Illegal identifier "$1" for $WARN dire
#
# Parser
#
# 03284 is the last used one
# 03287 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -1293,11 +1293,14 @@ parser_e_more_array_elements_expected=03285_E_Expected another $1 array elements
parser_e_string_const_too_long=03286_E_String constant too long while ansistrings are disabled
% Only when a piece of code is compiled with ansistrings enabled (\var{\{\$H+\}}), string constants
% longer than 255 characters are allowed.
parser_e_invalid_univ_para=03287_E_Type cannot be used as univ parameter because its size is unknown at compile time: "$1"
% \var{univ} parameters are compatible with all values of the same size, but this
% cannot be checked in case a parameter's size is unknown at compile time.
% \end{description}
#
# Type Checking
#
# 04094 is the last used one
# 04095 is the last used one
#
% \section{Type checking errors}
% This section lists all errors that can occur when type checking is
@ -1613,8 +1616,32 @@ type_e_objc_type_unsupported=04092_E_The type "$1" is not supported for interact
type_e_class_or_objcclass_type_expected=04093_E_Class or objcclass type expected, but got "$1"
% It is only possible to create class reference types of \var{class} and \var{objcclass}
type_e_objcclass_type_expected=04094_E_Objcclass type expected
% The compiler expected an Objc
% \var{objcclass} types
% The compiler expected an \var{objcclass} type
type_w_procvar_univ_conflicting_para=04095_W_Coerced univ parameter type in procedural variable may cause crash or memory corruption: $1 to $2
% \var{univ} parameters are implicitly compatible with all types of the same size,
% also in procedural variable definitions. That means that the following code is
% legal, because \var{single} and \var{longint} have the same size:
% \begin{verbatim}
% {$mode macpas}
% Type
% TIntProc = procedure (l: univ longint);
%
% procedure test(s: single);
% begin
% writeln(s);
% end;
%
% var
% p: TIntProc;
% begin
% p:=test;
% p(4);
% end.
% \end{verbatim}
% This code may however crash on platforms that pass integers in registers and
% floating point values on the stack, because then the stack will be unbalanced.
% Note that this warning will not flagg all potentially dangerous situations.
% when \var{test} returns.
%
% \end{description}
#

6
compiler/msgidx.inc
View File

@ -375,6 +375,7 @@ const
parser_e_operator_not_overloaded_3=03284;
parser_e_more_array_elements_expected=03285;
parser_e_string_const_too_long=03286;
parser_e_invalid_univ_para=03287;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -460,6 +461,7 @@ const
type_e_objc_type_unsupported=04092;
type_e_class_or_objcclass_type_expected=04093;
type_e_objcclass_type_expected=04094;
type_w_procvar_univ_conflicting_para=04095;
sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002;
@ -852,9 +854,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 55890;
MsgTxtSize = 56081;
MsgIdxMax : array[1..20] of longint=(
24,88,287,95,80,51,110,22,202,63,
24,88,288,96,80,51,110,22,202,63,
49,20,1,1,1,1,1,1,1,1
);

793
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

30
compiler/ncal.pas
View File

@ -658,7 +658,7 @@ implementation
begin
{ Convert tp procvars, this is needs to be done
here to make the change permanent. in the overload
choosing the changes are only made temporary }
choosing the changes are only made temporarily }
if (left.resultdef.typ=procvardef) and
not(parasym.vardef.typ in [procvardef,formaldef]) then
begin
@ -738,7 +738,8 @@ implementation
{ test conversions }
if not(is_shortstring(left.resultdef) and
is_shortstring(parasym.vardef)) and
(parasym.vardef.typ<>formaldef) then
(parasym.vardef.typ<>formaldef) and
not(parasym.univpara) then
begin
{ Process open parameters }
if paramanager.push_high_param(parasym.varspez,parasym.vardef,aktcallnode.procdefinition.proccalloption) then
@ -805,6 +806,29 @@ implementation
CGMessagePos(left.fileinfo,type_e_strict_var_string_violation);
end;
{ passing a value to an "univ" parameter implies an explicit
typecast to the parameter type. Must be done before the
valid_for_var() check, since the typecast can result in
an invalid lvalue in case of var/out parameters. }
if (parasym.univpara) then
begin
{ load procvar if a procedure is passed }
if ((m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches)) and
(left.nodetype=calln) and
(is_void(left.resultdef)) then
begin
load_procvar_from_calln(left);
{ load_procvar_from_calln() creates a loadn for a
a procedure, which means that the type conversion
below will type convert the first instruction
bytes of the procedure -> convert to a procvar }
left:=ctypeconvnode.create_proc_to_procvar(left);
typecheckpass(left);
end;
inserttypeconv_explicit(left,parasym.vardef);
end;
{ Handle formal parameters separate }
if (parasym.vardef.typ=formaldef) then
begin
@ -844,7 +868,7 @@ implementation
parameter and we can pass the address transparently (but
that is handled by make_not_regable if ra_addr_regable is
passed, and make_not_regable always needs to called for
the ra_addr_taken info for non-invisble parameters }
the ra_addr_taken info for non-invisble parameters) }
if (
not(
(vo_is_hidden_para in parasym.varoptions) and

51
compiler/ncnv.pas
View File

@ -213,6 +213,7 @@ interface
cisnode : tisnodeclass;
procedure inserttypeconv(var p:tnode;def:tdef);
procedure inserttypeconv_explicit(var p:tnode;def:tdef);
procedure inserttypeconv_internal(var p:tnode;def:tdef);
procedure arrayconstructor_to_set(var p : tnode);
procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
@ -232,8 +233,10 @@ implementation
{*****************************************************************************
Helpers
*****************************************************************************}
type
ttypeconvnodetype = (tct_implicit,tct_explicit,tct_internal);
procedure inserttypeconv(var p:tnode;def:tdef);
procedure do_inserttypeconv(var p: tnode;def: tdef; convtype: ttypeconvnodetype);
begin
if not assigned(p.resultdef) then
@ -251,35 +254,37 @@ implementation
p.resultdef:=def
else
begin
p:=ctypeconvnode.create(p,def);
case convtype of
tct_implicit:
p:=ctypeconvnode.create(p,def);
tct_explicit:
p:=ctypeconvnode.create_explicit(p,def);
tct_internal:
p:=ctypeconvnode.create_internal(p,def);
end;
p.fileinfo:=ttypeconvnode(p).left.fileinfo;
typecheckpass(p);
end;
end;
procedure inserttypeconv(var p:tnode;def:tdef);
begin
do_inserttypeconv(p,def,tct_implicit);
end;
procedure inserttypeconv_explicit(var p: tnode; def: tdef);
begin
do_inserttypeconv(p,def,tct_explicit);
end;
procedure inserttypeconv_internal(var p:tnode;def:tdef);
begin
if not assigned(p.resultdef) then
begin
typecheckpass(p);
if codegenerror then
exit;
end;
{ don't insert superfluous type conversions, but
in case of bitpacked accesses, the original type must
remain too so that not too many/few bits are laoded }
if equal_defs(p.resultdef,def) and
not is_bitpacked_access(p) then
p.resultdef:=def
else
begin
p:=ctypeconvnode.create_internal(p,def);
p.fileinfo:=ttypeconvnode(p).left.fileinfo;
typecheckpass(p);
end;
do_inserttypeconv(p,def,tct_internal);
end;
@ -1684,7 +1689,7 @@ implementation
if convtype=tc_none then
begin
cdoptions:=[cdo_check_operator,cdo_allow_variant];
cdoptions:=[cdo_check_operator,cdo_allow_variant,cdo_warn_incompatible_univ];
if nf_explicit in flags then
include(cdoptions,cdo_explicit);
if nf_internal in flags then
@ -1785,7 +1790,7 @@ implementation
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if not(nf_explicit in flags) and
(proc_to_procvar_equal(currprocdef,tprocvardef(resultdef))=te_incompatible) then
(proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible) then
IncompatibleTypes(left.resultdef,resultdef);
exit;
end;

6
compiler/nobj.pas
View File

@ -269,7 +269,7 @@ implementation
end;
{ compare parameter types only, no specifiers yet }
hasequalpara:=(compare_paras(vmtpd.paras,pd.paras,cp_none,[])>=te_equal);
hasequalpara:=(compare_paras(vmtpd.paras,pd.paras,cp_none,[cpo_ignoreuniv])>=te_equal);
{ check that we are not trying to override a final method }
if (po_finalmethod in vmtpd.procoptions) and
@ -349,7 +349,7 @@ implementation
{ All parameter specifiers and some procedure the flags have to match
except abstract and override }
if (compare_paras(vmtpd.paras,pd.paras,cp_all,[])<te_equal) or
if (compare_paras(vmtpd.paras,pd.paras,cp_all,[cpo_ignoreuniv])<te_equal) or
(vmtpd.proccalloption<>pd.proccalloption) or
(vmtpd.proctypeoption<>pd.proctypeoption) or
((vmtpd.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
@ -429,7 +429,7 @@ implementation
begin
implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
if (implprocdef.procsym=tprocsym(srsym)) and
(compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])>=te_equal) and
(compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_ignoreuniv])>=te_equal) and
(compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
(proc.proccalloption=implprocdef.proccalloption) and
(proc.proctypeoption=implprocdef.proctypeoption) and

20
compiler/pdecsub.pas
View File

@ -428,7 +428,8 @@ implementation
paranr : integer;
dummytype : ttypesym;
explicit_paraloc,
need_array: boolean;
need_array,
is_univ: boolean;
begin
old_block_type:=block_type;
explicit_paraloc:=false;
@ -446,6 +447,7 @@ implementation
paranr:=0;
inc(testcurobject);
block_type:=bt_var;
is_univ:=false;
repeat
parseprocvar:=pv_none;
if try_to_consume(_VAR) then
@ -560,7 +562,8 @@ implementation
else
begin
if (m_mac in current_settings.modeswitches) then
try_to_consume(_UNIV); {currently does nothing}
is_univ:=try_to_consume(_UNIV);
if try_to_consume(_TYPE) then
hdef:=ctypedformaltype
else
@ -645,9 +648,16 @@ implementation
not(varspez in [vs_out,vs_var]) then
CGMessage(cg_e_file_must_call_by_reference);
{ univ cannot be used with types whose size is not known at compile
time }
if is_univ and
not is_valid_univ_para_type(hdef) then
Message1(parser_e_invalid_univ_para,hdef.typename);
for i:=0 to sc.count-1 do
begin
vs:=tparavarsym(sc[i]);
vs.univpara:=is_univ;
{ update varsym }
vs.vardef:=hdef;
vs.defaultconstsym:=defaultvalue;
@ -2754,7 +2764,7 @@ const
{ check arguments, we need to check only the user visible parameters. The hidden parameters
can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV) }
(
(compare_paras(currpd.paras,fwpd.paras,cp_none,[cpo_comparedefaultvalue,cpo_ignorehidden,cpo_openequalisexact])=te_exact) and
(compare_paras(currpd.paras,fwpd.paras,cp_none,[cpo_comparedefaultvalue,cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and
(fwpd.returndef=currpd.returndef)
) then
begin
@ -2767,9 +2777,9 @@ const
if not(m_repeat_forward in current_settings.modeswitches) and
(fwpd.proccalloption<>currpd.proccalloption) then
paracompopt:=[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_openequalisexact]
paracompopt:=[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv]
else
paracompopt:=[cpo_comparedefaultvalue,cpo_openequalisexact];
paracompopt:=[cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv];
{ Check calling convention }
if (fwpd.proccalloption<>currpd.proccalloption) then

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 115;
CurrentPPUVersion = 116;
{ buffer sizes }
maxentrysize = 1024;

2
compiler/symdef.pas
View File

@ -2900,6 +2900,8 @@ implementation
vs_out :
s:=s+'out ';
end;
if hp.univpara then
s:=s+'univ ';
if assigned(hp.vardef.typesym) then
begin
hs:=hp.vardef.typesym.realname;

8
compiler/symsym.pas
View File

@ -180,6 +180,10 @@ interface
tparavarsym = class(tabstractnormalvarsym)
paraloc : array[tcallercallee] of TCGPara;
paranr : word; { position of this parameter }
{ in MacPas mode, "univ" parameters mean that type checking should
be disabled, except that the size of the passed parameter must
match the size of the formal parameter }
univpara : boolean;
{$ifdef EXTDEBUG}
eqval : tequaltype;
{$endif EXTDEBUG}
@ -695,7 +699,7 @@ implementation
for i:=0 to ProcdefList.Count-1 do
begin
pd:=tprocdef(ProcdefList[i]);
eq:=proc_to_procvar_equal(pd,d);
eq:=proc_to_procvar_equal(pd,d,false);
if eq>=te_equal then
begin
{ multiple procvars with the same equal level }
@ -1401,6 +1405,7 @@ implementation
begin
inherited ppuload(paravarsym,ppufile);
paranr:=ppufile.getword;
univpara:=boolean(ppufile.getbyte);
{ The var state of parameter symbols is fixed after writing them so
we write them to the unit file.
@ -1429,6 +1434,7 @@ implementation
begin
inherited ppuwrite(ppufile);
ppufile.putword(paranr);
ppufile.putbyte(byte(univpara));
{ The var state of parameter symbols is fixed after writing them so
we write them to the unit file.

119
tests/webtbf/tw15777b.pp Normal file
View File

@ -0,0 +1,119 @@
{ %opt=-vw -Sew }
{ %fail }
{ has to fail because of the longint/single mixing with the procvars }
{$mode macpas}
program testunivprocparams;
type
Int8 = -128..127;
Int16 = integer;
Int32 = longint;
Rec32 = packed record f1, f2: Int16 end;
procedure calli32value( procedure pp( i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure calli32var( procedure pp( var i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure calli32const( procedure pp( const i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure psvalue( s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure psvar( var s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure psconst( const s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure pdvalue( d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pdvar( var d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pdconst( const d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pi8value( i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi8var( var i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi8const( const i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi16value( i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi16var( var i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi16const( const i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi32value( i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure pi32var( var i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure pi32const( const i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure variouscalli32;
var
s: single;
d: double;
i8: Int8;
i16: Int16;
i32: Int32;
r: Rec32;
begin
s:=1.0;
d:=1.0;
i8:=1;
i16:=2;
r.f1:=3;
r.f1:=4;
i32:=5;
calli32value( psvalue, s, 'psvalue');
calli32var( psvar, s, 'psvar');
calli32const( psconst, s, 'psconst');
end;
begin
variouscalli32
end.

27
tests/webtbs/tw15777a.pp Normal file
View File

@ -0,0 +1,27 @@
{ %opt=-vw -Sew }
{ should not cause warnings about potential problems with coerced univ
parameters, since no procvars are involved }
{$mode macpas}
type
tr = record
l : longint;
end;
procedure test(l: univ longint);
begin
writeln(l);
end;
var
r: tr;
s: single;
begin
r.l:=12345;
test(r);
s:=1234;
test(s);
end.

163
tests/webtbs/tw15777c.pp Normal file
View File

@ -0,0 +1,163 @@
{ %opt=-vw -Sew }
{$mode macpas}
program testunivprocparams;
type
Int8 = -128..127;
Int16 = integer;
Int32 = longint;
Rec32 = packed record f1, f2: Int16 end;
procedure calli32value( procedure pp( i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure calli32var( procedure pp( var i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure calli32const( procedure pp( const i: univ Int32; x: string); i: univ Int32; x: string);
begin
pp( i, x)
end;
procedure psvalue( s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure psvar( var s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure psconst( const s: single; x: string);
begin
writeln( s, ', ', x)
end;
procedure pdvalue( d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pdvar( var d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pdconst( const d: double; x: string);
begin
writeln( d, ', ', x)
end;
procedure pi8value( i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi8var( var i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi8const( const i8: Int8; x: string);
begin
writeln( i8, ', ', x)
end;
procedure pi16value( i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi16var( var i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi16const( const i16: Int16; x: string);
begin
writeln( i16, ', ', x)
end;
procedure pi32value( i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure pi32var( var i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure pi32const( const i32: Int32; x: string);
begin
writeln( i32, ', ', x)
end;
procedure variouscalli32;
var
s: single;
d: double;
i8: Int8;
i16: Int16;
i32: Int32;
r: Rec32;
begin
s:=1.0;
d:=1.0;
i8:=1;
i16:=2;
r.f1:=3;
r.f1:=4;
i32:=5;
{ will crash on platforms that pass integers by register and
floats by stack }
// calli32value( psvalue, s, 'psvalue');
// calli32var( psvar, s, 'psvar');
// calli32const( psconst, s, 'psconst');
{ not allowed by fpc because sizeof(double) <> sizeof(longint) }
// calli32value( pdvalue, d, 'pdvalue');
// calli32var( pdvar, d, 'pdvar');
// calli32const( pdconst, d, 'pdconst');
{ not allowed by fpc because size(shortint) <> sizeof(longint) }
// calli32value( pi8value, i8, 'pi8value');
// calli32var( pi8var, i8, 'pi8var');
// calli32const( pi8const, i8, 'pi8const');
{ not allowed by fpc because sizeof(smallint) <> sizeof(longint) }
// calli32value( pi16value, i16, 'pi16value');
// calli32var( pi16var, i16, 'pi16var');
// calli32const( pi16const, i16, 'pi16const');
calli32value( pi32value, i32, 'pi32value');
calli32var( pi32var, i32, 'pi32var');
calli32const( pi32const, i32, 'pi32const');
end;
begin
variouscalli32
end.
{
Below is the output from CodeWarrior. FPC's output can be different in case
sizes differ, and if floating point/integer types are mixed
1.000e+0 , psvalue
0.000e+0 , psvar
1.000e+0 , psconst
1.000e+9 ,
3.227e-314 , pdvar
1.000e+15 , Q
Q
Q
1, pi8value
0, pi8var
1, pi8const
1, pi16value
0, pi16var
1, pi16const
1, pi32value
1, pi32var
1, pi32const
}

80
tests/webtbs/tw15777d.pp Normal file
View File

@ -0,0 +1,80 @@
{ %opt=-vw -Sew }
{$mode macpas}
type
Int8 = -128..127;
Int16 = integer;
Int32 = longint;
Rec1 = packed record f1, f2: Int8 end;
Rec2 = packed record f1, f2: Int16 end;
Rec3 = packed record f1, f2: Int32 end;
procedure test1(l: univ Int32);
begin
writeln(l)
end;
procedure test2(l: Int32);
begin
writeln(l)
end;
procedure test3(var l: univ Int32);
begin
writeln(l)
end;
procedure test4(const l: univ Int32);
begin
writeln(l)
end;
procedure testit;
var
s: single;
d: double;
i8: Int8;
i16: Int16;
i32: Int32;
r1: rec1;
r2: rec2;
r3: rec3;
begin
s:=1.0;
d:=1.0;
i8:=1;
i16:=1;
r2.f1:=1;
r2.f1:=1;
i32:= Int32( s);
test1(s);
test3(s);
test4(s);
// not supported by FPC since the sizes differ
// test1(d);
test1(i32);
test2(i32);
test3(i32);
test4(i32);
test1(1.0);
test4(1.0);
test1(2.0);
test4(2.0);
test1(r2);
test3(r2);
test4(r2);
test1(i8);
test4(i8);
test1(i16);
test4(i16);
i8:= Int8(i32);
i8:= Int8(i16);
i16:= Int16(i32);
i32:= Int32(i16);
end;
begin
testit
end.