* wait till the end of typecheckpass before we load a call context's self

  parameter instead of immediately doing it in the constructor of the call
  node, and then only create it if we actually need it.

  It was previously created in the call node constructor because it needs to be
  done before pass_1 (which is where it is actually used) due to pass_1 possibly
  being performed in the context of inlining (and then a wrong self parameter
  may be found, or none at all), and it was done unconditionally because at that
  point we don't know yet whether or not a self parameter will be necessary (as
  we haven't resolved the overloads/procdef yet).

  The problem with this is that if we use the parentfpstruct way of handling
  accesses to outer scope locals/parameters, we need to know all locals/
  parameters that will be accessed from nested routines after typecheckpass,
  otherwise we get crashes. The problem was that if a call to an RTL routine was
  generated by the compiler in a routine nested inside a method during pass_1,
  and this nested routine itself did not access self of the method (so self was
  not added to its parentfpstruct during the typecheckpass), then the
  unconditional reference to self when creating the call caused a compiler
  crash (introduced in r30908)

git-svn-id: trunk@31197 -

.gitattributes

@@ -11278,6 +11278,7 @@ tests/test/jvm/tintstr.pp svneol=native#text/plain
 tests/test/jvm/tjavalowercaseproc.java svneol=native#text/plain
 tests/test/jvm/tjsetter.java svneol=native#text/plain
 tests/test/jvm/tlowercaseproc.pp svneol=native#text/plain
+tests/test/jvm/tnestcallpass1.pp svneol=native#text/plain
 tests/test/jvm/tnestdynarr.pp svneol=native#text/plain
 tests/test/jvm/tnestedset.pp svneol=native#text/plain
 tests/test/jvm/tnestproc.pp svneol=native#text/plain

compiler/ncal.pas

@@ -52,7 +52,9 @@ interface
          cnf_objc_processed,     { the procedure name has been set to the appropriate objc_msgSend* variant -> don't process again }
          cnf_objc_id_call,       { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
          cnf_unit_specified,     { the unit in which the procedure has to be searched has been specified }
-         cnf_call_never_returns  { information for the dfa that a subroutine never returns }
+         cnf_call_never_returns, { information for the dfa that a subroutine never returns }
+         cnf_call_self_node_done { the call_self_node has been generated if necessary
+                                   (to prevent it from potentially happening again in a wrong context in case of constant propagation or so) }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -69,6 +71,8 @@ interface
           function  gen_procvar_context_tree_self:tnode;
           function  gen_procvar_context_tree_parentfp:tnode;
           function  gen_self_tree:tnode;
+          function  use_caller_self(check_for_callee_self: boolean): boolean;
+          procedure maybe_gen_call_self_node;
           function  gen_vmt_tree:tnode;
           function gen_block_context:tnode;
           procedure gen_hidden_parameters;
@@ -1363,11 +1367,6 @@ implementation
          if assigned(current_structdef) and
             assigned(mp) then
            begin
-             { can't determine now yet if it will be necessary or not, so
-               always create it if there is a 'self' symbol in the current
-               context }
-             if get_local_or_para_sym('self')<>nil then
-               call_self_node:=load_self_node;
             { only needed when calling a destructor from an exception block in a
               contructor of a TP-style object }
             if is_object(current_structdef) and
@@ -2203,6 +2202,67 @@ implementation
         result:=selftree;
       end;
 
+    function tcallnode.use_caller_self(check_for_callee_self: boolean): boolean;
+      var
+        i: longint;
+        ps: tparavarsym;
+      begin
+        result:=false;
+        { is there a self parameter? }
+        if check_for_callee_self then
+          begin
+            ps:=nil;
+            for i:=0 to procdefinition.paras.count-1 do
+              begin
+                ps:=tparavarsym(procdefinition.paras[i]);
+                if vo_is_self in ps.varoptions then
+                  break;
+                ps:=nil;
+              end;
+
+            if not assigned(ps) then
+              exit;
+          end;
+
+        { we need to load the'self' parameter of the current routine as the
+          'self' parameter of the called routine if
+            1) we're calling an inherited routine
+            2) we're calling a constructor via type.constructorname and
+               type is not a classrefdef (i.e., we're calling a constructor like
+               a regular method)
+            3) we're calling any regular (non-class/non-static) method via
+               a typenode (the methodpointer is then that typenode, but the
+               passed self node must become the current self node)
+
+          In other cases, we either don't have to pass the 'self' parameter of
+          the current routine to the called one, or methodpointer will already
+          contain it (e.g. because a method was called via "method", in which
+          case the parser already passed 'self' as the method pointer, or via
+          "self.method") }
+        if (cnf_inherited in callnodeflags) or
+           ((procdefinition.proctypeoption=potype_constructor) and
+            not((methodpointer.resultdef.typ=classrefdef) or
+                (cnf_new_call in callnodeflags)) and
+               (methodpointer.nodetype=typen) and
+               (methodpointer.resultdef.typ=objectdef)) or
+           (assigned(methodpointer) and
+            (procdefinition.proctypeoption<>potype_constructor) and
+            not(po_classmethod in procdefinition.procoptions) and
+            not(po_staticmethod in procdefinition.procoptions) and
+            (methodpointer.nodetype=typen)) then
+          result:=true;
+      end;
+
+
+    procedure tcallnode.maybe_gen_call_self_node;
+      begin
+        if cnf_call_self_node_done in callnodeflags then
+          exit;
+        include(callnodeflags,cnf_call_self_node_done);
+        if use_caller_self(true) then
+          call_self_node:=load_self_node;
+      end;
+
 
     procedure tcallnode.register_created_object_types;
 
@@ -3674,6 +3734,8 @@ implementation
                parameters:=nil;
              end;
 
+         maybe_gen_call_self_node;
+
          if assigned(call_self_node) then
            typecheckpass(call_self_node);
          if assigned(call_vmt_node) then

tests/test/jvm/testall.bat

@@ -314,3 +314,5 @@ ppcjvm -O2 -g -B  -CTinitlocals tsetstring
 if %errorlevel% neq 0 exit /b %errorlevel%
 java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tsetstring
 if %errorlevel% neq 0 exit /b %errorlevel%
+ppcjvm -O2 -g -B  -Sa tnestcallpass1
+if %errorlevel% neq 0 exit /b %errorlevel%

tests/test/jvm/testall.sh

@@ -184,3 +184,4 @@ $PPC -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get
 java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a
 $PPC -O2 -g -B -Sa tsetstring
 java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tsetstring
+$PPC -O2 -g -B -Sa tnestcallpass1

tests/test/jvm/tnestcallpass1.pp

@@ -0,0 +1,31 @@
+{$mode delphi}
+
+program tnestcallpass1;
+
+type
+  tncp1_c = class
+    procedure test;
+  end;
+
+
+procedure tncp1_c.test;
+
+var
+  l: longint;
+
+  function nest(const s: unicodestring): longint;
+    begin
+      l:=5;
+      if length(s)=5 then
+        nest:=l
+      else
+        nest:=3;
+    end;
+
+begin
+  nest('abcdef');
+end;
+
+
+begin
+end.