* procvar cleanup

compiler/nadd.pas

@@ -74,7 +74,7 @@ implementation
       symconst,symtype,symdef,symsym,symtable,defutil,defcmp,
       cgbase,
       htypechk,pass_1,
-      nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,
+      nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
       {$ifdef state_tracking}
       nstate,
       {$endif}
@@ -128,6 +128,10 @@ implementation
          if codegenerror then
            exit;
 
+         { tp procvar support }
+         maybe_call_procvar(left,true);
+         maybe_call_procvar(right,true);
+
          { convert array constructors to sets, because there is no other operator
            possible for array constructors }
          if is_array_constructor(left.resulttype.def) then
@@ -1910,7 +1914,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.110  2004-02-05 01:24:08  florian
+  Revision 1.111  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.110  2004/02/05 01:24:08  florian
     * several fixes to compile x86-64 system
 
   Revision 1.109  2004/02/03 22:32:54  peter

compiler/ncal.pas

@@ -194,7 +194,7 @@ implementation
       verbose,globals,
       symconst,defutil,defcmp,
       htypechk,pass_1,
-      ncnv,nld,ninl,nadd,ncon,nmem,
+      ncnv,nld,ninl,nadd,ncon,nmem,nutils,
       procinfo,
       cgbase
       ;
@@ -597,6 +597,16 @@ type
 
          if (left.nodetype<>nothingn) then
            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 }
+             if (left.resulttype.def.deftype=procvardef) and
+                (paraitem.paratype.def.deftype<>procvardef) then
+               begin
+                 if maybe_call_procvar(left,true) then
+                   resulttype:=left.resulttype;
+               end;
+
              { Handle varargs and hidden paras directly, no typeconvs or }
              { typechecking needed                                       }
              if (nf_varargs_para in flags) then
@@ -1468,10 +1478,12 @@ type
         currparanr : byte;
         def_from,
         def_to   : tdef;
+        currpt,
         pt       : tcallparanode;
         eq       : tequaltype;
         convtype : tconverttype;
         pdoper   : tprocdef;
+        releasecurrpt : boolean;
       begin
         { process all procs }
         hp:=procs;
@@ -1487,9 +1499,13 @@ type
            pt:=tcallparanode(left);
            while assigned(pt) and assigned(currpara) do
             begin
+              { currpt can be changed from loadn to calln when a procvar
+                is passed. This is to prevent that the change is permanent }
+              currpt:=pt;
+              releasecurrpt:=false;
               { retrieve current parameter definitions to compares }
               eq:=te_incompatible;
-              def_from:=pt.resulttype.def;
+              def_from:=currpt.resulttype.def;
               def_to:=currpara.paratype.def;
               if not(assigned(def_from)) then
                internalerror(200212091);
@@ -1500,18 +1516,29 @@ type
                     ) then
                internalerror(200212092);
 
+              { Convert tp procvars when not expecting a procvar }
+              if (def_to.deftype<>procvardef) and
+                 (currpt.left.resulttype.def.deftype=procvardef) then
+                begin
+                  releasecurrpt:=true;
+                  currpt:=tcallparanode(pt.getcopy);
+                  if maybe_call_procvar(currpt.left,true) then
+                    begin
+                      currpt.resulttype:=currpt.left.resulttype;
+                      def_from:=currpt.left.resulttype.def;
+                    end;
+                end;
+
               { varargs are always equal, but not exact }
               if (po_varargs in hp^.data.procoptions) and
                  (currparanr>hp^.data.minparacount) then
                begin
-                 inc(hp^.equal_count);
                  eq:=te_equal;
                end
               else
               { same definition -> exact }
                if (def_from=def_to) then
                 begin
-                  inc(hp^.exact_count);
                   eq:=te_exact;
                 end
               else
@@ -1522,7 +1549,6 @@ type
                   is_integer(def_to) and
                   is_in_limit(def_from,def_to) then
                  begin
-                   inc(hp^.equal_count);
                    eq:=te_equal;
                    hp^.ordinal_distance:=hp^.ordinal_distance+
                      abs(bestreal(torddef(def_from).low)-bestreal(torddef(def_to).low));
@@ -1536,7 +1562,7 @@ type
               else
               { generic type comparision }
                begin
-                 eq:=compare_defs_ext(def_from,def_to,pt.left.nodetype,convtype,pdoper,
+                 eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,
                                       [cdo_allow_variant,cdo_check_operator]);
 
                  { when the types are not equal we need to check
@@ -1550,32 +1576,39 @@ type
                         eq:=te_incompatible;
                         { var_para_allowed will return te_equal and te_convert_l1 to
                           make a difference for best matching }
-                        var_para_allowed(eq,pt.resulttype.def,currpara.paratype.def)
+                        var_para_allowed(eq,currpt.resulttype.def,currpara.paratype.def)
                       end
                     else
-                      para_allowed(eq,pt,def_to);
+                      para_allowed(eq,currpt,def_to);
                   end;
-
-                 case eq of
-                   te_exact :
-                     internalerror(200212071); { already checked }
-                   te_equal :
-                     inc(hp^.equal_count);
-                   te_convert_l1 :
-                     inc(hp^.cl1_count);
-                   te_convert_l2 :
-                     inc(hp^.cl2_count);
-                   te_convert_l3 :
-                     inc(hp^.cl3_count);
-                   te_convert_operator :
-                     inc(hp^.coper_count);
-                   te_incompatible :
-                     hp^.invalid:=true;
-                   else
-                     internalerror(200212072);
-                 end;
                end;
 
+              { when a procvar was changed to a call an exact much 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
+                eq:=te_equal;
+
+              { increase correct counter }
+              case eq of
+                te_exact :
+                  inc(hp^.exact_count);
+                te_equal :
+                  inc(hp^.equal_count);
+                te_convert_l1 :
+                  inc(hp^.cl1_count);
+                te_convert_l2 :
+                  inc(hp^.cl2_count);
+                te_convert_l3 :
+                  inc(hp^.cl3_count);
+                te_convert_operator :
+                  inc(hp^.coper_count);
+                te_incompatible :
+                  hp^.invalid:=true;
+                else
+                  internalerror(200212072);
+              end;
+
               { stop checking when an incompatible parameter is found }
               if hp^.invalid then
                begin
@@ -1591,6 +1624,10 @@ type
               currpara.eqval:=eq;
 {$endif EXTDEBUG}
 
+              { maybe release temp currpt }
+              if releasecurrpt then
+                currpt.free;
+
               { next parameter in the call tree }
               pt:=tcallparanode(pt.right);
 
@@ -2719,7 +2756,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.226  2004-02-19 17:07:42  florian
+  Revision 1.227  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.226  2004/02/19 17:07:42  florian
     * fixed arg. area calculation
 
   Revision 1.225  2004/02/13 15:42:21  peter

compiler/ncgcal.pas

@@ -88,7 +88,7 @@ implementation
 {$endif GDB}
       cgbase,pass_2,
       cpuinfo,aasmbase,aasmtai,
-      nbas,nmem,nld,ncnv,
+      nbas,nmem,nld,ncnv,nutils,
 {$ifdef x86}
       cga,cgx86,
 {$endif x86}
@@ -1210,7 +1210,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.154  2004-02-11 19:59:06  peter
+  Revision 1.155  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.154  2004/02/11 19:59:06  peter
     * fix compilation without GDB
 
   Revision 1.153  2004/02/09 22:48:45  florian

compiler/ncgmem.pas

@@ -93,7 +93,7 @@ implementation
       symconst,symdef,symsym,defutil,paramgr,
       aasmbase,aasmtai,
       procinfo,pass_2,
-      pass_1,nld,ncon,nadd,
+      pass_1,nld,ncon,nadd,nutils,
       cgobj,tgobj,ncgutil,symbase
       ;
 
@@ -881,7 +881,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.86  2004-02-03 22:32:54  peter
+  Revision 1.87  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.86  2004/02/03 22:32:54  peter
     * renamed xNNbittype to xNNinttype
     * renamed registers32 to registersint
     * replace some s32bit,u32bit with torddef([su]inttype).def.typ

compiler/ncnv.pas

@@ -202,7 +202,7 @@ implementation
       globtype,systems,tokens,
       cutils,verbose,globals,widestr,
       symconst,symdef,symsym,symtable,
-      ncon,ncal,nset,nadd,ninl,nmem,nmat,
+      ncon,ncal,nset,nadd,ninl,nmem,nmat,nutils,
       cgbase,procinfo,
       htypechk,pass_1,cpuinfo;
 
@@ -1141,6 +1141,12 @@ implementation
             exit;
           end;
 
+        { tp procvar support. Skip typecasts to record or set. Those
+          convert on the procvar value. This is used to access the
+          fields of a methodpointer }
+        if not(resulttype.def.deftype in [recorddef,setdef]) then
+          maybe_call_procvar(left,true);
+
         cdoptions:=[cdo_check_operator,cdo_allow_variant];
         if nf_explicit in flags then
           include(cdoptions,cdo_explicit);
@@ -1350,43 +1356,6 @@ implementation
         { Constant folding and other node transitions to
           remove the typeconv node }
         case left.nodetype of
-          loadn :
-            begin
-              { tp7 procvar support, when right is not a procvardef and we got a
-                loadn of a procvar (ignore procedures as void can not be converted)
-                then convert to a calln, the check for the result is already done
-                in is_convertible, also no conflict with @procvar is here because
-                that has an extra addrn.
-                The following deftypes always access the procvar: recorddef,setdef. This
-                has been tested with Kylix using trial and error }
-              if (m_tp_procvar in aktmodeswitches) and
-                 (resulttype.def.deftype<>procvardef) and
-                 { ignore internal typecasts to access methodpointer fields }
-                 not(resulttype.def.deftype in [recorddef,setdef]) and
-                 (left.resulttype.def.deftype=procvardef) and
-                 (not is_void(tprocvardef(left.resulttype.def).rettype.def)) then
-               begin
-                 hp:=ccallnode.create_procvar(nil,left);
-                 resulttypepass(hp);
-                 left:=hp;
-               end;
-            end;
-
-          calln :
-            begin
-              { See remark for loadn, this is the reverse }
-              if (m_tp_procvar in aktmodeswitches) and
-                 (resulttype.def.deftype in [recorddef,setdef]) and
-                 assigned(tcallnode(left).right) and
-                 (tcallnode(left).para_count=0) then
-               begin
-                 hp:=tcallnode(left).right.getcopy;
-                 resulttypepass(hp);
-                 left.free;
-                 left:=hp;
-               end;
-            end;
-
           niln :
             begin
               { nil to ordinal node }
@@ -2410,7 +2379,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.139  2004-02-13 15:42:21  peter
+  Revision 1.140  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.139  2004/02/13 15:42:21  peter
     * compare_defs_ext has now a options argument
     * fixes for variants
 

compiler/ninl.pas

@@ -74,7 +74,7 @@ implementation
       globtype, cutils,
       symbase,symconst,symdef,symsym,symtable,paramgr,defutil,defcmp,
       pass_1,
-      ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,
+      ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils,
       cgbase,procinfo
       ;
 
@@ -2374,7 +2374,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.131  2004-02-04 18:45:29  jonas
+  Revision 1.132  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.131  2004/02/04 18:45:29  jonas
     + some more usage of register temps
 
   Revision 1.130  2004/02/03 22:32:54  peter

compiler/nld.pas

@@ -133,14 +133,6 @@ interface
        crttinode : trttinodeclass;
 
 
-    procedure load_procvar_from_calln(var p1:tnode);
-    function load_high_value_node(vs:tvarsym):tnode;
-    function load_self_node:tnode;
-    function load_result_node:tnode;
-    function load_self_pointer_node:tnode;
-    function load_vmt_pointer_node:tnode;
-    function is_self_node(p:tnode):boolean;
-
 
 implementation
 
@@ -149,141 +141,10 @@ implementation
       symtable,symnot,
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
-      ncon,ninl,ncnv,nmem,ncal,cpubase,cgobj,cgbase
+      ncon,ninl,ncnv,nmem,ncal,nutils,
+      cpubase,cgobj,cgbase
       ;
 
-{*****************************************************************************
-                                 Helpers
-*****************************************************************************}
-
-      procedure load_procvar_from_calln(var p1:tnode);
-        var
-          p2 : tnode;
-        begin
-          if p1.nodetype<>calln then
-            internalerror(200212251);
-          { was it a procvar, then we simply remove the calln and
-            reuse the right }
-          if assigned(tcallnode(p1).right) then
-            begin
-              p2:=tcallnode(p1).right;
-              tcallnode(p1).right:=nil;
-            end
-          else
-            begin
-              p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
-                 tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
-              { when the methodpointer is typen we've something like:
-                tobject.create. Then only the address is needed of the
-                method without a self pointer }
-              if assigned(tcallnode(p1).methodpointer) and
-                 (tcallnode(p1).methodpointer.nodetype<>typen) then
-               begin
-                 tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
-                 tcallnode(p1).methodpointer:=nil;
-               end;
-            end;
-          resulttypepass(p2);
-          p1.free;
-          p1:=p2;
-        end;
-
-
-    function load_high_value_node(vs:tvarsym):tnode;
-      var
-        srsym : tsym;
-        srsymtable : tsymtable;
-      begin
-        result:=nil;
-        srsymtable:=vs.owner;
-        srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
-        if assigned(srsym) then
-          begin
-            result:=cloadnode.create(srsym,srsymtable);
-            resulttypepass(result);
-          end
-        else
-          CGMessage(cg_e_illegal_expression);
-      end;
-
-
-    function load_self_node:tnode;
-      var
-        srsym : tsym;
-        srsymtable : tsymtable;
-      begin
-        result:=nil;
-        searchsym('self',srsym,srsymtable);
-        if assigned(srsym) then
-          begin
-            result:=cloadnode.create(srsym,srsymtable);
-            resulttypepass(result);
-          end
-        else
-          CGMessage(cg_e_illegal_expression);
-      end;
-
-
-    function load_result_node:tnode;
-      var
-        srsym : tsym;
-        srsymtable : tsymtable;
-      begin
-        result:=nil;
-        searchsym('result',srsym,srsymtable);
-        if assigned(srsym) then
-          begin
-            result:=cloadnode.create(srsym,srsymtable);
-            resulttypepass(result);
-          end
-        else
-          CGMessage(cg_e_illegal_expression);
-      end;
-
-
-    function load_self_pointer_node:tnode;
-      var
-        srsym : tsym;
-        srsymtable : tsymtable;
-      begin
-        result:=nil;
-        searchsym('self',srsym,srsymtable);
-        if assigned(srsym) then
-          begin
-            result:=cloadnode.create(srsym,srsymtable);
-            include(result.flags,nf_load_self_pointer);
-            resulttypepass(result);
-          end
-        else
-          CGMessage(cg_e_illegal_expression);
-      end;
-
-
-    function load_vmt_pointer_node:tnode;
-      var
-        srsym : tsym;
-        srsymtable : tsymtable;
-      begin
-        result:=nil;
-        searchsym('vmt',srsym,srsymtable);
-        if assigned(srsym) then
-          begin
-            result:=cloadnode.create(srsym,srsymtable);
-            resulttypepass(result);
-          end
-        else
-          CGMessage(cg_e_illegal_expression);
-      end;
-
-
-    function is_self_node(p:tnode):boolean;
-      begin
-        is_self_node:=(p.nodetype=loadn) and
-                      (tloadnode(p).symtableentry.typ=varsym) and
-                      (vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
-      end;
-
-
 {*****************************************************************************
                              TLOADNODE
 *****************************************************************************}
@@ -656,6 +517,11 @@ implementation
         if codegenerror then
           exit;
 
+        { tp procvar support, when we don't expect a procvar
+          then we need to call the procvar }
+        if (left.resulttype.def.deftype<>procvardef) then
+          maybe_call_procvar(right,true);
+
         { assignments to formaldefs and open arrays aren't allowed }
         if (left.resulttype.def.deftype=formaldef) or
            is_open_array(left.resulttype.def) then
@@ -1256,7 +1122,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.122  2004-02-20 20:21:16  daniel
+  Revision 1.123  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.122  2004/02/20 20:21:16  daniel
     * Tarrayconstructornode sets pi_do_call if a call is possible
 
   Revision 1.121  2004/02/03 22:32:54  peter

compiler/nmem.pas

@@ -130,7 +130,7 @@ implementation
       globtype,systems,
       cutils,verbose,globals,
       symconst,symbase,defutil,defcmp,
-      nbas,
+      nbas,nutils,
       htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
       ;
 
@@ -516,6 +516,9 @@ implementation
          if codegenerror then
           exit;
 
+         { tp procvar support }
+         maybe_call_procvar(left,true);
+
          if left.resulttype.def.deftype=pointerdef then
           resulttype:=tpointerdef(left.resulttype.def).pointertype
          else
@@ -601,6 +604,8 @@ implementation
       begin
         result:=nil;
         resulttypepass(left);
+        { tp procvar support }
+        maybe_call_procvar(left,true);
         resulttype:=vs.vartype;
       end;
 
@@ -970,7 +975,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.79  2004-02-03 22:32:54  peter
+  Revision 1.80  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.79  2004/02/03 22:32:54  peter
     * renamed xNNbittype to xNNinttype
     * renamed registers32 to registersint
     * replace some s32bit,u32bit with torddef([su]inttype).def.typ

compiler/nutils.pas

@@ -27,7 +27,7 @@ unit nutils;
 interface
 
   uses
-    node;
+    symsym,node;
 
   type
     { resulttype of functions that process on all nodes in a (sub)tree }
@@ -50,6 +50,15 @@ interface
     function foreachnode(var n: tnode; f: foreachnodefunction): boolean;
     function foreachnodestatic(var n: tnode; f: staticforeachnodefunction): boolean;
 
+    procedure load_procvar_from_calln(var p1:tnode);
+    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
+    function load_high_value_node(vs:tvarsym):tnode;
+    function load_self_node:tnode;
+    function load_result_node:tnode;
+    function load_self_pointer_node:tnode;
+    function load_vmt_pointer_node:tnode;
+    function is_self_node(p:tnode):boolean;
+
     function call_fail_node:tnode;
     function initialize_data_node(p:tnode):tnode;
     function finalize_data_node(p:tnode):tnode;
@@ -58,8 +67,8 @@ interface
 implementation
 
     uses
-      verbose,
-      symconst,symsym,symtype,symdef,symtable,
+      globtype,globals,verbose,
+      symconst,symbase,symtype,symdef,symtable,
       nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,
       cgbase,procinfo,
       pass_1;
@@ -157,6 +166,167 @@ implementation
     end;
 
 
+    procedure load_procvar_from_calln(var p1:tnode);
+      var
+        p2 : tnode;
+      begin
+        if p1.nodetype<>calln then
+          internalerror(200212251);
+        { was it a procvar, then we simply remove the calln and
+          reuse the right }
+        if assigned(tcallnode(p1).right) then
+          begin
+            p2:=tcallnode(p1).right;
+            tcallnode(p1).right:=nil;
+          end
+        else
+          begin
+            p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
+               tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
+            { when the methodpointer is typen we've something like:
+              tobject.create. Then only the address is needed of the
+              method without a self pointer }
+            if assigned(tcallnode(p1).methodpointer) and
+               (tcallnode(p1).methodpointer.nodetype<>typen) then
+             begin
+               tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
+               tcallnode(p1).methodpointer:=nil;
+             end;
+          end;
+        resulttypepass(p2);
+        p1.free;
+        p1:=p2;
+      end;
+
+
+    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
+      var
+        hp : tnode;
+      begin
+        result:=false;
+        if (p1.resulttype.def.deftype<>procvardef) or
+           (tponly and
+            not(m_tp_procvar in aktmodeswitches)) then
+          exit;
+        { ignore vecn,subscriptn }
+        hp:=p1;
+        repeat
+          case hp.nodetype of
+            vecn,
+            derefn,
+            typeconvn,
+            subscriptn :
+              hp:=tunarynode(hp).left;
+            else
+              break;
+          end;
+        until false;
+        if (hp.nodetype=loadn) then
+          begin
+            hp:=ccallnode.create_procvar(nil,p1);
+            resulttypepass(hp);
+            p1:=hp;
+            result:=true;
+          end;
+      end;
+
+
+    function load_high_value_node(vs:tvarsym):tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        srsymtable:=vs.owner;
+        srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
+        if assigned(srsym) then
+          begin
+            result:=cloadnode.create(srsym,srsymtable);
+            resulttypepass(result);
+          end
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
+    function load_self_node:tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        searchsym('self',srsym,srsymtable);
+        if assigned(srsym) then
+          begin
+            result:=cloadnode.create(srsym,srsymtable);
+            resulttypepass(result);
+          end
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
+    function load_result_node:tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        searchsym('result',srsym,srsymtable);
+        if assigned(srsym) then
+          begin
+            result:=cloadnode.create(srsym,srsymtable);
+            resulttypepass(result);
+          end
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
+    function load_self_pointer_node:tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        searchsym('self',srsym,srsymtable);
+        if assigned(srsym) then
+          begin
+            result:=cloadnode.create(srsym,srsymtable);
+            include(result.flags,nf_load_self_pointer);
+            resulttypepass(result);
+          end
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
+    function load_vmt_pointer_node:tnode;
+      var
+        srsym : tsym;
+        srsymtable : tsymtable;
+      begin
+        result:=nil;
+        searchsym('vmt',srsym,srsymtable);
+        if assigned(srsym) then
+          begin
+            result:=cloadnode.create(srsym,srsymtable);
+            resulttypepass(result);
+          end
+        else
+          CGMessage(cg_e_illegal_expression);
+      end;
+
+
+    function is_self_node(p:tnode):boolean;
+      begin
+        is_self_node:=(p.nodetype=loadn) and
+                      (tloadnode(p).symtableentry.typ=varsym) and
+                      (vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
+      end;
+
+
+
     function call_fail_node:tnode;
       var
         para : tcallparanode;
@@ -254,7 +424,10 @@ end.
 
 {
   $Log$
-  Revision 1.9  2004-02-03 22:32:54  peter
+  Revision 1.10  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.9  2004/02/03 22:32:54  peter
     * renamed xNNbittype to xNNinttype
     * renamed registers32 to registersint
     * replace some s32bit,u32bit with torddef([su]inttype).def.typ

compiler/pdecvar.pas

@@ -48,7 +48,7 @@ implementation
        fmodule,
        { pass 1 }
        node,pass_1,
-       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,
+       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,nutils,
        { codegen }
        ncgutil,
        { parser }
@@ -725,9 +725,6 @@ implementation
                   Message(parser_e_absolute_only_one_var);
                 { parse the rest }
                 pt:=expr;
-                { transform a procvar calln to loadn }
-                if pt.nodetype=calln then
-                  load_procvar_from_calln(pt);
                 { check allowed absolute types }
                 if (pt.nodetype=stringconstn) or
                    (is_constcharnode(pt)) then
@@ -1117,7 +1114,7 @@ implementation
               { Align the offset where the union symtable is added }
               if (trecordsymtable(symtablestack).usefieldalignment=-1) then
                 usedalign:=used_align(maxalignment,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
-              else  
+              else
                 usedalign:=used_align(maxalignment,aktalignment.recordalignmin,aktalignment.recordalignmax);
               offset:=align(trecordsymtable(symtablestack).datasize,usedalign);
               trecordsymtable(symtablestack).datasize:=offset+unionsymtable.datasize;
@@ -1138,7 +1135,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.66  2004-02-17 15:57:49  peter
+  Revision 1.67  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.66  2004/02/17 15:57:49  peter
   - fix rtti generation for properties containing sl_vec
   - fix crash when overloaded operator is not available
   - fix record alignment for C style variant records

compiler/pexpr.pas

@@ -75,7 +75,7 @@ implementation
        symconst,symtable,symsym,defutil,defcmp,
        { pass 1 }
        pass_1,htypechk,
-       nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
+       nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
        { parser }
        scanner,
        pbase,pinline,
@@ -286,50 +286,6 @@ implementation
       end;
 
 
-    procedure check_tp_procvar(var p : tnode);
-      var
-         hp,
-         p1 : tnode;
-      begin
-         if (m_tp_procvar in aktmodeswitches) and
-            (token<>_ASSIGNMENT) and
-            (not got_addrn) and
-            (block_type=bt_body) then
-          begin
-            { ignore vecn,subscriptn }
-            hp:=p;
-            repeat
-              case hp.nodetype of
-                vecn :
-                  hp:=tvecnode(hp).left;
-                subscriptn :
-                  hp:=tsubscriptnode(hp).left;
-                else
-                  break;
-              end;
-            until false;
-            if (hp.nodetype=loadn) then
-               begin
-                  { get the resulttype of p }
-                  do_resulttypepass(p);
-                  { convert the procvar load to a call:
-                     - not expecting a procvar
-                     - the procvar does not get arguments, when it
-                       requires arguments the callnode will fail
-                       Note: When arguments were passed there was no loadn }
-                  if (getprocvardef=nil) and
-                     (p.resulttype.def.deftype=procvardef) and
-                     (tprocvardef(p.resulttype.def).minparacount=0) then
-                    begin
-                       p1:=ccallnode.create_procvar(nil,p);
-                       resulttypepass(p1);
-                       p:=p1;
-                    end;
-               end;
-          end;
-      end;
-
-
      function statement_syssym(l : longint) : tnode;
       var
         p1,p2,paras  : tnode;
@@ -471,16 +427,6 @@ implementation
               p1:=comp_expr(true);
               if not codegenerror then
                begin
-                 { With tp procvars we allways need to load a
-                   procvar when it is passed, but not when the
-                   callnode is inserted due a property or has
-                   arguments }
-                 if (m_tp_procvar in aktmodeswitches) and
-                    (p1.nodetype=calln) and
-                    (tcallnode(p1).para_count=0) and
-                    not(nf_isproperty in tcallnode(p1).flags) then
-                   load_procvar_from_calln(p1);
-
                  case p1.resulttype.def.deftype of
                    procdef, { procvar }
                    pointerdef,
@@ -1761,31 +1707,22 @@ implementation
 
                else
                  begin
-                 { is this a procedure variable ? }
-                   if assigned(p1.resulttype.def) then
-                    begin
-                      if (p1.resulttype.def.deftype=procvardef) then
-                       begin
-                         if assigned(getprocvardef) and
-                            equal_defs(p1.resulttype.def,getprocvardef) then
-                           again:=false
-                         else
-                           if (token=_LKLAMMER) or
-                              ((tprocvardef(p1.resulttype.def).maxparacount=0) and
-                               (not((token in [_ASSIGNMENT,_UNEQUAL,_EQUAL]))) and
-                               (not afterassignment) and
-                               (not in_args)) then
+                   { is this a procedure variable ? }
+                   if assigned(p1.resulttype.def) and
+                      (p1.resulttype.def.deftype=procvardef) then
+                     begin
+                       if assigned(getprocvardef) and
+                          equal_defs(p1.resulttype.def,getprocvardef) then
+                         again:=false
+                       else
+                         begin
+                           if try_to_consume(_LKLAMMER) then
                              begin
-                                if try_to_consume(_LKLAMMER) then
-                                  begin
-                                     p2:=parse_paras(false,false);
-                                     consume(_RKLAMMER);
-                                  end
-                                else
-                                  p2:=nil;
-                                p1:=ccallnode.create_procvar(p2,p1);
-                                { proc():= is never possible }
-                                if token=_ASSIGNMENT then
+                               p2:=parse_paras(false,false);
+                               consume(_RKLAMMER);
+                               p1:=ccallnode.create_procvar(p2,p1);
+                               { proc():= is never possible }
+                               if token=_ASSIGNMENT then
                                  begin
                                    Message(cg_e_illegal_expression);
                                    p1.free;
@@ -1793,14 +1730,12 @@ implementation
                                    again:=false;
                                  end;
                              end
-                         else
-                           again:=false;
-                       end
-                      else
-                       again:=false;
-                    end
+                           else
+                             again:=false;
+                         end;
+                     end
                    else
-                    again:=false;
+                     again:=false;
                   end;
              end;
            end; { while again }
@@ -2248,10 +2183,6 @@ implementation
         if (not assigned(p1.resulttype.def)) then
          do_resulttypepass(p1);
 
-        { tp7 procvar handling, but not if the next token
-          will be a := }
-        check_tp_procvar(p1);
-
         factor:=p1;
         check_tokenpos;
       end;
@@ -2387,7 +2318,6 @@ implementation
          if not assigned(p1.resulttype.def) then
           do_resulttypepass(p1);
          filepos:=akttokenpos;
-         check_tp_procvar(p1);
          if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
            afterassignment:=true;
          oldp1:=p1;
@@ -2489,7 +2419,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.149  2004-02-18 21:58:53  peter
+  Revision 1.150  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.149  2004/02/18 21:58:53  peter
     * constants are now parsed as 64bit for cpu64bit
 
   Revision 1.148  2004/02/17 23:36:40  daniel

compiler/pstatmnt.pas

@@ -941,16 +941,22 @@ implementation
               end;
 
              if p.nodetype=labeln then
-              begin
-                { the pointer to the following instruction }
-                { isn't a very clean way                   }
-                if token in endtokens then
-                  tlabelnode(p).left:=cnothingnode.create
-                else
-                  tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
-                { be sure to have left also resulttypepass }
-                resulttypepass(tlabelnode(p).left);
-              end;
+               begin
+                 { the pointer to the following instruction }
+                 { isn't a very clean way                   }
+                 if token in endtokens then
+                   tlabelnode(p).left:=cnothingnode.create
+                 else
+                   tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
+                 { be sure to have left also resulttypepass }
+                 resulttypepass(tlabelnode(p).left);
+               end
+             else
+               begin
+                 { change a load of a procvar to a call. this is also
+                   supported in fpc mode }
+                 maybe_call_procvar(p,false);
+               end;
 
              { blockn support because a read/write is changed into a blocknode }
              { with a separate statement for each read/write operation (JM)    }
@@ -1092,7 +1098,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.129  2004-02-03 22:32:54  peter
+  Revision 1.130  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.129  2004/02/03 22:32:54  peter
     * renamed xNNbittype to xNNinttype
     * renamed registers32 to registersint
     * replace some s32bit,u32bit with torddef([su]inttype).def.typ

compiler/symtable.pas

@@ -765,7 +765,7 @@ implementation
               [objectsymtable,parasymtable,localsymtable,staticsymtable])) then
           begin
            if (Errorcount<>0) or
-              (copy(p.name,1,3)='def') then
+              (sp_internal in tsym(p).symoptions) then
              exit;
            { do not claim for inherited private fields !! }
            if (Tsym(p).refs=0) and (tsym(p).owner.symtabletype=objectsymtable) then
@@ -1090,7 +1090,7 @@ implementation
         { Calc alignment needed for this record }
         if (usefieldalignment=-1) then
           varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
-        else  
+        else
           varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.recordalignmax);
         recordalignment:=max(recordalignment,varalignrecord);
       end;
@@ -1847,10 +1847,10 @@ implementation
                    end;
                  if (not assigned(topclass)) or
                     Tsym(srsym).is_visible_for_object(topclass) then
-                   begin 
+                   begin
                      searchsym:=true;
                      exit;
-                   end;  
+                   end;
                end;
              srsymtable:=srsymtable.next;
            end;
@@ -2427,7 +2427,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.138  2004-02-17 15:57:49  peter
+  Revision 1.139  2004-02-20 21:55:59  peter
+    * procvar cleanup
+
+  Revision 1.138  2004/02/17 15:57:49  peter
   - fix rtti generation for properties containing sl_vec
   - fix crash when overloaded operator is not available
   - fix record alignment for C style variant records