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

    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 -

.gitattributes

@@ -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

compiler/defcmp.pas

@@ -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;

compiler/defutil.pas

@@ -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.

compiler/htypechk.pas

@@ -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

compiler/msg/errore.msg

@@ -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}
 #

compiler/msgidx.inc

@@ -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
   );

compiler/ncal.pas

@@ -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

compiler/ncnv.pas

@@ -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_internal(var p:tnode;def:tdef);
+    procedure inserttypeconv(var p:tnode;def:tdef);
 
       begin
-        if not assigned(p.resultdef) then
-         begin
-           typecheckpass(p);
-           if codegenerror then
-            exit;
-         end;
+        do_inserttypeconv(p,def,tct_implicit);
+      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;
+
+    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
+        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;

compiler/nobj.pas

@@ -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

compiler/pdecsub.pas

@@ -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

compiler/ppu.pas

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

compiler/symdef.pas

@@ -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;

compiler/symsym.pas

@@ -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.

tests/webtbf/tw15777b.pp

@@ -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.

tests/webtbs/tw15777a.pp

@@ -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.
+

tests/webtbs/tw15777c.pp

@@ -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
+
+
+}

tests/webtbs/tw15777d.pp

@@ -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.
+