* symcreat functionality to use the parser from inside the compiler for

    artificially generated stuff rather than directly working with defs/syms
   problems
    o scanner state saving/restoring, and avoiding problems in case of
      errors in the injected strings
    o in case of the actual application (adding overriding constructors):
      the parameters may be of types not visible in the current unit to
      newly written code -> can't just use the scanner...

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

.gitattributes

@@ -553,6 +553,7 @@ compiler/sparc/strinst.inc svneol=native#text/plain
 compiler/switches.pas svneol=native#text/plain
 compiler/symbase.pas svneol=native#text/plain
 compiler/symconst.pas svneol=native#text/plain
+compiler/symcreat.pas svneol=native#text/plain
 compiler/symdef.pas svneol=native#text/plain
 compiler/symnot.pas svneol=native#text/plain
 compiler/symsym.pas svneol=native#text/plain

compiler/pdecobj.pas

@@ -32,6 +32,9 @@ interface
     { parses a object declaration }
     function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef;helpertype:thelpertype) : tobjectdef;
 
+    { parses a (class) method declaration }
+    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
+
     function class_constructor_head:tprocdef;
     function class_destructor_head:tprocdef;
     function constructor_head:tprocdef;
@@ -43,7 +46,7 @@ implementation
     uses
       sysutils,cutils,
       globals,verbose,systems,tokens,
-      symbase,symsym,symtable,
+      symbase,symsym,symtable,symcreat,
       node,nld,nmem,ncon,ncnv,ncal,
       fmodule,scanner,
       pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,ppu
@@ -704,7 +707,8 @@ implementation
           message(parser_e_dispinterface_needs_a_guid);
       end;
 
-    procedure parse_object_members;
+
+    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
 
       procedure chkobjc(pd: tprocdef);
         begin
@@ -733,28 +737,195 @@ implementation
             { nothing currently }
           end;
 
+
         procedure maybe_parse_hint_directives(pd:tprocdef);
-        var
-          dummysymoptions : tsymoptions;
-          deprecatedmsg : pshortstring;
-        begin
-          dummysymoptions:=[];
-          deprecatedmsg:=nil;
-          while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
-            Consume(_SEMICOLON);
-          if assigned(pd) then
+          var
+            dummysymoptions : tsymoptions;
+            deprecatedmsg : pshortstring;
+          begin
+            dummysymoptions:=[];
+            deprecatedmsg:=nil;
+            while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
+              Consume(_SEMICOLON);
+            if assigned(pd) then
+              begin
+                pd.symoptions:=pd.symoptions+dummysymoptions;
+                pd.deprecatedmsg:=deprecatedmsg;
+              end
+            else
+              stringdispose(deprecatedmsg);
+          end;
+
+      var
+        oldparse_only: boolean;
+      begin
+        case token of
+          _PROCEDURE,
+          _FUNCTION:
             begin
-              pd.symoptions:=pd.symoptions+dummysymoptions;
-              pd.deprecatedmsg:=deprecatedmsg;
-            end
+              if (astruct.symtable.currentvisibility=vis_published) and
+                 not(oo_can_have_published in astruct.objectoptions) then
+                Message(parser_e_cant_have_published);
+
+              oldparse_only:=parse_only;
+              parse_only:=true;
+              result:=parse_proc_dec(is_classdef,astruct);
+
+              { this is for error recovery as well as forward }
+              { interface mappings, i.e. mapping to a method  }
+              { which isn't declared yet                      }
+              if assigned(result) then
+                begin
+                  parse_object_proc_directives(result);
+
+                  { check if dispid is set }
+                  if is_dispinterface(result.struct) and not (po_dispid in result.procoptions) then
+                    begin
+                      result.dispid:=tobjectdef(result.struct).get_next_dispid;
+                      include(result.procoptions, po_dispid);
+                    end;
+
+                  { all Macintosh Object Pascal methods are virtual.  }
+                  { this can't be a class method, because macpas mode }
+                  { has no m_class                                    }
+                  if (m_mac in current_settings.modeswitches) then
+                    include(result.procoptions,po_virtualmethod);
+
+                  { for record helpers only static class methods are allowed }
+                  if is_objectpascal_helper(astruct) and
+                     is_record(tobjectdef(astruct).extendeddef) and
+                     is_classdef and not (po_staticmethod in result.procoptions) then
+                    MessagePos(result.fileinfo,parser_e_class_methods_only_static_in_records);
+
+                  handle_calling_convention(result);
+
+                  { add definition to procsym }
+                  proc_add_definition(result);
+
+                  { add procdef options to objectdef options }
+                  if (po_msgint in result.procoptions) then
+                    include(astruct.objectoptions,oo_has_msgint);
+                  if (po_msgstr in result.procoptions) then
+                    include(astruct.objectoptions,oo_has_msgstr);
+                  if (po_virtualmethod in result.procoptions) then
+                    include(astruct.objectoptions,oo_has_virtual);
+
+                  chkcpp(result);
+                  chkobjc(result);
+                  chkjava(result);
+                end;
+
+              maybe_parse_hint_directives(result);
+
+              parse_only:=oldparse_only;
+            end;
+          _CONSTRUCTOR :
+            begin
+              if (astruct.symtable.currentvisibility=vis_published) and
+                not(oo_can_have_published in astruct.objectoptions) then
+                Message(parser_e_cant_have_published);
+
+              if not is_classdef and not(astruct.symtable.currentvisibility in [vis_public,vis_published]) then
+                Message(parser_w_constructor_should_be_public);
+
+              if is_interface(astruct) then
+                Message(parser_e_no_con_des_in_interfaces);
+
+              { Objective-C does not know the concept of a constructor }
+              if is_objc_class_or_protocol(astruct) then
+                Message(parser_e_objc_no_constructor_destructor);
+
+              if is_objectpascal_helper(astruct) then
+                if is_classdef then
+                  { class constructors are not allowed in class helpers }
+                  Message(parser_e_no_class_constructor_in_helpers)
+                else if is_record(tobjectdef(astruct).extendeddef) then
+                  { as long as constructors aren't allowed in records they
+                    aren't allowed in helpers either }
+                  Message(parser_e_no_constructor_in_records);
+
+              { only 1 class constructor is allowed }
+              if is_classdef and (oo_has_class_constructor in astruct.objectoptions) then
+                Message1(parser_e_only_one_class_constructor_allowed, astruct.objrealname^);
+
+              oldparse_only:=parse_only;
+              parse_only:=true;
+              if is_classdef then
+                result:=class_constructor_head
+              else
+                result:=constructor_head;
+              parse_object_proc_directives(result);
+              handle_calling_convention(result);
+
+              { add definition to procsym }
+              proc_add_definition(result);
+
+              { add procdef options to objectdef options }
+              if (po_virtualmethod in result.procoptions) then
+                include(astruct.objectoptions,oo_has_virtual);
+              chkcpp(result);
+              maybe_parse_hint_directives(result);
+
+              parse_only:=oldparse_only;
+            end;
+          _DESTRUCTOR :
+            begin
+              if (astruct.symtable.currentvisibility=vis_published) and
+                 not(oo_can_have_published in astruct.objectoptions) then
+                Message(parser_e_cant_have_published);
+
+              if not is_classdef then
+                if (oo_has_destructor in astruct.objectoptions) then
+                  Message(parser_n_only_one_destructor);
+
+              if is_interface(astruct) then
+                Message(parser_e_no_con_des_in_interfaces);
+
+              { (class) destructors are not allowed in class helpers }
+              if is_objectpascal_helper(astruct) then
+                Message(parser_e_no_destructor_in_records);
+
+              if not is_classdef and (astruct.symtable.currentvisibility<>vis_public) then
+                Message(parser_w_destructor_should_be_public);
+
+              { Objective-C does not know the concept of a destructor }
+              if is_objc_class_or_protocol(astruct) then
+                Message(parser_e_objc_no_constructor_destructor);
+
+              { only 1 class destructor is allowed }
+              if is_classdef and (oo_has_class_destructor in astruct.objectoptions) then
+                Message1(parser_e_only_one_class_destructor_allowed, astruct.objrealname^);
+
+              oldparse_only:=parse_only;
+              parse_only:=true;
+              if is_classdef then
+                result:=class_destructor_head
+              else
+                result:=destructor_head;
+              parse_object_proc_directives(result);
+              handle_calling_convention(result);
+
+              { add definition to procsym }
+              proc_add_definition(result);
+
+              { add procdef options to objectdef options }
+              if (po_virtualmethod in result.procoptions) then
+                include(astruct.objectoptions,oo_has_virtual);
+
+              chkcpp(result);
+              maybe_parse_hint_directives(result);
+
+              parse_only:=oldparse_only;
+            end;
           else
-            stringdispose(deprecatedmsg);
+            internalerror(2011032102);
         end;
+      end;
+
+
+    procedure parse_object_members;
 
       var
-        pd : tprocdef;
-        has_destructor,
-        oldparse_only,
         typedconstswritable: boolean;
         object_member_blocktype : tblock_type;
         fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean;
@@ -846,7 +1017,6 @@ implementation
           current_structdef.symtable.currentvisibility:=vis_published
         else
           current_structdef.symtable.currentvisibility:=vis_public;
-        has_destructor:=false;
         fields_allowed:=true;
         is_classdef:=false;
         class_fields:=false;
@@ -1003,168 +1173,11 @@ implementation
                 parse_class;
               end;
             _PROCEDURE,
-            _FUNCTION:
-              begin
-                if (current_structdef.symtable.currentvisibility=vis_published) and
-                   not(oo_can_have_published in current_structdef.objectoptions) then
-                  Message(parser_e_cant_have_published);
-
-                oldparse_only:=parse_only;
-                parse_only:=true;
-                pd:=parse_proc_dec(is_classdef,current_structdef);
-
-                { this is for error recovery as well as forward }
-                { interface mappings, i.e. mapping to a method  }
-                { which isn't declared yet                      }
-                if assigned(pd) then
-                  begin
-                    parse_object_proc_directives(pd);
-
-                    { check if dispid is set }
-                    if is_dispinterface(pd.struct) and not (po_dispid in pd.procoptions) then
-                      begin
-                        pd.dispid:=tobjectdef(pd.struct).get_next_dispid;
-                        include(pd.procoptions, po_dispid);
-                      end;
-
-                    { all Macintosh Object Pascal methods are virtual.  }
-                    { this can't be a class method, because macpas mode }
-                    { has no m_class                                    }
-                    if (m_mac in current_settings.modeswitches) then
-                      include(pd.procoptions,po_virtualmethod);
-
-                    { for record helpers only static class methods are allowed }
-                    if is_objectpascal_helper(current_structdef) and
-                        is_record(current_objectdef.extendeddef) and
-                        is_classdef and not (po_staticmethod in pd.procoptions) then
-                      MessagePos(pd.fileinfo, parser_e_class_methods_only_static_in_records);
-
-                    handle_calling_convention(pd);
-
-                    { add definition to procsym }
-                    proc_add_definition(pd);
-
-                    { add procdef options to objectdef options }
-                    if (po_msgint in pd.procoptions) then
-                      include(current_structdef.objectoptions,oo_has_msgint);
-                    if (po_msgstr in pd.procoptions) then
-                      include(current_structdef.objectoptions,oo_has_msgstr);
-                    if (po_virtualmethod in pd.procoptions) then
-                      include(current_structdef.objectoptions,oo_has_virtual);
-
-                    chkcpp(pd);
-                    chkobjc(pd);
-                    chkjava(pd);
-                  end;
-
-                maybe_parse_hint_directives(pd);
-
-                parse_only:=oldparse_only;
-                fields_allowed:=false;
-                is_classdef:=false;
-              end;
-            _CONSTRUCTOR :
-              begin
-                if (current_structdef.symtable.currentvisibility=vis_published) and
-                  not(oo_can_have_published in current_structdef.objectoptions) then
-                  Message(parser_e_cant_have_published);
-
-                if not is_classdef and not(current_structdef.symtable.currentvisibility in [vis_public,vis_published]) then
-                  Message(parser_w_constructor_should_be_public);
-
-                if is_interface(current_structdef) then
-                  Message(parser_e_no_con_des_in_interfaces);
-
-                { Objective-C does not know the concept of a constructor }
-                if is_objc_class_or_protocol(current_structdef) then
-                  Message(parser_e_objc_no_constructor_destructor);
-
-                if is_objectpascal_helper(current_structdef) then
-                  if is_classdef then
-                    { class constructors are not allowed in class helpers }
-                    Message(parser_e_no_class_constructor_in_helpers)
-                  else
-                  if is_record(current_objectdef.extendeddef) then
-                    { as long as constructors aren't allowed in records they
-                      aren't allowed in helpers either }
-                    Message(parser_e_no_constructor_in_records);
-
-                { only 1 class constructor is allowed }
-                if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
-                  Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
-
-                oldparse_only:=parse_only;
-                parse_only:=true;
-                if is_classdef then
-                  pd:=class_constructor_head
-                else
-                  pd:=constructor_head;
-                parse_object_proc_directives(pd);
-                handle_calling_convention(pd);
-
-                { add definition to procsym }
-                proc_add_definition(pd);
-
-                { add procdef options to objectdef options }
-                if (po_virtualmethod in pd.procoptions) then
-                  include(current_structdef.objectoptions,oo_has_virtual);
-                chkcpp(pd);
-                maybe_parse_hint_directives(pd);
-
-                parse_only:=oldparse_only;
-                fields_allowed:=false;
-                is_classdef:=false;
-              end;
+            _FUNCTION,
+            _CONSTRUCTOR,
             _DESTRUCTOR :
               begin
-                if (current_structdef.symtable.currentvisibility=vis_published) and
-                   not(oo_can_have_published in current_structdef.objectoptions) then
-                  Message(parser_e_cant_have_published);
-
-                if not is_classdef then
-                  if has_destructor then
-                    Message(parser_n_only_one_destructor)
-                  else
-                    has_destructor:=true;
-
-                if is_interface(current_structdef) then
-                  Message(parser_e_no_con_des_in_interfaces);
-
-                { (class) destructors are not allowed in class helpers }
-                if is_objectpascal_helper(current_structdef) then
-                  Message(parser_e_no_destructor_in_records);
-
-                if not is_classdef and (current_structdef.symtable.currentvisibility<>vis_public) then
-                  Message(parser_w_destructor_should_be_public);
-
-                { Objective-C does not know the concept of a destructor }
-                if is_objc_class_or_protocol(current_structdef) then
-                  Message(parser_e_objc_no_constructor_destructor);
-
-                { only 1 class destructor is allowed }
-                if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
-                  Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
-
-                oldparse_only:=parse_only;
-                parse_only:=true;
-                if is_classdef then
-                  pd:=class_destructor_head
-                else
-                  pd:=destructor_head;
-                parse_object_proc_directives(pd);
-                handle_calling_convention(pd);
-
-                { add definition to procsym }
-                proc_add_definition(pd);
-
-                { add procdef options to objectdef options }
-                if (po_virtualmethod in pd.procoptions) then
-                  include(current_structdef.objectoptions,oo_has_virtual);
-
-                chkcpp(pd);
-                maybe_parse_hint_directives(pd);
-
-                parse_only:=oldparse_only;
+                method_dec(current_structdef,is_classdef);
                 fields_allowed:=false;
                 is_classdef:=false;
               end;
@@ -1330,6 +1343,15 @@ implementation
 
             { parse and insert object members }
             parse_object_members;
+
+            { In Java, constructors are not automatically inherited (so you can
+              hide them). Emulate the Pascal behaviour for classes implemented
+              in Pascal (we cannot do it for classes implemented in Java, since
+              we obviously cannot add constructors to those) }
+            if is_javaclass(current_structdef) and
+               not(oo_is_external in current_structdef.objectoptions) then
+              add_missing_parent_constructors_intf(tobjectdef(current_structdef));
+
             symtablestack.pop(current_structdef.symtable);
           end;
 

compiler/pmodules.pas

@@ -36,7 +36,7 @@ implementation
        globtype,version,systems,tokens,
        cutils,cfileutl,cclasses,comphook,
        globals,verbose,fmodule,finput,fppu,
-       symconst,symbase,symtype,symdef,symsym,symtable,
+       symconst,symbase,symtype,symdef,symsym,symtable,symcreat,
        wpoinfo,
        aasmtai,aasmdata,aasmcpu,aasmbase,
        cgbase,cgobj,
@@ -1041,6 +1041,7 @@ implementation
         until false;
       end;
 
+
     procedure proc_unit;
 
       function is_assembler_generated:boolean;
@@ -1267,6 +1268,10 @@ implementation
              init_procinfo.parse_body;
              { save file pos for debuginfo }
              current_module.mainfilepos:=init_procinfo.entrypos;
+             { add implementations for synthetic method declarations added by
+               the compiler }
+             add_synthetic_method_implementations(current_module.globalsymtable);
+             add_synthetic_method_implementations(current_module.localsymtable);
            end;
 
          { Generate specializations of objectdefs methods }

compiler/psub.pas

@@ -66,6 +66,11 @@ interface
     { reads declarations in the interface part of a unit }
     procedure read_interface_declarations;
 
+    { 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 generate_specialization_procs;
 
 
@@ -81,7 +86,7 @@ implementation
        { aasm }
        cpuinfo,cpubase,aasmbase,aasmtai,aasmdata,
        { symtable }
-       symconst,symbase,symsym,symtype,symtable,defutil,
+       symconst,symbase,symsym,symtype,symtable,defutil,symcreat,
        paramgr,
        ppu,fmodule,
        { pass 1 }
@@ -1946,6 +1951,10 @@ implementation
            end;
          until false;
 
+         { add implementations for synthetic method declarations added by
+           the compiler }
+         add_synthetic_method_implementations(current_procinfo.procdef.localst);
+
          { check for incomplete class definitions, this is only required
            for fpc modes }
          if (m_fpc in current_settings.modeswitches) then

compiler/scanner.pas

@@ -78,8 +78,14 @@ interface
 
        tspecialgenerictoken = (ST_LOADSETTINGS,ST_LINE,ST_COLUMN,ST_FILEINDEX);
 
-       { tscannerfile }
+       tscannerstate = record
+         lasttokenpos: longint;
+         current_tokenpos,
+         current_filepos: tfileposinfo;
+         token: ttoken;
+       end;
 
+       { tscannerfile }
        tscannerfile = class
        private
          procedure do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo);
@@ -145,7 +151,12 @@ interface
           procedure nextfile;
           procedure addfile(hp:tinputfile);
           procedure reload;
-          procedure insertmacro(const macname:string;p:pchar;len,line,fileindex:longint);
+          { replaces current token with the text in p }
+          procedure substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint);
+          { inserts the text in p before the current token; the current token
+            will be restored afterwards }
+          procedure inserttext_begin(const macname: string; const str: ansistring; out scannerstate: tscannerstate);
+          procedure inserttext_end(const scannerstate: tscannerstate);
         { Scanner things }
           procedure gettokenpos;
           procedure inc_comment_level;
@@ -1753,7 +1764,7 @@ In case not, the value returned can be arbitrary.
             Message1(scan_w_include_env_not_found,path);
            { make it a stringconst }
            hs:=''''+hs+'''';
-           current_scanner.insertmacro(path,@hs[1],length(hs),
+           current_scanner.substitutemacro(path,@hs[1],length(hs),
             current_scanner.line_no,current_scanner.inputfile.ref_index);
          end
         else
@@ -2423,7 +2434,7 @@ In case not, the value returned can be arbitrary.
       end;
 
 
-    procedure tscannerfile.insertmacro(const macname:string;p:pchar;len,line,fileindex:longint);
+    procedure tscannerfile.substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint);
       var
         hp : tinputfile;
       begin
@@ -2454,6 +2465,35 @@ In case not, the value returned can be arbitrary.
       end;
 
 
+    procedure tscannerfile.inserttext_begin(const macname: string; const str: ansistring; out scannerstate: tscannerstate);
+      begin
+        if (nexttoken<>NOTOKEN) then
+          internalerror(2011032103);
+        scannerstate.lasttokenpos:=lasttokenpos;
+        scannerstate.token:=token;
+        scannerstate.current_tokenpos:=current_tokenpos;
+        scannerstate.current_filepos:=current_filepos;
+
+        current_scanner.substitutemacro(macname,@str[1],length(str),
+          current_scanner.line_no,current_scanner.inputfile.ref_index);
+        current_scanner.readtoken(false);
+      end;
+
+
+    procedure tscannerfile.inserttext_end(const scannerstate: tscannerstate);
+      begin
+        if nexttoken<>NOTOKEN then
+          internalerror(2011032104);
+        nexttoken:=token;
+        cachenexttokenpos;
+
+        lasttokenpos:=scannerstate.lasttokenpos;
+        token:=scannerstate.token;
+        current_tokenpos:=scannerstate.current_tokenpos;
+        current_filepos:=scannerstate.current_filepos;
+      end;
+
+
     procedure tscannerfile.do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo);
       begin
         tokenpos:=inputstart+(inputpointer-inputbuffer);
@@ -3539,7 +3579,7 @@ In case not, the value returned can be arbitrary.
                      begin
                        mac.is_used:=true;
                        inc(yylexcount);
-                       insertmacro(pattern,mac.buftext,mac.buflen,
+                       substitutemacro(pattern,mac.buftext,mac.buflen,
                          mac.fileinfo.line,mac.fileinfo.fileindex);
                      { handle empty macros }
                        if c=#0 then

compiler/symconst.pas

@@ -316,7 +316,9 @@ type
        up the stack will also remain balanced) }
     po_delphi_nested_cc,
     { Java method }
-    po_java
+    po_java,
+    { synthetic method, not parsed from source but inserted by compiler }
+    po_synthetic
   );
   tprocoptions=set of tprocoption;
 

compiler/symcreat.pas

@@ -0,0 +1,215 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    This unit provides helpers for creating new syms/defs based on string
+    representations.
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+{$i fpcdefs.inc}
+
+unit symcreat;
+
+interface
+
+  uses
+    finput,
+    symconst,symdef,symbase;
+
+  { 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);
+
+  { parses a (class or regular) method/constructor/destructor declaration from
+    str, as if it were declared in astruct's declaration body }
+  function str_parse_method_dec(str: ansistring; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean;
+
+  { parses a (class or regular)  method/constructor/destructor implementation
+    from str, as if it appeared in the current unit's implementation section }
+  function str_parse_method_impl(str: ansistring; is_classdef: boolean):boolean;
+
+  { goes through all defs in st to add implementations for synthetic methods
+    added earlier }
+  procedure add_synthetic_method_implementations(st: tsymtable);
+
+implementation
+
+  uses
+    verbose,systems,
+    tokens,scanner,
+    symtype,symsym,symtable,
+    pbase,pdecobj,psub,
+    defcmp;
+
+
+  function str_parse_method_dec(str: ansistring; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean;
+    var
+      oldparse_only: boolean;
+      scannerstate: tscannerstate;
+    begin
+      oldparse_only:=parse_only;
+      parse_only:=true;
+      result:=false;
+      { inject the string in the scanner }
+      str:=str+'end;';
+      current_scanner.substitutemacro('meth_head_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index);
+      current_scanner.readtoken(false);
+      { and parse it... }
+      pd:=method_dec(astruct,is_classdef);
+      if assigned(pd) then
+        begin
+          include(pd.procoptions,po_synthetic);
+          result:=true;
+        end;
+      parse_only:=oldparse_only;
+//      current_scanner.inserttext_end(scannerstate);
+    end;
+
+
+  function str_parse_method_impl(str: ansistring; is_classdef: boolean):boolean;
+     var
+       oldparse_only: boolean;
+       scannerstate: tscannerstate;
+     begin
+       str:=str+'end;';
+     (*
+       oldparse_only:=parse_only;
+       parse_only:=false;
+      { inject the string in the scanner }
+      current_scanner.inserttext_begin('meth_impl_macro',str,scannerstate);
+      dec(current_scanner.yylexcount);
+      read_proc(is_classdef);
+      parse_only:=oldparse_only;
+      result:=true;
+      current_scanner.inserttext_end(scannerstate);
+      *)
+     end;
+
+
+  procedure add_missing_parent_constructors_intf(obj: tobjectdef);
+    var
+      parent: tobjectdef;
+      psym: tprocsym;
+      def: tdef;
+      pd: tprocdef;
+      newpd,
+      parentpd: tprocdef;
+      i: longint;
+      srsym: tsym;
+      srsymtable: tsymtable;
+      isclassmethod: boolean;
+      str: ansistring;
+      old_scanner: tscannerfile;
+    begin
+      if not assigned(obj.childof) then
+        exit;
+      old_scanner:=nil;
+      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
+            continue;
+          pd:=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
+            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,
+                    [cpo_ignorehidden,cpo_ignoreuniv,cpo_openequalisexact]);
+                  if assigned(parentpd) then
+                    continue;
+                end;
+            end;
+          { if we get here, we did not find it in the current objectdef ->
+            add }
+          if not assigned(old_scanner) then
+            begin
+              old_scanner:=current_scanner;
+              current_scanner:=tscannerfile.Create('_Macro_.parent_constructors_intf');
+            end;
+          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])+'overload;';
+          if not str_parse_method_dec(str,isclassmethod,obj,newpd) then
+            internalerror(2011032001);
+          include(newpd.procoptions,po_synthetic);
+        end;
+      if assigned(old_scanner) then
+        begin
+          current_scanner.free;
+          current_scanner:=old_scanner;
+          current_scanner.readtoken(false);
+        end;
+    end;
+
+
+  procedure add_missing_parent_constructors_impl(obj: tobjectdef);
+    var
+      i: longint;
+      def: tdef;
+      str: ansistring;
+      isclassmethod: boolean;
+    begin
+      for i:=0 to tobjectsymtable(obj.symtable).deflist.count-1 do
+        begin
+          def:=tdef(tobjectsymtable(obj.symtable).deflist[i]);
+          if (def.typ<>procdef) or
+             not(po_synthetic in tprocdef(def).procoptions) then
+            continue;
+          isclassmethod:=
+            (po_classmethod in tprocdef(def).procoptions) and
+            not(tprocdef(def).proctypeoption in [potype_constructor,potype_destructor]);
+          str:=tprocdef(def).customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker]);
+          str:=str+'overload; begin inherited end;';
+          str_parse_method_impl(str,isclassmethod);
+        end;
+    end;
+
+
+  procedure add_synthetic_method_implementations(st: tsymtable);
+    var
+      i: longint;
+      def: tdef;
+    begin
+      { only necessary for the JVM target currently }
+      if not (target_info.system in [system_jvm_java32]) then
+        exit;
+      for i:=0 to st.deflist.count-1 do
+        begin
+          def:=tdef(st.deflist[i]);
+          if is_javaclass(def) and
+             not(oo_is_external in tobjectdef(def).objectoptions) then
+            add_missing_parent_constructors_impl(tobjectdef(def));
+        end;
+    end;
+
+
+end.
+

compiler/symdef.pas

@@ -3338,7 +3338,7 @@ implementation
                   first:=false;
                 end
                else
-                s:=s+',';
+                s:=s+';';
                if vo_is_hidden_para in hp.varoptions then
                  s:=s+'<';
                case hp.varspez of

compiler/symsym.pas

@@ -102,6 +102,7 @@ interface
           procedure deref;override;
           function find_procdef_bytype(pt:Tproctypeoption):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;
           function find_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
           function find_procdef_assignment_operator(fromdef,todef:tdef;var besteq:tequaltype):Tprocdef;
@@ -652,35 +653,67 @@ implementation
       end;
 
 
+    function check_procdef_paras(pd:tprocdef;para:TFPObjectList;retdef:tdef;
+                                            cpoptions:tcompare_paras_options): tprocdef;
+      var
+        eq: tequaltype;
+      begin
+        result:=nil;
+        if assigned(retdef) then
+          eq:=compare_defs(retdef,pd.returndef,nothingn)
+        else
+          eq:=te_equal;
+        if (eq>=te_equal) or
+           ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
+          begin
+            eq:=compare_paras(para,pd.paras,cp_value_equal_const,cpoptions);
+            if (eq>=te_equal) or
+               ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
+              begin
+                result:=pd;
+                exit;
+              end;
+          end;
+      end;
+
+
     function Tprocsym.Find_procdef_bypara(para:TFPObjectList;retdef:tdef;
                                             cpoptions:tcompare_paras_options):Tprocdef;
       var
         i  : longint;
         pd : tprocdef;
-        eq : tequaltype;
       begin
         result:=nil;
         for i:=0 to ProcdefList.Count-1 do
           begin
             pd:=tprocdef(ProcdefList[i]);
-            if assigned(retdef) then
-              eq:=compare_defs(retdef,pd.returndef,nothingn)
-            else
-              eq:=te_equal;
-            if (eq>=te_equal) or
-               ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
+            result:=check_procdef_paras(pd,para,retdef,cpoptions);
+            if assigned(result) then
+              exit;
+          end;
+      end;
+
+
+    function Tprocsym.find_procdef_bytype_and_para(pt:Tproctypeoption;
+               para:TFPObjectList;retdef:tdef;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]);
+            if pd.proctypeoption=pt then
               begin
-                eq:=compare_paras(para,pd.paras,cp_value_equal_const,cpoptions);
-                if (eq>=te_equal) or
-                   ((cpo_allowconvert in cpoptions) and (eq>te_incompatible)) then
-                  begin
-                    result:=pd;
-                    exit;
-                  end;
+                result:=check_procdef_paras(pd,para,retdef,cpoptions);
+                if assigned(result) then
+                  exit;
               end;
           end;
       end;
 
+
     function tprocsym.find_procdef_byoptions(ops: tprocoptions): Tprocdef;
       var
         i  : longint;