* (class_)constructor/destructor_head() now also parses hints,

    handles modifiers and adds the procdefinition. This code was
    duplicated in several places (for objects and records)
  * properly handle introducing artificial class constructors
    (the manually constructed procdefs were wrong, now use
     str_parse_method_dec)

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

compiler/pdecobj.pas

@@ -35,8 +35,8 @@ interface
     { 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 class_constructor_head(astruct: tabstractrecorddef):tprocdef;
+    function class_destructor_head(astruct: tabstractrecorddef):tprocdef;
     function constructor_head:tprocdef;
     function destructor_head:tprocdef;
     procedure struct_property_dec(is_classproperty:boolean);
@@ -63,7 +63,31 @@ implementation
     var
       current_objectdef : tobjectdef absolute current_structdef;
 
-    function class_constructor_head:tprocdef;
+
+    procedure constr_destr_finish_head(pd: tprocdef; const astruct: tabstractrecorddef);
+      begin
+        case astruct.typ of
+          recorddef:
+            parse_record_proc_directives(pd);
+          objectdef:
+            parse_object_proc_directives(pd);
+          else
+            internalerror(2011040502);
+        end;
+        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(astruct.objectoptions,oo_has_virtual);
+
+        maybe_parse_hint_directives(pd);
+      end;
+
+
+    function class_constructor_head(astruct: tabstractrecorddef):tprocdef;
       var
         pd : tprocdef;
       begin
@@ -80,10 +104,11 @@ implementation
         if (pd.maxparacount>0) then
           Message(parser_e_no_paras_for_class_constructor);
         consume(_SEMICOLON);
-        include(current_structdef.objectoptions,oo_has_class_constructor);
+        include(astruct.objectoptions,oo_has_class_constructor);
         current_module.flags:=current_module.flags or uf_classinits;
         { no return value }
         pd.returndef:=voidtype;
+        constr_destr_finish_head(pd,astruct);
         result:=pd;
       end;
 
@@ -117,6 +142,7 @@ implementation
 {$else CPU64bitaddr}
           pd.returndef:=bool32type;
 {$endif CPU64bitaddr}
+        constr_destr_finish_head(pd,pd.struct);
         result:=pd;
       end;
 
@@ -179,7 +205,7 @@ implementation
       end;
 
 
-    function class_destructor_head:tprocdef;
+    function class_destructor_head(astruct: tabstractrecorddef):tprocdef;
       var
         pd : tprocdef;
       begin
@@ -195,10 +221,11 @@ implementation
         if (pd.maxparacount>0) then
           Message(parser_e_no_paras_for_class_destructor);
         consume(_SEMICOLON);
-        include(current_structdef.objectoptions,oo_has_class_destructor);
+        include(astruct.objectoptions,oo_has_class_destructor);
         current_module.flags:=current_module.flags or uf_classinits;
         { no return value }
         pd.returndef:=voidtype;
+        constr_destr_finish_head(pd,astruct);
         result:=pd;
       end;
 
@@ -225,6 +252,7 @@ implementation
         include(current_structdef.objectoptions,oo_has_destructor);
         { no return value }
         pd.returndef:=voidtype;
+        constr_destr_finish_head(pd,pd.struct);
         result:=pd;
       end;
 
@@ -765,25 +793,6 @@ 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
-              begin
-                pd.symoptions:=pd.symoptions+dummysymoptions;
-                pd.deprecatedmsg:=deprecatedmsg;
-              end
-            else
-              stringdispose(deprecatedmsg);
-          end;
-
       var
         oldparse_only: boolean;
       begin
@@ -879,20 +888,11 @@ implementation
               oldparse_only:=parse_only;
               parse_only:=true;
               if is_classdef then
-                result:=class_constructor_head
+                result:=class_constructor_head(current_structdef)
               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;
@@ -927,21 +927,11 @@ implementation
               oldparse_only:=parse_only;
               parse_only:=true;
               if is_classdef then
-                result:=class_destructor_head
+                result:=class_destructor_head(current_structdef)
               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;

compiler/pjvm.pas

@@ -60,6 +60,7 @@ implementation
         pd: tprocdef;
         topowner: tdefentry;
         i: longint;
+        sstate: symcreat.tscannerstate;
         needclassconstructor: boolean;
       begin
         { if there is at least one constructor for a class, do nothing (for
@@ -156,35 +157,12 @@ implementation
               end;
             if needclassconstructor then
               begin
-                { determine symtable level }
-                topowner:=obj;
-                while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable,localsymtable]) do
-                  topowner:=topowner.owner.defowner;
-                { name doesn't matter, so pick something that hopefully conflict }
-                ps:=tprocsym.create('$fpc_jvm_class_constructor');
-                obj.symtable.insert(ps);
-                { create procdef }
-                pd:=tprocdef.create(topowner.owner.symtablelevel+1);
-                { method of this objectdef }
-                pd.struct:=obj;
-                { associated procsym }
-                pd.procsym:=ps;
-                { constructor }
-                pd.proctypeoption:=potype_class_constructor;
-                { needs to be exported }
-                include(pd.procoptions,po_global);
-                { class constructor is a class method }
-                include(pd.procoptions,po_classmethod);
-                { empty body; proc entry code will add inits for class fields }
-                pd.synthetickind:=tsk_empty;
-                { private (= package visibility) }
-                pd.visibility:=vis_private;
-                { result type }
-                pd.returndef:=obj;
-                { calling convention, self, ... }
-                handle_calling_convention(pd);
-                { register forward declaration with procsym }
-                proc_add_definition(pd);
+                replace_scanner('custom_class_constructor',sstate);
+                if str_parse_method_dec('constructor fpc_jvm_class_constructor;',potype_class_constructor,true,obj,pd) then
+                  pd.synthetickind:=tsk_empty
+                else
+                  internalerror(2011040501);
+                restore_scanner(sstate);
               end;
           end;
       end;
@@ -199,14 +177,14 @@ implementation
         replace_scanner('record_jvm_helpers',sstate);
         { no override, because not supported in records; the parser will still
           accept "inherited" though }
-        if str_parse_method_dec('function clone: JLObject;',false,def,pd) then
+        if str_parse_method_dec('function clone: JLObject;',potype_function,false,def,pd) then
           pd.synthetickind:=tsk_jvm_clone
         else
           internalerror(2011032806);
         { can't use def.typesym, not yet set at this point }
         if def.symtable.realname^='' then
           internalerror(2011032803);
-        if str_parse_method_dec('procedure fpcDeepCopy(out result:'+def.symtable.realname^+');',false,def,pd) then
+        if str_parse_method_dec('procedure fpcDeepCopy(out result:'+def.symtable.realname^+');',potype_procedure,false,def,pd) then
           pd.synthetickind:=tsk_record_deepcopy
         else
           internalerror(2011032807);

compiler/ptype.pas

@@ -59,6 +59,9 @@ interface
       systems.systems_typed_constants_node_init) }
     procedure add_typedconst_init_routine(def: tabstractrecorddef);
 
+    { parse hint directives (platform, deprecated, ...) for a procdef }
+    procedure maybe_parse_hint_directives(pd:tprocdef);
+
 implementation
 
     uses
@@ -83,6 +86,26 @@ implementation
        pjvm;
 
 
+    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
+          begin
+            pd.symoptions:=pd.symoptions+dummysymoptions;
+            pd.deprecatedmsg:=deprecatedmsg;
+          end
+        else
+          stringdispose(deprecatedmsg);
+      end;
+
+
+
     procedure resolve_forward_types;
       var
         i: longint;
@@ -664,25 +687,6 @@ implementation
       end;
 
     procedure parse_record_members;
-
-        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
-            begin
-              pd.symoptions:=pd.symoptions+dummysymoptions;
-              pd.deprecatedmsg:=deprecatedmsg;
-            end
-          else
-            stringdispose(deprecatedmsg);
-        end;
-
       var
         pd : tprocdef;
         oldparse_only: boolean;
@@ -905,16 +909,9 @@ implementation
                 oldparse_only:=parse_only;
                 parse_only:=true;
                 if is_classdef then
-                  pd:=class_constructor_head
+                  pd:=class_constructor_head(current_structdef)
                 else
                   pd:=constructor_head;
-                parse_record_proc_directives(pd);
-                handle_calling_convention(pd);
-
-                { add definition to procsym }
-                proc_add_definition(pd);
-
-                maybe_parse_hint_directives(pd);
 
                 parse_only:=oldparse_only;
                 fields_allowed:=false;
@@ -932,16 +929,9 @@ implementation
                 oldparse_only:=parse_only;
                 parse_only:=true;
                 if is_classdef then
-                  pd:=class_destructor_head
+                  pd:=class_destructor_head(current_structdef)
                 else
                   pd:=destructor_head;
-                parse_record_proc_directives(pd);
-                handle_calling_convention(pd);
-
-                { add definition to procsym }
-                proc_add_definition(pd);
-
-                maybe_parse_hint_directives(pd);
 
                 parse_only:=oldparse_only;
                 fields_allowed:=false;
@@ -1817,13 +1807,13 @@ implementation
         { the class constructor }
         if not assigned(pd) then
           begin
-            if str_parse_method_dec('constructor fpc_init_typed_consts_class_constructor;',true,def,pd) then
+            if str_parse_method_dec('constructor fpc_init_typed_consts_class_constructor;',potype_class_constructor,true,def,pd) then
               pd.synthetickind:=tsk_empty
             else
               internalerror(2011040206);
           end;
         { the initialisation helper }
-        if str_parse_method_dec('procedure fpc_init_typed_consts_helper; static;',true,def,pd) then
+        if str_parse_method_dec('procedure fpc_init_typed_consts_helper; static;',potype_procedure,true,def,pd) then
           pd.synthetickind:=tsk_tcinit
         else
           internalerror(2011040207);

compiler/symcreat.pas

@@ -48,7 +48,7 @@ interface
 
     WARNING: save the scanner state before calling this routine, and restore
       when done. }
-  function str_parse_method_dec(str: ansistring; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean;
+  function str_parse_method_dec(str: ansistring; potype: tproctypeoption; 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
@@ -101,7 +101,7 @@ implementation
     end;
 
 
-  function str_parse_method_dec(str: ansistring; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean;
+  function str_parse_method_dec(str: ansistring; potype: tproctypeoption; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean;
     var
       oldparse_only: boolean;
     begin
@@ -114,7 +114,18 @@ implementation
       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);
+      case potype of
+        potype_class_constructor:
+          pd:=class_constructor_head(astruct);
+        potype_class_destructor:
+          pd:=class_destructor_head(astruct);
+        potype_constructor:
+          pd:=constructor_head;
+        potype_destructor:
+          pd:=destructor_head;
+        else
+          pd:=method_dec(astruct,is_classdef);
+      end;
       if assigned(pd) then
         result:=true;
       parse_only:=oldparse_only;
@@ -191,7 +202,7 @@ implementation
             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,isclassmethod,obj,newpd) then
+          if not str_parse_method_dec(str,tprocdef(pd).proctypeoption,isclassmethod,obj,newpd) then
             internalerror(2011032001);
           newpd.synthetickind:=tsk_anon_inherited;
         end;