+ explicitly add constructors of parent class that do not appear in the

    current class, since constructors are not automatically inherited in
    Java
   o tprocdef.getcopy() implementation, which returns an (unfinished) copy
     of a tprocdef. Finalise by calling symcreat.finish_copied_procdef()
   o made it possible to specify an existing procdef as argument to
     read_proc(), in which case it won't try to parse a procedure declaration,
     but only a body and associate it with the passed procdef. This is
     required for the inherited constructor support, since we cannot generate
     a textual representation of inherited constructors that is guaranteed to
     parse in the context of the current unit (e.g., if they use types from
     a unit that is not in the uses clause of the current unit)
   o folded tprocsym.find_procdef_bypara_no_rettype() into
     Tprocsym.Find_procdef_bypara, by interpreting specifying nil as
     retdef as not having to check the return def (required to compare
     parent constructors with child constructors to see whether they
     match, since the returndef will always be the current class type)

git-svn-id: branches/jvmbackend@18488 -

compiler/pdecobj.pas

@@ -1376,7 +1376,10 @@ implementation
                 in Pascal (we cannot do it for classes implemented in Java, since
                 we obviously cannot add constructors to those) }
               if is_javaclass(current_structdef) then
-                maybe_add_public_default_java_constructor(tobjectdef(current_structdef));
+                begin
+                  add_missing_parent_constructors_intf(tobjectdef(current_structdef));
+                  maybe_add_public_default_java_constructor(tobjectdef(current_structdef));
+                end;
               { need method to hold the initialization code for typed constants? }
               if (target_info.system in systems_typed_constants_node_init) and
                  not is_any_interface_kind(current_structdef) then

compiler/pdecsub.pas

@@ -3121,6 +3121,13 @@ const
          begin
            fwpd:=tprocdef(tprocsym(currpd.procsym).ProcdefList[i]);
 
+           { can happen for internally generated routines }
+           if (fwpd=currpd) then
+             begin
+               result:=true;
+               exit;
+             end;
+
            { Skip overloaded definitions that are declared in other units }
            if fwpd.procsym<>currpd.procsym then
              continue;

compiler/psub.pas

@@ -69,7 +69,7 @@ interface
     { reads any routine in the implementation, or a non-method routine
       declaration in the interface (depending on whether or not parse_only is
       true) }
-    procedure read_proc(isclassmethod:boolean);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
 
     procedure generate_specialization_procs;
 
@@ -1668,7 +1668,7 @@ implementation
       end;
 
 
-    procedure read_proc(isclassmethod:boolean);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
       {
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
@@ -1696,8 +1696,11 @@ implementation
          current_genericdef:=nil;
          current_specializedef:=nil;
 
-         { parse procedure declaration }
-         pd:=parse_proc_dec(isclassmethod,old_current_structdef);
+         if not assigned(usefwpd) then
+           { parse procedure declaration }
+           pd:=parse_proc_dec(isclassmethod,old_current_structdef)
+         else
+           pd:=usefwpd;
 
          { set the default function options }
          if parse_only then
@@ -1725,16 +1728,19 @@ implementation
             pd.forwarddef:=false;
           end;
 
-         { parse the directives that may follow }
-         parse_proc_directives(pd,pdflags);
+         if not assigned(usefwpd) then
+           begin
+             { parse the directives that may follow }
+             parse_proc_directives(pd,pdflags);
 
-         { hint directives, these can be separated by semicolons here,
-           that needs to be handled here with a loop (PFV) }
-         while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
-          Consume(_SEMICOLON);
+             { hint directives, these can be separated by semicolons here,
+               that needs to be handled here with a loop (PFV) }
+             while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
+              Consume(_SEMICOLON);
 
-         { Set calling convention }
-         handle_calling_convention(pd);
+             { Set calling convention }
+             handle_calling_convention(pd);
+           end;
 
          { search for forward declarations }
          if not proc_add_definition(pd) then
@@ -1898,7 +1904,7 @@ implementation
               _PROCEDURE,
               _OPERATOR:
                 begin
-                  read_proc(is_classdef);
+                  read_proc(is_classdef,nil);
                   is_classdef:=false;
                 end;
               _EXPORTS:
@@ -1933,7 +1939,7 @@ implementation
                       begin
                         if is_classdef then
                           begin
-                            read_proc(is_classdef);
+                            read_proc(is_classdef,nil);
                             is_classdef:=false;
                           end
                         else
@@ -1984,7 +1990,7 @@ implementation
              _FUNCTION,
              _PROCEDURE,
              _OPERATOR :
-               read_proc(false);
+               read_proc(false,nil);
              else
                begin
                  case idtoken of

compiler/symcreat.pas

@@ -55,25 +55,28 @@ interface
 
       WARNING: save the scanner state before calling this routine, and restore
         when done. }
-  function str_parse_method_impl(str: ansistring; is_classdef: boolean):boolean;
+  function str_parse_method_impl(str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean;
 
 
   { in the JVM, constructors are not automatically inherited (so you can hide
     them). To emulate the Pascal behaviour, we have to automatically add
     all parent constructors to the current class as well.}
   procedure add_missing_parent_constructors_intf(obj: tobjectdef);
-//  procedure add_missing_parent_constructors_impl(obj: tobjectdef);
 
   { goes through all defs in st to add implementations for synthetic methods
     added earlier }
   procedure add_synthetic_method_implementations(st: tsymtable);
 
+
+  procedure finish_copied_procdef(var pd: tprocdef; const realname: string; newparentst: tsymtable; newstruct: tabstractrecorddef);
+
+
 implementation
 
   uses
-    verbose,systems,
+    cutils,verbose,systems,comphook,
     symtype,symsym,symtable,defutil,
-    pbase,pdecobj,psub,
+    pbase,pdecobj,pdecsub,psub,
     defcmp;
 
   procedure replace_scanner(const tempname: string; out sstate: tscannerstate);
@@ -132,11 +135,24 @@ implementation
     end;
 
 
-  function str_parse_method_impl(str: ansistring; is_classdef: boolean):boolean;
+  function str_parse_method_impl(str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean;
      var
        oldparse_only: boolean;
+       tmpstr: ansistring;
      begin
-      Message1(parser_d_internal_parser_string,str);
+      if ((status.verbosity and v_debug)<>0) then
+        begin
+           if assigned(usefwpd) then
+             Message1(parser_d_internal_parser_string,usefwpd.customprocname([pno_proctypeoption,pno_paranames,pno_noclassmarker,pno_noleadingdollar]))
+           else
+             begin
+               if is_classdef then
+                 tmpstr:='class '
+               else
+                 tmpstr:='';
+               Message1(parser_d_internal_parser_string,tmpstr+str);
+             end;
+        end;
       oldparse_only:=parse_only;
       parse_only:=false;
       result:=false;
@@ -145,7 +161,7 @@ implementation
       current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index);
       current_scanner.readtoken(false);
       { and parse it... }
-      read_proc(is_classdef);
+      read_proc(is_classdef,usefwpd);
       parse_only:=oldparse_only;
       result:=true;
      end;
@@ -155,58 +171,50 @@ implementation
     var
       parent: tobjectdef;
       def: tdef;
-      pd: tprocdef;
-      newpd,
-      parentpd: tprocdef;
+      parentpd,
+      childpd: tprocdef;
       i: longint;
       srsym: tsym;
       srsymtable: tsymtable;
-      isclassmethod: boolean;
-      str: ansistring;
-      sstate: tscannerstate;
     begin
-      if not assigned(obj.childof) then
+      if (oo_is_external in obj.objectoptions) or
+         not assigned(obj.childof) then
         exit;
-      sstate.valid:=false;
       parent:=obj.childof;
       { find all constructor in the parent }
       for i:=0 to tobjectsymtable(parent.symtable).deflist.count-1 do
         begin
           def:=tdef(tobjectsymtable(parent.symtable).deflist[i]);
           if (def.typ<>procdef) or
-             (tprocdef(def).proctypeoption<>potype_constructor) then
+             (tprocdef(def).proctypeoption<>potype_constructor) or
+             not is_visible_for_object(tprocdef(def),obj) then
             continue;
-          pd:=tprocdef(def);
+          parentpd:=tprocdef(def);
           { do we have this constructor too? (don't use
             search_struct_member/searchsym_in_class, since those will
             search parents too) }
-          if searchsym_in_record(obj,pd.procsym.name,srsym,srsymtable) then
+          if searchsym_in_record(obj,parentpd.procsym.name,srsym,srsymtable) then
             begin
               { there's a symbol with the same name, is it a constructor
                 with the same parameters? }
               if srsym.typ=procsym then
                 begin
-                  parentpd:=tprocsym(srsym).find_procdef_bytype_and_para(
-                    potype_constructor,pd.paras,tprocdef(def).returndef,
+                  childpd:=tprocsym(srsym).find_procdef_bytype_and_para(
+                    potype_constructor,parentpd.paras,nil,
                     [cpo_ignorehidden,cpo_ignoreuniv,cpo_openequalisexact]);
-                  if assigned(parentpd) then
+                  if assigned(childpd) then
                     continue;
                 end;
             end;
           { if we get here, we did not find it in the current objectdef ->
             add }
-          if not sstate.valid then
-            replace_scanner('parent_constructors_intf',sstate);
-          isclassmethod:=
-            (po_classmethod in tprocdef(pd).procoptions) and
-            not(tprocdef(pd).proctypeoption in [potype_constructor,potype_destructor]);
-          { + 'overload' for Delphi modes }
-          str:=tprocdef(pd).customprocname([pno_proctypeoption,pno_paranames,pno_noclassmarker,pno_noleadingdollar])+'overload;';
-          if not str_parse_method_dec(str,tprocdef(pd).proctypeoption,isclassmethod,obj,newpd) then
-            internalerror(2011032001);
-          newpd.synthetickind:=tsk_anon_inherited;
+          childpd:=tprocdef(parentpd.getcopy);
+          finish_copied_procdef(childpd,parentpd.procsym.realname,obj.symtable,obj);
+          exclude(childpd.procoptions,po_external);
+          include(childpd.procoptions,po_overload);
+          childpd.synthetickind:=tsk_anon_inherited;
+          include(obj.objectoptions,oo_has_constructor);
         end;
-      restore_scanner(sstate);
     end;
 
 
@@ -215,10 +223,11 @@ implementation
       str: ansistring;
       isclassmethod: boolean;
     begin
-      isclassmethod:=(po_classmethod in pd.procoptions);
-      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker,pno_noleadingdollar]);
-      str:=str+'begin inherited end;';
-      str_parse_method_impl(str,isclassmethod);
+      isclassmethod:=
+        (po_classmethod in pd.procoptions) and
+        not(pd.proctypeoption in [potype_constructor,potype_destructor]);
+      str:='begin inherited end;';
+      str_parse_method_impl(str,pd,isclassmethod);
     end;
 
 
@@ -238,10 +247,9 @@ implementation
       if (struct.typ=recorddef) and
          not assigned(struct.typesym) then
         internalerror(2011032812);
-      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker,pno_noleadingdollar]);
       { the inherited clone will already copy all fields in a shallow way ->
         copy records/regular arrays in a regular way }
-      str:=str+'begin result:=inherited;';
+      str:='begin clone:=inherited;';
       for i:=0 to struct.symtable.symlist.count-1 do
         begin
           sym:=tsym(struct.symtable.symlist[i]);
@@ -253,11 +261,11 @@ implementation
                   not is_dynamic_array(fsym.vardef)) or
                  ((fsym.vardef.typ=setdef) and
                   not is_smallset(fsym.vardef)) then
-                str:=str+struct.typesym.realname+'(result).'+fsym.realname+':='+fsym.realname+';';
+                str:=str+struct.typesym.realname+'(clone).'+fsym.realname+':='+fsym.realname+';';
             end;
         end;
       str:=str+'end;';
-      str_parse_method_impl(str,false);
+      str_parse_method_impl(str,pd,false);
     end;
 
 
@@ -277,9 +285,8 @@ implementation
       if (struct.typ=recorddef) and
          not assigned(struct.typesym) then
         internalerror(2011032811);
-      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker,pno_noleadingdollar]);
       { copy all fields }
-      str:=str+'begin ';
+      str:='begin ';
       for i:=0 to struct.symtable.symlist.count-1 do
         begin
           sym:=tsym(struct.symtable.symlist[i]);
@@ -290,7 +297,7 @@ implementation
             end;
         end;
       str:=str+'end;';
-      str_parse_method_impl(str,false);
+      str_parse_method_impl(str,pd,false);
     end;
 
 
@@ -299,10 +306,11 @@ implementation
       str: ansistring;
       isclassmethod: boolean;
     begin
-      isclassmethod:=(po_classmethod in pd.procoptions);
-      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker,pno_noleadingdollar]);
-      str:=str+'begin end;';
-      str_parse_method_impl(str,isclassmethod);
+      isclassmethod:=
+        (po_classmethod in pd.procoptions) and
+        not(pd.proctypeoption in [potype_constructor,potype_destructor]);
+      str:='begin end;';
+      str_parse_method_impl(str,pd,isclassmethod);
     end;
 
 
@@ -367,5 +375,57 @@ implementation
     end;
 
 
+  procedure finish_copied_procdef(var pd: tprocdef; const realname: string; newparentst: tsymtable; newstruct: tabstractrecorddef);
+    var
+      sym: tsym;
+      parasym: tparavarsym;
+      ps: tprocsym;
+      hdef: tdef;
+      stname: string;
+      i: longint;
+    begin
+      { associate the procdef with a procsym in the owner }
+      if not(pd.proctypeoption in [potype_class_constructor,potype_class_destructor]) then
+        stname:=upper(realname)
+      else
+        stname:=lower(realname);
+      sym:=tsym(newparentst.find(stname));
+      if assigned(sym) then
+        begin
+          if sym.typ<>procsym then
+            internalerror(2011040601);
+          ps:=tprocsym(sym);
+        end
+      else
+        begin
+          ps:=tprocsym.create(realname);
+          newparentst.insert(ps);
+        end;
+      pd.procsym:=ps;
+      pd.struct:=newstruct;
+      { in case of methods, replace the special parameter types with new ones }
+      if assigned(newstruct) then
+        begin
+          symtablestack.push(pd.parast);
+          for i:=0 to pd.paras.count-1 do
+            begin
+              parasym:=tparavarsym(pd.paras[i]);
+              if vo_is_self in parasym.varoptions then
+                begin
+                  if parasym.vardef.typ=classrefdef then
+                    parasym.vardef:=tclassrefdef.create(newstruct)
+                  else
+                    parasym.vardef:=newstruct;
+                end
+            end;
+          { also fix returndef in case of a constructor }
+          if pd.proctypeoption=potype_constructor then
+            pd.returndef:=newstruct;
+          symtablestack.pop(pd.parast);
+        end;
+      proc_add_definition(pd);
+    end;
+
+
 end.
 

compiler/symdef.pas

@@ -592,6 +592,14 @@ interface
           procedure deref;override;
           procedure derefimpl;override;
           function  GetSymtable(t:tGetSymtable):TSymtable;override;
+          { warnings:
+              * the symtablestack top has to be the symtable to which the copy
+                should be added
+              * getcopy does not create a finished/ready-to-use procdef; it
+                needs to be finalised afterwards by calling
+                symcreat.finish_copied_procdef() afterwards
+          }
+          function  getcopy: tstoreddef; override;
           function  GetTypeName : string;override;
           function  mangledname : string;
           procedure setmangledname(const s : string);
@@ -3988,6 +3996,94 @@ implementation
       end;
 
 
+    function tprocdef.getcopy: tstoreddef;
+      var
+        i : tcallercallee;
+        j : longint;
+        pvs : tparavarsym;
+      begin
+        result:=tprocdef.create(parast.symtablelevel);
+        tprocdef(result).returndef:=returndef;
+        tprocdef(result).returndefderef:=returndefderef;
+        tprocdef(result).parast:=tparasymtable.create(tprocdef(result),parast.symtablelevel);
+        for j:=0 to parast.symlist.count-1 do
+          begin
+            case tsym(parast.symlist[j]).typ of
+              paravarsym:
+                begin
+                  pvs:=tparavarsym(parast.symlist[j]);
+                  tprocdef(result).parast.insert(tparavarsym.create(
+                    pvs.realname,pvs.paranr,pvs.varspez,pvs.vardef,pvs.varoptions));
+                end;
+              else
+                internalerror(201160604);
+              end;
+          end;
+        tprocdef(result).savesize:=savesize;
+
+        tprocdef(result).proctypeoption:=proctypeoption;
+        tprocdef(result).proccalloption:=proccalloption;
+        tprocdef(result).procoptions:=procoptions;
+        tprocdef(result).callerargareasize:=callerargareasize;
+        tprocdef(result).calleeargareasize:=calleeargareasize;
+        tprocdef(result).maxparacount:=maxparacount;
+        tprocdef(result).minparacount:=minparacount;
+        if po_explicitparaloc in procoptions then
+          tprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
+        { recalculate parameter info }
+        tprocdef(result).has_paraloc_info:=callnoside;
+{$ifdef m68k}
+        tprocdef(result).exp_funcretloc:=exp_funcretloc;
+{$endif}
+        { don't copy mangled name, can be different }
+        tprocdef(result).messageinf:=messageinf;
+        if po_msgstr in procoptions then
+          tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
+        tprocdef(result).symoptions:=symoptions;
+        if assigned(deprecatedmsg) then
+          tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
+        { will have to be associated with appropriate procsym }
+        tprocdef(result).procsym:=nil;
+        tprocdef(result).aliasnames.concatListcopy(aliasnames);
+        if assigned(funcretsym) then
+          begin
+            if (funcretsym.owner=parast) then
+              begin
+                j:=parast.symlist.indexof(funcretsym);
+                if j<0 then
+                  internalerror(2011040606);
+                tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
+              end
+            else
+              internalerror(2011040605);
+          end;
+        { will have to be associated with a new struct }
+        tprocdef(result).struct:=nil;
+{$if defined(powerpc) or defined(m68k)}
+        tprocdef(result).libsym:=libsym;
+{$endif powerpc or m68k}
+        if assigned(resultname) then
+          tprocdef(result).resultname:=stringdup(resultname^);
+        if assigned(import_dll) then
+          tprocdef(result).import_dll:=stringdup(import_dll^);
+        if assigned(import_name) then
+          tprocdef(result).import_name:=stringdup(import_name^);
+        tprocdef(result).import_nr:=import_nr;
+        tprocdef(result).extnumber:=$ffff;
+{$ifdef i386}
+        tprocdef(result).fpu_used:=fpu_used;
+{$endif i386}
+        tprocdef(result).visibility:=visibility;
+        tprocdef(result).synthetickind:=synthetickind;
+        { we need a separate implementation for the copied def }
+        tprocdef(result).forwarddef:=true;
+        tprocdef(result).interfacedef:=true;
+
+        { create new paralist }
+        tprocdef(result).calcparas;
+      end;
+
+
     procedure tprocdef.buildderef;
       begin
          inherited buildderef;

compiler/symsym.pas

@@ -102,7 +102,6 @@ interface
           procedure deref;override;
           function find_procdef_bytype(pt:Tproctypeoption):Tprocdef;
           function find_bytype_parameterless(pt:Tproctypeoption):Tprocdef;
-          function find_procdef_bypara_no_rettype(para:TFPObjectList;cpoptions:tcompare_paras_options):Tprocdef;
           function find_procdef_bypara(para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
           function find_procdef_bytype_and_para(pt:Tproctypeoption;para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
           function find_procdef_byoptions(ops:tprocoptions): Tprocdef;
@@ -687,18 +686,13 @@ implementation
 
 
     function check_procdef_paras(pd:tprocdef;para:TFPObjectList;retdef:tdef;
-                                            cpoptions:tcompare_paras_options; checkrettype: boolean): tprocdef;
+                                            cpoptions:tcompare_paras_options): tprocdef;
       var
         eq: tequaltype;
       begin
         result:=nil;
-        if checkrettype then
-          begin
-            if assigned(retdef) then
-              eq:=compare_defs(retdef,pd.returndef,nothingn)
-            else
-              eq:=te_equal;
-          end
+        if assigned(retdef) then
+          eq:=compare_defs(retdef,pd.returndef,nothingn)
         else
           eq:=te_equal;
         if (eq>=te_equal) or
@@ -715,22 +709,6 @@ implementation
       end;
 
 
-    function tprocsym.find_procdef_bypara_no_rettype(para: TFPObjectList; cpoptions: tcompare_paras_options): Tprocdef;
-      var
-        i: longint;
-        pd: tprocdef;
-      begin
-        result:=nil;
-        for i:=0 to ProcdefList.Count-1 do
-          begin
-            pd:=tprocdef(ProcdefList[i]);
-            result:=check_procdef_paras(pd,para,nil,cpoptions,false);
-            if assigned(result) then
-              exit;
-          end;
-      end;
-
-
     function Tprocsym.Find_procdef_bypara(para:TFPObjectList;retdef:tdef;
                                             cpoptions:tcompare_paras_options):Tprocdef;
       var
@@ -741,7 +719,7 @@ implementation
         for i:=0 to ProcdefList.Count-1 do
           begin
             pd:=tprocdef(ProcdefList[i]);
-            result:=check_procdef_paras(pd,para,retdef,cpoptions,true);
+            result:=check_procdef_paras(pd,para,retdef,cpoptions);
             if assigned(result) then
               exit;
           end;
@@ -760,7 +738,7 @@ implementation
             pd:=tprocdef(ProcdefList[i]);
             if pd.proctypeoption=pt then
               begin
-                result:=check_procdef_paras(pd,para,retdef,cpoptions,true);
+                result:=check_procdef_paras(pd,para,retdef,cpoptions);
                 if assigned(result) then
                   exit;
               end;