* better const to var checking

compiler/htypechk.pas

@@ -96,18 +96,9 @@ interface
     { subroutine handling }
     procedure test_protected_sym(sym : tsym);
     procedure test_protected(p : tnode);
-    function  valid_for_formal_var(p : tnode) : boolean;
-    function  valid_for_formal_const(p : tnode) : boolean;
     function  is_procsym_load(p:tnode):boolean;
     function  is_procsym_call(p:tnode):boolean;
     procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
-    function  valid_for_assign(p:tnode;allowprop:boolean):boolean;
-    { sets the callunique flag, if the node is a vecn, }
-    { takes care of type casts etc.                 }
-    procedure set_unique(p : tnode);
-
-    { sets funcret_is_valid to true, if p contains a funcref node }
-    procedure set_funcret_is_valid(p : tnode);
 
     {
     type
@@ -118,6 +109,18 @@ interface
     procedure unset_varstate(p : tnode);
     procedure set_varstate(p : tnode;must_be_valid : boolean);
 
+    { sets the callunique flag, if the node is a vecn, }
+    { takes care of type casts etc.                 }
+    procedure set_unique(p : tnode);
+
+    { sets funcret_is_valid to true, if p contains a funcref node }
+    procedure set_funcret_is_valid(p : tnode);
+
+    function  valid_for_formal_var(p : tnode) : boolean;
+    function  valid_for_formal_const(p : tnode) : boolean;
+    function  valid_for_var(p:tnode):boolean;
+    function  valid_for_assignment(p:tnode):boolean;
+
 
 implementation
 
@@ -135,6 +138,11 @@ implementation
 {$endif}
        ;
 
+    type
+      TValidAssign=(Valid_Property,Valid_Void);
+      TValidAssigns=set of TValidAssign;
+
+
     { ld is the left type definition
       rd the right type definition
       dd the result type definition  or voiddef if unkown }
@@ -496,61 +504,6 @@ implementation
         end;
       end;
 
-   function  valid_for_formal_var(p : tnode) : boolean;
-     var
-        v : boolean;
-     begin
-        case p.nodetype of
-         loadn :
-           v:=(tloadnode(p).symtableentry.typ in [typedconstsym,varsym]);
-         typeconvn :
-           v:=valid_for_formal_var(ttypeconvnode(p).left);
-         derefn,
-         subscriptn,
-         vecn,
-         funcretn,
-         selfn :
-           v:=true;
-         calln : { procvars are callnodes first }
-           v:=assigned(tcallnode(p).right) and not assigned(tcallnode(p).left);
-         addrn :
-           begin
-             { addrn is not allowed as this generate a constant value,
-               but a tp procvar are allowed (PFV) }
-             if nf_procvarload in p.flags then
-              v:=true
-             else
-              v:=false;
-           end;
-         else
-           v:=false;
-        end;
-        valid_for_formal_var:=v;
-     end;
-
-   function  valid_for_formal_const(p : tnode) : boolean;
-     var
-        v : boolean;
-     begin
-        { p must have been firstpass'd before }
-        { accept about anything but not a statement ! }
-        case p.nodetype of
-          calln,
-          statementn,
-          addrn :
-           begin
-             { addrn is not allowed as this generate a constant value,
-               but a tp procvar are allowed (PFV) }
-             if nf_procvarload in p.flags then
-              v:=true
-             else
-              v:=false;
-           end;
-          else
-            v:=true;
-        end;
-        valid_for_formal_const:=v;
-     end;
 
     function is_procsym_load(p:tnode):boolean;
       begin
@@ -559,6 +512,7 @@ implementation
                           and (tloadnode(taddrnode(p).left).symtableentry.typ=procsym)) ;
       end;
 
+
    { change a proc call to a procload for assignment to a procvar }
    { this can only happen for proc/function without arguments }
     function is_procsym_call(p:tnode):boolean;
@@ -577,7 +531,182 @@ implementation
       end;
 
 
-    function valid_for_assign(p:tnode;allowprop:boolean):boolean;
+    procedure set_varstate(p : tnode;must_be_valid : boolean);
+      var
+        hsym : tvarsym;
+      begin
+        while assigned(p) do
+         begin
+           if (nf_varstateset in p.flags) then
+            exit;
+           include(p.flags,nf_varstateset);
+           case p.nodetype of
+             typeconvn :
+               begin
+                 case ttypeconvnode(p).convtype of
+                   tc_cchar_2_pchar,
+                   tc_cstring_2_pchar,
+                   tc_array_2_pointer :
+                     must_be_valid:=false;
+                   tc_pchar_2_string,
+                   tc_pointer_2_array :
+                     must_be_valid:=true;
+                 end;
+                 p:=tunarynode(p).left;
+               end;
+             subscriptn :
+               p:=tunarynode(p).left;
+             vecn:
+               begin
+                 set_varstate(tbinarynode(p).right,true);
+                 if not(tunarynode(p).left.resulttype.def.deftype in [stringdef,arraydef]) then
+                  must_be_valid:=true;
+                 p:=tunarynode(p).left;
+               end;
+             { do not parse calln }
+             calln :
+               break;
+             callparan :
+               begin
+                 set_varstate(tbinarynode(p).right,must_be_valid);
+                 p:=tunarynode(p).left;
+               end;
+             loadn :
+               begin
+                 if (tloadnode(p).symtableentry.typ=varsym) then
+                  begin
+                    hsym:=tvarsym(tloadnode(p).symtableentry);
+                    if must_be_valid and (nf_first in p.flags) then
+                     begin
+                       if (hsym.varstate=vs_declared_and_first_found) or
+                          (hsym.varstate=vs_set_but_first_not_passed) then
+                        begin
+                          if (assigned(hsym.owner) and
+                             assigned(aktprocsym) and
+                             (hsym.owner = aktprocsym.definition.localst)) then
+                           begin
+                             if tloadnode(p).symtable.symtabletype=localsymtable then
+                              CGMessage1(sym_n_uninitialized_local_variable,hsym.realname)
+                             else
+                              CGMessage1(sym_n_uninitialized_variable,hsym.realname);
+                           end;
+                        end;
+                     end;
+                    if (nf_first in p.flags) then
+                     begin
+                       if hsym.varstate=vs_declared_and_first_found then
+                        begin
+                          { this can only happen at left of an assignment, no ? PM }
+                          if (parsing_para_level=0) and not must_be_valid then
+                           hsym.varstate:=vs_assigned
+                          else
+                           hsym.varstate:=vs_used;
+                        end
+                       else
+                        if hsym.varstate=vs_set_but_first_not_passed then
+                         hsym.varstate:=vs_used;
+                       exclude(p.flags,nf_first);
+                     end
+                    else
+                      begin
+                        if (hsym.varstate=vs_assigned) and
+                           (must_be_valid or (parsing_para_level>0) or
+                            (p.resulttype.def.deftype=procvardef)) then
+                          hsym.varstate:=vs_used;
+                        if (hsym.varstate=vs_declared_and_first_found) and
+                           (must_be_valid or (parsing_para_level>0) or
+                           (p.resulttype.def.deftype=procvardef)) then
+                          hsym.varstate:=vs_set_but_first_not_passed;
+                      end;
+                  end;
+                 break;
+               end;
+             funcretn:
+               begin
+                 { no claim if setting higher return value_str }
+                 if must_be_valid and
+                    (procinfo=pprocinfo(tfuncretnode(p).funcretprocinfo)) and
+                    ((procinfo^.funcret_state=vs_declared) or
+                    ((nf_is_first_funcret in p.flags) and
+                     (procinfo^.funcret_state=vs_declared_and_first_found))) then
+                   begin
+                     CGMessage(sym_w_function_result_not_set);
+                     { avoid multiple warnings }
+                     procinfo^.funcret_state:=vs_assigned;
+                   end;
+                 if (nf_is_first_funcret in p.flags) and not must_be_valid then
+                   pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
+                 break;
+               end;
+             else
+               break;
+           end;{case }
+         end;
+      end;
+
+
+    procedure unset_varstate(p : tnode);
+      begin
+        while assigned(p) do
+         begin
+           exclude(p.flags,nf_varstateset);
+           case p.nodetype of
+             typeconvn,
+             subscriptn,
+             vecn :
+               p:=tunarynode(p).left;
+             else
+               break;
+           end;
+         end;
+      end;
+
+
+    procedure set_unique(p : tnode);
+      begin
+        while assigned(p) do
+         begin
+           case p.nodetype of
+             vecn:
+               begin
+                 include(p.flags,nf_callunique);
+                 break;
+               end;
+             typeconvn,
+             subscriptn,
+             derefn:
+               p:=tunarynode(p).left;
+             else
+               break;
+           end;
+         end;
+      end;
+
+
+    procedure set_funcret_is_valid(p:tnode);
+      begin
+        while assigned(p) do
+         begin
+           case p.nodetype of
+             funcretn:
+               begin
+                 if (nf_is_first_funcret in p.flags) then
+                   pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
+                 break;
+               end;
+             vecn,
+             {derefn,}
+             typeconvn,
+             subscriptn:
+               p:=tunarynode(p).left;
+             else
+               break;
+           end;
+         end;
+      end;
+
+
+    function  valid_for_assign(p:tnode;opts:TValidAssigns):boolean;
       var
         hp : tnode;
         gotwith,
@@ -593,7 +722,8 @@ implementation
         gotpointer:=false;
         gotwith:=false;
         hp:=p;
-        if is_void(hp.resulttype.def) then
+        if not(valid_void in opts) and
+           is_void(hp.resulttype.def) then
          begin
            CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
            exit;
@@ -601,7 +731,7 @@ implementation
         while assigned(hp) do
          begin
            { property allowed? calln has a property check itself }
-           if (not allowprop) and
+           if not(valid_property in opts) and
               (nf_isproperty in hp.flags) and
               (hp.nodetype<>calln) then
             begin
@@ -687,7 +817,7 @@ implementation
                    3. property is allowed }
                  if (gotpointer and gotderef) or
                     (gotclass and (gotsubscript or gotwith)) or
-                    ((nf_isproperty in hp.flags) and allowprop) then
+                    ((nf_isproperty in hp.flags) and (valid_property in opts)) then
                   valid_for_assign:=true
                  else
                   CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
@@ -743,184 +873,55 @@ implementation
       end;
 
 
-    procedure set_varstate(p : tnode;must_be_valid : boolean);
-      var
-        hsym : tvarsym;
+    function  valid_for_var(p:tnode):boolean;
       begin
-        while assigned(p) do
-         begin
-           if (nf_varstateset in p.flags) then
-            exit;
-           include(p.flags,nf_varstateset);
-           case p.nodetype of
-             typeconvn :
-               begin
-                 case ttypeconvnode(p).convtype of
-                   tc_cchar_2_pchar,
-                   tc_cstring_2_pchar,
-                   tc_array_2_pointer :
-                     must_be_valid:=false;
-                   tc_pchar_2_string,
-                   tc_pointer_2_array :
-                     must_be_valid:=true;
-                 end;
-                 p:=tunarynode(p).left;
-               end;
-             subscriptn :
-               p:=tunarynode(p).left;
-             vecn:
-               begin
-                 set_varstate(tbinarynode(p).right,true);
-                 if not(tunarynode(p).left.resulttype.def.deftype in [stringdef,arraydef]) then
-                  must_be_valid:=true;
-                 p:=tunarynode(p).left;
-               end;
-             { do not parse calln }
-             calln :
-               break;
-             callparan :
-               begin
-                 set_varstate(tbinarynode(p).right,must_be_valid);
-                 p:=tunarynode(p).left;
-               end;
-             loadn :
-               begin
-                 if (tloadnode(p).symtableentry.typ=varsym) then
-                  begin
-                    hsym:=tvarsym(tloadnode(p).symtableentry);
-                    if must_be_valid and (nf_first in p.flags) then
-                     begin
-                       if (hsym.varstate=vs_declared_and_first_found) or
-                          (hsym.varstate=vs_set_but_first_not_passed) then
-                        begin
-                          if (assigned(hsym.owner) and
-                             assigned(aktprocsym) and
-                             (hsym.owner = aktprocsym.definition.localst)) then
-                           begin
-                             if tloadnode(p).symtable.symtabletype=localsymtable then
-                              CGMessage1(sym_n_uninitialized_local_variable,hsym.realname)
-                             else
-                              CGMessage1(sym_n_uninitialized_variable,hsym.realname);
-                           end;
-                        end;
-                     end;
-                    if (nf_first in p.flags) then
-                     begin
-                       if hsym.varstate=vs_declared_and_first_found then
-                        begin
-                          { this can only happen at left of an assignment, no ? PM }
-                          if (parsing_para_level=0) and not must_be_valid then
-                           hsym.varstate:=vs_assigned
-                          else
-                           hsym.varstate:=vs_used;
-                        end
-                       else
-                        if hsym.varstate=vs_set_but_first_not_passed then
-                         hsym.varstate:=vs_used;
-                       exclude(p.flags,nf_first);
-                     end
-                    else
-                      begin
-                        if (hsym.varstate=vs_assigned) and
-                           (must_be_valid or (parsing_para_level>0) or
-                            (p.resulttype.def.deftype=procvardef)) then
-                          hsym.varstate:=vs_used;
-                        if (hsym.varstate=vs_declared_and_first_found) and
-                           (must_be_valid or (parsing_para_level>0) or
-                           (p.resulttype.def.deftype=procvardef)) then
-                          hsym.varstate:=vs_set_but_first_not_passed;
-                      end;
-                  end;
-                 break;
-               end;
-             funcretn:
-               begin
-                 { no claim if setting higher return value_str }
-                 if must_be_valid and
-                    (procinfo=pprocinfo(tfuncretnode(p).funcretprocinfo)) and
-                    ((procinfo^.funcret_state=vs_declared) or
-                    ((nf_is_first_funcret in p.flags) and
-                     (procinfo^.funcret_state=vs_declared_and_first_found))) then
-                   begin
-                     CGMessage(sym_w_function_result_not_set);
-                     { avoid multiple warnings }
-                     procinfo^.funcret_state:=vs_assigned;
-                   end;
-                 if (nf_is_first_funcret in p.flags) and not must_be_valid then
-                   pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
-                 break;
-               end;
-             else
-               break;
-           end;{case }
-         end;
+        valid_for_var:=valid_for_assign(p,[]);
       end;
 
 
-    procedure unset_varstate(p : tnode);
+    function  valid_for_formal_var(p : tnode) : boolean;
       begin
-        while assigned(p) do
-         begin
-           exclude(p.flags,nf_varstateset);
-           case p.nodetype of
-             typeconvn,
-             subscriptn,
-             vecn :
-               p:=tunarynode(p).left;
-             else
-               break;
-           end;
-         end;
+        valid_for_formal_var:=valid_for_assign(p,[valid_void]);
       end;
 
 
-    procedure set_unique(p : tnode);
+    function  valid_for_formal_const(p : tnode) : boolean;
+      var
+        v : boolean;
       begin
-        while assigned(p) do
-         begin
-           case p.nodetype of
-             vecn:
-               begin
-                 include(p.flags,nf_callunique);
-                 break;
-               end;
-             typeconvn,
-             subscriptn,
-             derefn:
-               p:=tunarynode(p).left;
+        { p must have been firstpass'd before }
+        { accept about anything but not a statement ! }
+        case p.nodetype of
+          calln,
+          statementn,
+          addrn :
+           begin
+             { addrn is not allowed as this generate a constant value,
+               but a tp procvar are allowed (PFV) }
+             if nf_procvarload in p.flags then
+              v:=true
              else
-               break;
+              v:=false;
            end;
-         end;
+          else
+            v:=true;
+        end;
+        valid_for_formal_const:=v;
       end;
 
 
-    procedure set_funcret_is_valid(p:tnode);
+    function  valid_for_assignment(p:tnode):boolean;
       begin
-        while assigned(p) do
-         begin
-           case p.nodetype of
-             funcretn:
-               begin
-                 if (nf_is_first_funcret in p.flags) then
-                   pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
-                 break;
-               end;
-             vecn,
-             {derefn,}
-             typeconvn,
-             subscriptn:
-               p:=tunarynode(p).left;
-             else
-               break;
-           end;
-         end;
+        valid_for_assignment:=valid_for_assign(p,[valid_property]);
       end;
 
 end.
 {
   $Log$
-  Revision 1.27  2001-05-18 22:57:08  peter
+  Revision 1.28  2001-06-04 11:48:02  peter
+    * better const to var checking
+
+  Revision 1.27  2001/05/18 22:57:08  peter
     * replace constant by cpu dependent value (merged)
 
   Revision 1.26  2001/05/08 08:52:05  jonas

compiler/i386/n386cal.pas

@@ -98,15 +98,34 @@ implementation
 
          { push from left to right if specified }
          if push_from_left_to_right and assigned(right) then
-           tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
-             inlined,is_cdecl,para_alignment,para_offset);
+          begin
+            if (nf_varargs_para in flags) then
+              tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right,
+                                                   inlined,is_cdecl,para_alignment,para_offset)
+            else
+              tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
+                                                   inlined,is_cdecl,para_alignment,para_offset);
+          end;
+
          otlabel:=truelabel;
          oflabel:=falselabel;
          getlabel(truelabel);
          getlabel(falselabel);
          secondpass(left);
+         { handle varargs first, because defcoll is not valid }
+         if (nf_varargs_para in flags) then
+           begin
+             if push_addr_param(left.resulttype.def) then
+               begin
+                 inc(pushedparasize,4);
+                 emitpushreferenceaddr(left.location.reference);
+                 del_reference(left.location.reference);
+               end
+             else
+               push_value_para(left,inlined,is_cdecl,para_offset,para_alignment);
+           end
          { filter array constructor with c styled args }
-         if is_array_constructor(left.resulttype.def) and (nf_cargs in left.flags) then
+         else if is_array_constructor(left.resulttype.def) and (nf_cargs in left.flags) then
            begin
              { nothing, everything is already pushed }
            end
@@ -155,7 +174,7 @@ implementation
          else if (defcoll.paratyp in [vs_var,vs_out]) then
            begin
               if (left.location.loc<>LOC_REFERENCE) then
-                CGMessage(cg_e_var_must_be_reference);
+                internalerror(200106041);
               maybe_push_high;
               if (defcoll.paratyp=vs_out) and
                  assigned(defcoll.paratype.def) and
@@ -218,8 +237,14 @@ implementation
          falselabel:=oflabel;
          { push from right to left }
          if not push_from_left_to_right and assigned(right) then
-           tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
-             inlined,is_cdecl,para_alignment,para_offset);
+          begin
+            if (nf_varargs_para in flags) then
+              tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right,
+                                                   inlined,is_cdecl,para_alignment,para_offset)
+            else
+              tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
+                                                   inlined,is_cdecl,para_alignment,para_offset);
+          end;
       end;
 
 
@@ -1551,7 +1576,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.24  2001-05-19 21:22:53  peter
+  Revision 1.25  2001-06-04 11:48:02  peter
+    * better const to var checking
+
+  Revision 1.24  2001/05/19 21:22:53  peter
     * function returning int64 inlining fixed
 
   Revision 1.23  2001/05/16 15:11:42  jonas

compiler/ncal.pas

@@ -199,16 +199,34 @@ implementation
 {$endif def extdebug}
          if assigned(right) then
            begin
-              if defcoll=nil then
-                tcallparanode(right).insert_typeconv(nil,do_count)
-              else
-                tcallparanode(right).insert_typeconv(tparaitem(defcoll.next),do_count);
+             { if we are a para that belongs to varargs then keep
+               the current defcoll }
+             if (nf_varargs_para in flags) then
+              tcallparanode(right).insert_typeconv(defcoll,do_count)
+             else
+              tcallparanode(right).insert_typeconv(tparaitem(defcoll.next),do_count);
            end;
 
          { Be sure to have the resulttype }
          if not assigned(left.resulttype.def) then
            resulttypepass(left);
 
+         { Handle varargs directly, no typeconvs or typechecking needed }
+         if (nf_varargs_para in flags) then
+          begin
+            { convert pascal to C types }
+            case left.resulttype.def.deftype of
+              stringdef :
+                inserttypeconv(left,charpointertype);
+              floatdef :
+                inserttypeconv(left,s64floattype);
+            end;
+            set_varstate(left,true);
+            resulttype:=left.resulttype;
+            dec(parsing_para_level);
+            exit;
+          end;
+
          { Do we need arrayconstructor -> set conversion, then insert
            it here before the arrayconstructor node breaks the tree
            with its conversions of enum->ord }
@@ -235,45 +253,18 @@ implementation
              end;
           end;
 
-         if do_count then
-          begin
-            { not completly proper, but avoids some warnings }
-            if (defcoll.paratyp in [vs_var,vs_out]) then
-              set_funcret_is_valid(left);
-
-            { protected has nothing to do with read/write
-            if (defcoll.paratyp in [vs_var,vs_out]) then
-              test_protected(left);
-            }
-            { set_varstate(left,defcoll.paratyp<>vs_var);
-              must only be done after typeconv PM }
-            { only process typeconvn and arrayconstructn, else it will
-              break other trees }
-            { But this is need to get correct varstate !! PM }
-            {old_array_constructor:=allow_array_constructor;
-            old_get_para_resulttype:=get_para_resulttype;
-            allow_array_constructor:=true;
-            get_para_resulttype:=false;
-            if (left.nodetype in [arrayconstructorn,typeconvn]) then
-              firstpass(left);
-            if not assigned(resulttype.def) then
-              resulttype:=left.resulttype;
-            get_para_resulttype:=old_get_para_resulttype;
-            allow_array_constructor:=old_array_constructor; }
-          end;
          { check if local proc/func is assigned to procvar }
          if left.resulttype.def.deftype=procvardef then
            test_local_to_procvar(tprocvardef(left.resulttype.def),defcoll.paratype.def);
-         { property is not allowed as var parameter }
-         if (defcoll.paratyp in [vs_out,vs_var]) and
-            (nf_isproperty in left.flags) then
-           CGMessagePos(left.fileinfo,type_e_argument_cant_be_assigned);
+
          { generate the high() value tree }
          if not(assigned(aktcallprocsym) and
                 (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym.definition.proccalloptions)<>[]) and
                 (po_external in aktcallprocsym.definition.procoptions)) and
             push_high_param(defcoll.paratype.def) then
            gen_high_tree(is_open_string(defcoll.paratype.def));
+
+         { test conversions }
          if not(is_shortstring(left.resulttype.def) and
                 is_shortstring(defcoll.paratype.def)) and
                 (defcoll.paratype.def.deftype<>formaldef) then
@@ -334,6 +325,7 @@ implementation
                    exit;
                 end;
            end;
+
          { check var strings }
          if (cs_strict_var_strings in aktlocalswitches) and
             is_shortstring(left.resulttype.def) and
@@ -346,28 +338,28 @@ implementation
                CGMessage(type_e_strict_var_string_violation);
             end;
 
-         { variabls for call by reference may not be copied }
-         { into a register }
-         { is this usefull here ? }
-         { this was missing in formal parameter list   }
+         { Handle formal parameters separate }
          if (defcoll.paratype.def.deftype=formaldef) then
            begin
-             if defcoll.paratyp in [vs_var,vs_out] then
-               begin
-                 if not valid_for_formal_var(left) then
-                   begin
-                      aktfilepos:=left.fileinfo;
-                      CGMessage(parser_e_illegal_parameter_list);
-                   end;
-               end;
-             if defcoll.paratyp=vs_const then
-               begin
-                 if not valid_for_formal_const(left) then
-                   begin
-                      aktfilepos:=left.fileinfo;
-                      CGMessage(parser_e_illegal_parameter_list);
-                   end;
-               end;
+             case defcoll.paratyp of
+               vs_var,
+               vs_out :
+                 begin
+                   if not valid_for_formal_var(left) then
+                    CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list);
+                 end;
+               vs_const :
+                 begin
+                   if not valid_for_formal_const(left) then
+                    CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list);
+                 end;
+             end;
+           end
+         else
+           begin
+             { check if the argument is allowed }
+             if (defcoll.paratyp in [vs_out,vs_var]) then
+               valid_for_var(left);
            end;
 
          if defcoll.paratyp in [vs_var,vs_const] then
@@ -385,7 +377,12 @@ implementation
            make_not_regable(left);
 
          if do_count then
-           set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out]));
+          begin
+            { not completly proper, but avoids some warnings }
+            if (defcoll.paratyp in [vs_var,vs_out]) then
+             set_funcret_is_valid(left);
+            set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out]));
+          end;
          { must only be done after typeconv PM }
          resulttype:=defcoll.paratype;
          dec(parsing_para_level);
@@ -760,16 +757,21 @@ implementation
                      begin
                         { only when the # of parameter are supported by the
                           procedure }
-                        if (paralength>=pd.minparacount) and (paralength<=pd.maxparacount) then
+                        if (paralength>=pd.minparacount) and
+                           ((po_varargs in pd.procoptions) or { varargs }
+                            (paralength<=pd.maxparacount)) then
                           begin
                              new(hp);
                              hp^.data:=pd;
                              hp^.next:=procs;
                              hp^.firstpara:=tparaitem(pd.Para.first);
-                             { if not all parameters are given, then skip the
-                               default parameters }
-                             for i:=1 to pd.maxparacount-paralength do
-                              hp^.firstpara:=tparaitem(hp^.firstPara.next);
+                             if not(po_varargs in pd.procoptions) then
+                              begin
+                                { if not all parameters are given, then skip the
+                                  default parameters }
+                                for i:=1 to pd.maxparacount-paralength do
+                                 hp^.firstpara:=tparaitem(hp^.firstPara.next);
+                              end;
                              hp^.nextpara:=hp^.firstpara;
                              procs:=hp;
                           end;
@@ -823,27 +825,37 @@ implementation
                         hp:=procs;
                         while assigned(hp) do
                           begin
-                             if is_equal(pt,hp^.nextPara.paratype.def) then
-                               begin
-                                  if hp^.nextPara.paratype.def=pt.resulttype.def then
+                             { varargs are always equal, but not exact }
+                             if (po_varargs in hp^.data.procoptions) and
+                                (lastpara>hp^.data.minparacount) then
+                              begin
+                                hp^.nextPara.argconvtyp:=act_equal;
+                                exactmatch:=true;
+                              end
+                             else
+                              begin
+                                if is_equal(pt,hp^.nextPara.paratype.def) then
+                                 begin
+                                   if hp^.nextPara.paratype.def=pt.resulttype.def then
                                     begin
                                        include(pt.callparaflags,cpf_exact_match_found);
                                        hp^.nextPara.argconvtyp:=act_exact;
                                     end
-                                  else
+                                   else
                                     hp^.nextPara.argconvtyp:=act_equal;
-                                  exactmatch:=true;
-                               end
-                             else
-                               begin
-                                 hp^.nextPara.argconvtyp:=act_convertable;
-                                 hp^.nextPara.convertlevel:=isconvertable(pt.resulttype.def,hp^.nextPara.paratype.def,
-                                     hcvt,pt.left.nodetype,false);
-                                 case hp^.nextPara.convertlevel of
-                                  1 : include(pt.callparaflags,cpf_convlevel1found);
-                                  2 : include(pt.callparaflags,cpf_convlevel2found);
+                                   exactmatch:=true;
+                                 end
+                                else
+                                 begin
+                                   hp^.nextPara.argconvtyp:=act_convertable;
+                                   hp^.nextPara.convertlevel:=isconvertable(pt.resulttype.def,hp^.nextPara.paratype.def,
+                                       hcvt,pt.left.nodetype,false);
+                                   case hp^.nextPara.convertlevel of
+                                    1 : include(pt.callparaflags,cpf_convlevel1found);
+                                    2 : include(pt.callparaflags,cpf_convlevel2found);
+                                   end;
                                  end;
-                               end;
+                              end;
 
                              hp:=hp^.next;
                           end;
@@ -895,7 +907,11 @@ implementation
                         hp:=procs;
                         while assigned(hp) do
                           begin
-                             hp^.nextpara:=tparaitem(hp^.nextPara.next);
+                             { only goto next para if we're out of the
+                               varargs }
+                             if (not(po_varargs in hp^.data.procoptions) and
+                                 (lastpara<=hp^.data.minparacount)) then
+                               hp^.nextpara:=tparaitem(hp^.nextPara.next);
                              hp:=hp^.next;
                           end;
                         { load next parameter or quit loop if no procs left }
@@ -1243,32 +1259,32 @@ implementation
                end;
            end;
 
-              { handle predefined procedures }
-              is_const:=(pocall_internconst in procdefinition.proccalloptions) and
-                        ((block_type in [bt_const,bt_type]) or
-                         (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
-              if (pocall_internproc in procdefinition.proccalloptions) or is_const then
-                begin
-                   if assigned(left) then
-                     begin
-                     { ptr and settextbuf needs two args }
-                       if assigned(tcallparanode(left).right) then
-                        begin
-                          hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,left);
-                          left:=nil;
-                        end
-                       else
-                        begin
-                          hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,tcallparanode(left).left);
-                          tcallparanode(left).left:=nil;
-                        end;
-                     end
-                   else
-                     hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,nil);
-                   resulttypepass(hpt);
-                   result:=hpt;
-                   goto errorexit;
-                end;
+          { handle predefined procedures }
+          is_const:=(pocall_internconst in procdefinition.proccalloptions) and
+                    ((block_type in [bt_const,bt_type]) or
+                     (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
+          if (pocall_internproc in procdefinition.proccalloptions) or is_const then
+           begin
+             if assigned(left) then
+              begin
+                { ptr and settextbuf needs two args }
+                if assigned(tcallparanode(left).right) then
+                 begin
+                   hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,left);
+                   left:=nil;
+                 end
+                else
+                 begin
+                   hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,tcallparanode(left).left);
+                   tcallparanode(left).left:=nil;
+                 end;
+              end
+             else
+              hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,nil);
+             resulttypepass(hpt);
+             result:=hpt;
+             goto errorexit;
+           end;
 
          { Calling a message method directly ? }
          if assigned(procdefinition) and
@@ -1304,6 +1320,19 @@ implementation
                resulttype:=tclassrefdef(methodpointer.resulttype.def).pointertype;
            end;
 
+         { flag all callparanodes that belong to the varargs }
+         if (po_varargs in procdefinition.procoptions) then
+          begin
+            pt:=tcallparanode(left);
+            i:=paralength;
+            while (i>procdefinition.minparacount) do
+             begin
+               include(tcallparanode(pt).flags,nf_varargs_para);
+               pt:=tcallparanode(pt.right);
+               dec(i);
+             end;
+          end;
+
          { insert type conversions }
          if assigned(left) then
           tcallparanode(left).insert_typeconv(tparaitem(procdefinition.Para.first),true);
@@ -1622,7 +1651,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.33  2001-05-20 12:09:31  peter
+  Revision 1.34  2001-06-04 11:48:02  peter
+    * better const to var checking
+
+  Revision 1.33  2001/05/20 12:09:31  peter
     * fixed exit with ansistring return from function call, no_fast_exit
       should be set in det_resulttype instead of pass_1
 

compiler/ninl.pas

@@ -648,7 +648,7 @@ implementation
                              ppn:=tcallparanode(ppn.right);
                           end;
                         { last param must be var }
-                        valid_for_assign(ppn.left,false);
+                        valid_for_var(ppn.left);
                         set_varstate(ppn.left,false);
                         { first param must be a string or dynamic array ...}
                         if not((ppn.left.resulttype.def.deftype=stringdef) or
@@ -683,7 +683,7 @@ implementation
                    if assigned(left) and assigned(tcallparanode(left).left) then
                      begin
                         { first param must be var }
-                        valid_for_assign(tcallparanode(left).left,false);
+                        valid_for_var(tcallparanode(left).left);
                         set_varstate(tcallparanode(left).left,true);
 
                         { two parameters?, the last parameter must be a longint }
@@ -704,7 +704,7 @@ implementation
                        if codegenerror then
                         exit;
                        { first param must be var }
-                       valid_for_assign(tcallparanode(left).left,false);
+                       valid_for_var(tcallparanode(left).left);
 
                        if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
                           is_ordinal(left.resulttype.def) then
@@ -940,7 +940,7 @@ implementation
                  (tcallparanode(hp).right=nil) then
                 CGMessage(cg_e_illegal_expression);
               { we need a var parameter }
-              valid_for_assign(tcallparanode(hp).left,false);
+              valid_for_var(tcallparanode(hp).left);
               { generate the high() value for the shortstring }
               if is_shortstring(tcallparanode(hp).left.resulttype.def) then
                 tcallparanode(hp).gen_high_tree(true);
@@ -1027,7 +1027,7 @@ implementation
                     exit;
                    tcallparanode(left).right := hp;
                    { code has to be a var parameter }
-                   if valid_for_assign(tcallparanode(left).left,false) then
+                   if valid_for_var(tcallparanode(left).left) then
                     begin
                       if (tcallparanode(left).left.resulttype.def.deftype <> orddef) or
                          not(torddef(tcallparanode(left).left.resulttype.def).typ in [u16bit,s16bit,u32bit,s32bit]) then
@@ -1049,7 +1049,7 @@ implementation
               { remove warning when result is passed }
               set_funcret_is_valid(tcallparanode(hpp).left);
               tcallparanode(hpp).right := hp;
-              if valid_for_assign(tcallparanode(hpp).left,false) then
+              if valid_for_var(tcallparanode(hpp).left) then
                begin
                  If Not((tcallparanode(hpp).left.resulttype.def.deftype = floatdef) or
                         is_integer(tcallparanode(hpp).left.resulttype.def)) then
@@ -1073,7 +1073,7 @@ implementation
                        { remove warning when result is passed }
                        set_funcret_is_valid(tcallparanode(left).left);
                        { first param must be var }
-                       valid_for_assign(tcallparanode(left).left,false);
+                       valid_for_var(tcallparanode(left).left);
                        { check type }
                        if assigned(left.resulttype.def) and
                           (left.resulttype.def.deftype=setdef) then
@@ -1750,7 +1750,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.41  2001-06-03 20:12:53  peter
+  Revision 1.42  2001-06-04 11:48:01  peter
+    * better const to var checking
+
+  Revision 1.41  2001/06/03 20:12:53  peter
     * changed int64($ffffffff) that is buggy under 1.0.x to expression
       with a shl
 

compiler/nld.pas

@@ -388,7 +388,7 @@ implementation
          inserttypeconv(right,left.resulttype);
 
         { test if node can be assigned, properties are allowed }
-        valid_for_assign(left,true);
+        valid_for_assignment(left);
 
         { check if local proc/func is assigned to procvar }
         if right.resulttype.def.deftype=procvardef then
@@ -757,7 +757,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.17  2001-05-19 21:19:57  peter
+  Revision 1.18  2001-06-04 11:48:01  peter
+    * better const to var checking
+
+  Revision 1.17  2001/05/19 21:19:57  peter
     * remove unused typenode for procvars to prevent error
     * typenode.allowed flag to allow a typenode