* moved around/replaced the following procedures to stop nflw from depending

    on pdecsub (node units should not depend on parser units):
   o maybe_add_public_default_java_constructor()
   o handle_calling_convention()
   o create_finalizer_procdef() (replaced with create_outline_procdef())
   o insert_record_hidden_paras()
   o handle_calling_convention()
   o proc_add_definition()
   o build_parentfpstruct()
   o maybe_guarantee_record_typesym()
   o get_first_proc_str()
  * factored out the creation of a procinfo for a nested procdef based on a
    subnodetree of the current procdef into tprocinfo.create_for_outlining()

git-svn-id: trunk@40773 -

.gitattributes

@@ -650,6 +650,7 @@ compiler/ppcx64.lpi svneol=native#text/plain
 compiler/ppcx64llvm.lpi svneol=native#text/plain
 compiler/ppheap.pas svneol=native#text/plain
 compiler/ppu.pas svneol=native#text/plain
+compiler/procdefutil.pas svneol=native#text/plain
 compiler/procinfo.pas svneol=native#text/plain
 compiler/pstatmnt.pas svneol=native#text/plain
 compiler/psub.pas svneol=native#text/plain

compiler/i386/n386flw.pas

@@ -58,7 +58,7 @@ implementation
     symconst,symbase,symtable,symsym,symdef,
     cgbase,cgobj,cgcpu,cgutils,tgobj,
     cpubase,htypechk,
-    parabase,paramgr,pdecsub,pass_1,pass_2,ncgutil,cga,
+    parabase,paramgr,pass_1,pass_2,ncgutil,cga,
     aasmbase,aasmtai,aasmdata,aasmcpu,procinfo,cpupi;
 
   var
@@ -168,13 +168,7 @@ constructor ti386tryfinallynode.create(l, r: TNode);
       (df_generic in current_procinfo.procdef.defoptions)
       then
       exit;
-    finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
-    finalizepi.force_nested;
-    finalizepi.procdef:=create_finalizer_procdef;
-    finalizepi.entrypos:=r.fileinfo;
-    finalizepi.entryswitches:=r.localswitches;
-    finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
-    finalizepi.exitswitches:=current_settings.localswitches;
+    finalizepi:=tcgprocinfo(current_procinfo.create_for_outlining('$fin$',current_procinfo.procdef.struct,potype_exceptfilter,voidtype,r));
     { Regvar optimization for symbols is suppressed when using exceptions, but
       temps may be still placed into registers. This must be fixed. }
     foreachnodestatic(r,@reset_regvars,finalizepi);
@@ -196,13 +190,7 @@ constructor ti386tryfinallynode.create_implicit(l, r: TNode);
     if df_generic in current_procinfo.procdef.defoptions then
       InternalError(2013012501);
 
-    finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
-    finalizepi.force_nested;
-    finalizepi.procdef:=create_finalizer_procdef;
-    finalizepi.entrypos:=current_filepos;
-    finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
-    finalizepi.entryswitches:=r.localswitches;
-    finalizepi.exitswitches:=current_settings.localswitches;
+    finalizepi:=tcgprocinfo(current_procinfo.create_for_outlining('$fin$',current_procinfo.procdef.struct,potype_exceptfilter,voidtype,r));
     include(finalizepi.flags,pi_has_assembler_block);
     include(finalizepi.flags,pi_do_call);
     include(finalizepi.flags,pi_uses_exceptions);

compiler/jvm/jvmdef.pas

@@ -30,7 +30,7 @@ interface
     uses
       globtype,
       node,
-      symbase,symtype;
+      symbase,symtype,symdef;
 
     { returns whether a def can make use of an extra type signature (for
       Java-style generics annotations; not use for FPC-style generics or their
@@ -90,6 +90,10 @@ interface
       array }
     procedure jvmgetarraydimdef(arrdef: tdef; out eledef: tdef; out ndim: longint);
 
+    { the JVM specs require that you add a default parameterless
+      constructor in case the programmer hasn't specified any }
+    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
+
 
 implementation
 
@@ -97,7 +101,8 @@ implementation
     cutils,cclasses,constexp,
     verbose,systems,
     fmodule,
-    symtable,symconst,symsym,symdef,symcpu,symcreat,
+    symtable,symconst,symsym,symcpu,symcreat,
+    pparautl,
     defutil,paramgr;
 
 {******************************************************************
@@ -1024,4 +1029,135 @@ implementation
       end;
 
 
+
+{******************************************************************
+                   Adding extra methods
+*******************************************************************}
+    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
+      var
+        sym: tsym;
+        ps: tprocsym;
+        pd: tprocdef;
+        topowner: tdefentry;
+        i: longint;
+        sstate: tscannerstate;
+        needclassconstructor: boolean;
+      begin
+        ps:=nil;
+        { if there is at least one constructor for a class, do nothing (for
+           records, we'll always also need a parameterless constructor) }
+        if not is_javaclass(obj) or
+           not (oo_has_constructor in obj.objectoptions) then
+          begin
+            { check whether the parent has a parameterless constructor that we can
+              call (in case of a class; all records will derive from
+              java.lang.Object or a shim on top of that with a parameterless
+              constructor) }
+            if is_javaclass(obj) then
+              begin
+                pd:=nil;
+                { childof may not be assigned in case of a parser error }
+                if not assigned(tobjectdef(obj).childof) then
+                  exit;
+                sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
+                if assigned(sym) and
+                   (sym.typ=procsym) then
+                  pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+                if not assigned(pd) then
+                  begin
+                    Message(sym_e_no_matching_inherited_parameterless_constructor);
+                    exit
+                  end;
+              end;
+            { we call all constructors CREATE, because they don't have a name in
+              Java and otherwise we can't determine whether multiple overloads
+              are created with the same parameters }
+            sym:=tsym(obj.symtable.find('CREATE'));
+            if assigned(sym) then
+              begin
+                { does another, non-procsym, symbol already exist with that name? }
+                if (sym.typ<>procsym) then
+                  begin
+                    Message1(sym_e_duplicate_id_create_java_constructor,sym.realname);
+                    exit;
+                  end;
+                ps:=tprocsym(sym);
+                { is there already a parameterless function/procedure create? }
+                pd:=ps.find_bytype_parameterless(potype_function);
+                if not assigned(pd) then
+                  pd:=ps.find_bytype_parameterless(potype_procedure);
+                if assigned(pd) then
+                  begin
+                    Message1(sym_e_duplicate_id_create_java_constructor,pd.fullprocname(false));
+                    exit;
+                  end;
+              end;
+            if not assigned(sym) then
+              begin
+                ps:=cprocsym.create('Create');
+                obj.symtable.insert(ps);
+              end;
+            { determine symtable level }
+            topowner:=obj;
+            while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable]) do
+              topowner:=topowner.owner.defowner;
+            { create procdef }
+            pd:=cprocdef.create(topowner.owner.symtablelevel+1,true);
+            if df_generic in obj.defoptions then
+              include(pd.defoptions,df_generic);
+            { method of this objectdef }
+            pd.struct:=obj;
+            { associated procsym }
+            pd.procsym:=ps;
+            { constructor }
+            pd.proctypeoption:=potype_constructor;
+            { needs to be exported }
+            include(pd.procoptions,po_global);
+            { by default do not include this routine when looking for overloads }
+            include(pd.procoptions,po_ignore_for_overload_resolution);
+            { generate anonymous inherited call in the implementation }
+            pd.synthetickind:=tsk_anon_inherited;
+            { public }
+            pd.visibility:=vis_public;
+            { result type }
+            pd.returndef:=obj;
+            { calling convention, self, ... (not for advanced records, for those
+              this is handled later) }
+            if obj.typ=recorddef then
+              handle_calling_convention(pd,[hcc_declaration,hcc_check])
+            else
+              handle_calling_convention(pd,hcc_default_actions_intf);
+            { register forward declaration with procsym }
+            proc_add_definition(pd);
+          end;
+
+        { also add class constructor if class fields that need wrapping, and
+          if none was defined }
+        if obj.find_procdef_bytype(potype_class_constructor)=nil then
+          begin
+            needclassconstructor:=false;
+            for i:=0 to obj.symtable.symlist.count-1 do
+              begin
+                if (tsym(obj.symtable.symlist[i]).typ=staticvarsym) and
+                   jvmimplicitpointertype(tstaticvarsym(obj.symtable.symlist[i]).vardef) then
+                  begin
+                    needclassconstructor:=true;
+                    break;
+                  end;
+              end;
+            if needclassconstructor then
+              begin
+                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;
+
+
+
+
 end.

compiler/jvm/pjvm.pas

@@ -30,10 +30,6 @@ interface
       globtype,
       symconst,symtype,symbase,symdef,symsym;
 
-    { the JVM specs require that you add a default parameterless
-      constructor in case the programmer hasn't specified any }
-    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
-
     { records are emulated via Java classes. They require a default constructor
       to initialise temps, a deep copy helper for assignments, and clone()
       to initialse dynamic arrays }
@@ -56,138 +52,11 @@ implementation
     verbose,globals,systems,
     fmodule,
     parabase,aasmdata,
-    pdecsub,ngenutil,pparautl,
+    ngenutil,pparautl,
     symtable,symcreat,defcmp,jvmdef,symcpu,nobj,
     defutil,paramgr;
 
 
-    { the JVM specs require that you add a default parameterless
-      constructor in case the programmer hasn't specified any }
-    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
-      var
-        sym: tsym;
-        ps: tprocsym;
-        pd: tprocdef;
-        topowner: tdefentry;
-        i: longint;
-        sstate: tscannerstate;
-        needclassconstructor: boolean;
-      begin
-        ps:=nil;
-        { if there is at least one constructor for a class, do nothing (for
-           records, we'll always also need a parameterless constructor) }
-        if not is_javaclass(obj) or
-           not (oo_has_constructor in obj.objectoptions) then
-          begin
-            { check whether the parent has a parameterless constructor that we can
-              call (in case of a class; all records will derive from
-              java.lang.Object or a shim on top of that with a parameterless
-              constructor) }
-            if is_javaclass(obj) then
-              begin
-                pd:=nil;
-                { childof may not be assigned in case of a parser error }
-                if not assigned(tobjectdef(obj).childof) then
-                  exit;
-                sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
-                if assigned(sym) and
-                   (sym.typ=procsym) then
-                  pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
-                if not assigned(pd) then
-                  begin
-                    Message(sym_e_no_matching_inherited_parameterless_constructor);
-                    exit
-                  end;
-              end;
-            { we call all constructors CREATE, because they don't have a name in
-              Java and otherwise we can't determine whether multiple overloads
-              are created with the same parameters }
-            sym:=tsym(obj.symtable.find('CREATE'));
-            if assigned(sym) then
-              begin
-                { does another, non-procsym, symbol already exist with that name? }
-                if (sym.typ<>procsym) then
-                  begin
-                    Message1(sym_e_duplicate_id_create_java_constructor,sym.realname);
-                    exit;
-                  end;
-                ps:=tprocsym(sym);
-                { is there already a parameterless function/procedure create? }
-                pd:=ps.find_bytype_parameterless(potype_function);
-                if not assigned(pd) then
-                  pd:=ps.find_bytype_parameterless(potype_procedure);
-                if assigned(pd) then
-                  begin
-                    Message1(sym_e_duplicate_id_create_java_constructor,pd.fullprocname(false));
-                    exit;
-                  end;
-              end;
-            if not assigned(sym) then
-              begin
-                ps:=cprocsym.create('Create');
-                obj.symtable.insert(ps);
-              end;
-            { determine symtable level }
-            topowner:=obj;
-            while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable]) do
-              topowner:=topowner.owner.defowner;
-            { create procdef }
-            pd:=cprocdef.create(topowner.owner.symtablelevel+1,true);
-            if df_generic in obj.defoptions then
-              include(pd.defoptions,df_generic);
-            { method of this objectdef }
-            pd.struct:=obj;
-            { associated procsym }
-            pd.procsym:=ps;
-            { constructor }
-            pd.proctypeoption:=potype_constructor;
-            { needs to be exported }
-            include(pd.procoptions,po_global);
-            { by default do not include this routine when looking for overloads }
-            include(pd.procoptions,po_ignore_for_overload_resolution);
-            { generate anonymous inherited call in the implementation }
-            pd.synthetickind:=tsk_anon_inherited;
-            { public }
-            pd.visibility:=vis_public;
-            { result type }
-            pd.returndef:=obj;
-            { calling convention, self, ... (not for advanced records, for those
-              this is handled later) }
-            if obj.typ=recorddef then
-              handle_calling_convention(pd,[hcc_check])
-            else
-              handle_calling_convention(pd,hcc_all);
-            { register forward declaration with procsym }
-            proc_add_definition(pd);
-          end;
-
-        { also add class constructor if class fields that need wrapping, and
-          if none was defined }
-        if obj.find_procdef_bytype(potype_class_constructor)=nil then
-          begin
-            needclassconstructor:=false;
-            for i:=0 to obj.symtable.symlist.count-1 do
-              begin
-                if (tsym(obj.symtable.symlist[i]).typ=staticvarsym) and
-                   jvmimplicitpointertype(tstaticvarsym(obj.symtable.symlist[i]).vardef) then
-                  begin
-                    needclassconstructor:=true;
-                    break;
-                  end;
-              end;
-            if needclassconstructor then
-              begin
-                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;
-
-
     procedure add_java_default_record_methods_intf(def: trecorddef);
       var
         sstate: tscannerstate;

compiler/jvm/symcpu.pas

@@ -490,9 +490,9 @@ implementation
           begin
             { calling convention, self, ... }
             if obj.typ=recorddef then
-              handle_calling_convention(pd,[hcc_check])
+              handle_calling_convention(pd,[hcc_declaration,hcc_check])
             else
-              handle_calling_convention(pd,hcc_all);
+              handle_calling_convention(pd,hcc_default_actions_intf);
             { register forward declaration with procsym }
             proc_add_definition(pd);
           end;

compiler/ncgnstld.pas

@@ -59,7 +59,7 @@ implementation
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
       cpuinfo,
-      symconst,symbase,symsym,symdef,symtable,symcreat,
+      symconst,symbase,symsym,symdef,symtable,pparautl,symcreat,
       ncon,ninl,ncnv,nmem,ncal,nutils,nbas,
       pass_2,cgbase
       ;

compiler/ncgnstmm.pas

@@ -40,9 +40,9 @@ implementation
     uses
       systems,
       cutils,cclasses,verbose,globals,constexp,
-      symconst,symdef,symsym,symtable,symcreat,defutil,paramgr,
+      symconst,symdef,symsym,symtable,defutil,procdefutil,pparautl,symcreat,
       aasmbase,aasmtai,aasmdata,
-      procinfo,pass_2,parabase,
+      procinfo,pass_2,parabase,paramgr,
       pass_1,ncnv,nmem,nld,ncon,nadd,nutils,
       cgutils,cgobj,hlcgobj,
       tgobj,ncgutil,objcgutl

compiler/nflw.pas

@@ -29,7 +29,7 @@ interface
     uses
       cclasses,
       node,cpubase,
-      symtype,symbase,symdef,symsym,
+      symconst,symtype,symbase,symdef,symsym,
       optloop;
 
     type
@@ -197,7 +197,6 @@ interface
           function pass_1 : tnode;override;
           function simplify(forinline:boolean): tnode;override;
        protected
-          function create_finalizer_procdef: tprocdef;
           procedure adjust_estimated_stack_size; virtual;
        end;
        ttryfinallynodeclass = class of ttryfinallynode;
@@ -243,9 +242,8 @@ implementation
     uses
       globtype,systems,constexp,compinnr,
       cutils,verbose,globals,
-      symconst,symtable,paramgr,defcmp,defutil,htypechk,pass_1,
+      symtable,paramgr,defcmp,defutil,htypechk,pass_1,
       ncal,nadd,ncon,nmem,nld,ncnv,nbas,nutils,ninl,nset,ngenutil,
-      pdecsub,pparautl,
     {$ifdef state_tracking}
       nstate,
     {$endif}
@@ -2358,53 +2356,6 @@ implementation
      end;
 
 
-    var
-      seq: longint=0;
-
-    function ttryfinallynode.create_finalizer_procdef: tprocdef;
-      var
-        st:TSymTable;
-        checkstack: psymtablestackitem;
-        oldsymtablestack: tsymtablestack;
-        sym:tprocsym;
-      begin
-        { get actual procedure symtable (skip withsymtables, etc.) }
-        st:=nil;
-        checkstack:=symtablestack.stack;
-        while assigned(checkstack) do
-          begin
-            st:=checkstack^.symtable;
-            if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
-              break;
-            checkstack:=checkstack^.next;
-          end;
-        { Create a nested procedure, even from main_program_level.
-          Furthermore, force procdef and procsym into the same symtable
-          (by default, defs are registered with symtablestack.top which may be
-          something temporary like exceptsymtable - in that case, procdef can be
-          destroyed before procsym, leaving invalid pointers). }
-        oldsymtablestack:=symtablestack;
-        symtablestack:=nil;
-        result:=cprocdef.create(max(normal_function_level,st.symtablelevel)+1,true);
-        symtablestack:=oldsymtablestack;
-        st.insertdef(result);
-        result.struct:=current_procinfo.procdef.struct;
-        { tabstractprocdef constructor sets po_delphi_nested_cc whenever
-          nested procvars modeswitch is active. We must be independent of this switch. }
-        exclude(result.procoptions,po_delphi_nested_cc);
-        result.proctypeoption:=potype_exceptfilter;
-        handle_calling_convention(result);
-        sym:=cprocsym.create('$fin$'+tostr(seq));
-        st.insert(sym);
-        inc(seq);
-
-        result.procsym:=sym;
-        proc_add_definition(result);
-        result.forwarddef:=false;
-        result.aliasnames.insert(result.mangledname);
-      end;
-
-
     procedure ttryfinallynode.adjust_estimated_stack_size;
       begin
         inc(current_procinfo.estimatedtempsize,rec_jmp_buf.size);

compiler/pdecl.pas

@@ -310,7 +310,7 @@ implementation
                           parse_var_proc_directives(sym);
                        end;
                       { add default calling convention }
-                      handle_calling_convention(tabstractprocdef(hdef));
+                      handle_calling_convention(tabstractprocdef(hdef),hcc_default_actions_intf);
                     end;
                    if not skipequal then
                     begin
@@ -864,7 +864,7 @@ implementation
                                  Comment(V_Error,'Function references are not yet supported, only C blocks (add "cdecl;" at the end)');
                              end
                          end;
-                       handle_calling_convention(tprocvardef(hdef));
+                       handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
                        if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
                          consume(_SEMICOLON);
                      end;

compiler/pdecobj.pas

@@ -51,7 +51,7 @@ implementation
       fmodule,scanner,
       pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,pgenutil,pparautl,ppu
 {$ifdef jvm}
-      ,pjvm;
+      ,jvmdef,pjvm;
 {$else}
       ;
 {$endif}
@@ -75,12 +75,12 @@ implementation
               // we can't add hidden params here because record is not yet defined
               // and therefore record size which has influence on paramter passing rules may change too
               // look at record_dec to see where calling conventions are applied (issue #0021044)
-              handle_calling_convention(pd,[hcc_check]);
+              handle_calling_convention(pd,[hcc_declaration,hcc_check]);
             end;
           objectdef:
             begin
               parse_object_proc_directives(pd);
-              handle_calling_convention(pd);
+              handle_calling_convention(pd,hcc_default_actions_intf);
             end
           else
             internalerror(2011040502);
@@ -923,7 +923,7 @@ implementation
                      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);
+                  handle_calling_convention(result,hcc_default_actions_intf);
 
                   { add definition to procsym }
                   proc_add_definition(result);

compiler/pdecsub.pas

@@ -57,7 +57,6 @@ interface
 
     function  check_proc_directive(isprocvar:boolean):boolean;
 
-    function  proc_add_definition(var currpd:tprocdef):boolean;
     function  proc_get_importname(pd:tprocdef):string;
     procedure proc_set_mangledname(pd:tprocdef);
 
@@ -73,8 +72,6 @@ interface
     { parse a record method declaration (not a (class) constructor/destructor) }
     function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
 
-    procedure insert_record_hidden_paras(astruct: trecorddef);
-
     { helper functions - they insert nested objects hierarchy to the symtablestack
       with object hierarchy
     }
@@ -96,7 +93,7 @@ implementation
        { assembler }
        aasmbase,
        { symtable }
-       symbase,symcpu,symtable,defutil,defcmp,
+       symbase,symcpu,symtable,symutil,defutil,defcmp,
        { parameter handling }
        paramgr,cpupara,
        { pass 1 }
@@ -117,25 +114,6 @@ implementation
         Declaring it as string here results in an error when compiling (PFV) }
       current_procinfo = 'error';
 
-    { get_first_proc_str - returns the token string of the first option that
-      appears in the list }
-    function get_first_proc_str(Options: TProcOptions): ShortString;
-      var
-        X: TProcOption;
-      begin
-        if Options = [] then
-          InternalError(2018051700);
-
-        get_first_proc_str := '';
-
-        for X := Low(TProcOption) to High(TProcOption) do
-          if X in Options then
-            begin
-              get_first_proc_str := ProcOptionKeywords[X];
-              Exit;
-            end;
-      end;
-
     function push_child_hierarchy(obj:tabstractrecorddef):integer;
       var
         _class,hp : tobjectdef;
@@ -379,7 +357,7 @@ implementation
                   dummytype.free;
                end;
              { Add implicit hidden parameters and function result }
-             handle_calling_convention(pv);
+             handle_calling_convention(pv,hcc_default_actions_intf);
 {$ifdef jvm}
              { anonymous -> no name }
              jvm_create_procvar_class('',pv);
@@ -1711,7 +1689,7 @@ implementation
             // we can't add hidden params here because record is not yet defined
             // and therefore record size which has influence on paramter passing rules may change too
             // look at record_dec to see where calling conventions are applied (issue #0021044)
-            handle_calling_convention(result,[hcc_check]);
+            handle_calling_convention(result,[hcc_declaration,hcc_check]);
 
             { add definition to procsym }
             proc_add_definition(result);
@@ -1726,33 +1704,6 @@ implementation
       end;
 
 
-    procedure insert_record_hidden_paras(astruct: trecorddef);
-      var
-        pd: tdef;
-        i: longint;
-        oldpos : tfileposinfo;
-        oldparse_only: boolean;
-      begin
-        // handle calling conventions of record methods
-        oldpos:=current_filepos;
-        oldparse_only:=parse_only;
-        parse_only:=true;
-        { don't keep track of procdefs in a separate list, because the
-          compiler may add additional procdefs (e.g. property wrappers for
-          the jvm backend) }
-        for i := 0 to astruct.symtable.deflist.count - 1 do
-          begin
-            pd:=tdef(astruct.symtable.deflist[i]);
-            if pd.typ<>procdef then
-              continue;
-            current_filepos:=tprocdef(pd).fileinfo;
-            handle_calling_convention(tprocdef(pd),[hcc_insert_hidden_paras]);
-          end;
-        parse_only:=oldparse_only;
-        current_filepos:=oldpos;
-      end;
-
-
 {****************************************************************************
                         Procedure directive handlers
 ****************************************************************************}
@@ -2773,7 +2724,7 @@ const
       pooption : [po_virtualmethod];
       mutexclpocall : [pocall_internproc];
       mutexclpotype : [potype_class_constructor,potype_class_destructor];
-      mutexclpo     : [po_interrupt,po_exports,po_overridingmethod,po_inline,po_staticmethod]
+      mutexclpo     : PD_VIRTUAL_MUTEXCLPO
     ),(
       idtok:_CPPDECL;
       pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
@@ -3126,7 +3077,6 @@ const
       end;
 
 
-
     function proc_get_importname(pd:tprocdef):string;
       var
         dllname, importname : string;
@@ -3181,12 +3131,6 @@ const
       end;
 
 
-    procedure compilerproc_set_symbol_name(pd: tprocdef);
-      begin
-        pd.procsym.realname:='$'+lower(pd.procsym.name);
-      end;
-
-
     procedure proc_set_mangledname(pd:tprocdef);
       var
         s : string;
@@ -3210,7 +3154,7 @@ const
                       implementation that needs to match the original symbol
                       again -> immediately convert here }
                     if po_compilerproc in pd.procoptions then
-                      compilerproc_set_symbol_name(pd);
+                      pd.setcompilerprocname;
                   end
               end
             else
@@ -3405,474 +3349,4 @@ const
         parse_proc_directives(pd,pdflags);
       end;
 
-    function proc_add_definition(var currpd:tprocdef):boolean;
-
-
-      function check_generic_parameters(fwpd,currpd:tprocdef):boolean;
-        var
-          i : longint;
-          fwtype,
-          currtype : ttypesym;
-        begin
-          result:=true;
-          if fwpd.genericparas.count<>currpd.genericparas.count then
-            internalerror(2018090101);
-          for i:=0 to fwpd.genericparas.count-1 do
-            begin
-              fwtype:=ttypesym(fwpd.genericparas[i]);
-              currtype:=ttypesym(currpd.genericparas[i]);
-              if fwtype.name<>currtype.name then
-                begin
-                  messagepos1(currtype.fileinfo,sym_e_generic_type_param_mismatch,currtype.realname);
-                  messagepos1(fwtype.fileinfo,sym_e_generic_type_param_decl,fwtype.realname);
-                  result:=false;
-                end;
-            end;
-        end;
-
-
-      function equal_generic_procdefs(fwpd,currpd:tprocdef):boolean;
-        var
-          i : longint;
-          fwtype,
-          currtype : ttypesym;
-          foundretdef : boolean;
-        begin
-          result:=false;
-          if fwpd.genericparas.count<>currpd.genericparas.count then
-            exit;
-          { comparing generic declarations is a bit more cumbersome as the
-            defs of the generic parameter types are not equal, especially if the
-            declaration contains constraints; essentially we have two cases:
-            - proc declared in interface of unit (or in class/record/object)
-              and defined in implementation; here the fwpd might contain
-              constraints while currpd must only contain undefineddefs
-            - forward declaration in implementation }
-          foundretdef:=false;
-          for i:=0 to fwpd.genericparas.count-1 do
-            begin
-              fwtype:=ttypesym(fwpd.genericparas[i]);
-              currtype:=ttypesym(currpd.genericparas[i]);
-              { if the type in the currpd isn't a pure undefineddef, then we can
-                stop right there }
-              if (currtype.typedef.typ<>undefineddef) or (df_genconstraint in currtype.typedef.defoptions) then
-                exit;
-              if not foundretdef then
-                begin
-                  { if the returndef is the same as this parameter's def then this
-                    needs to be the case for both procdefs }
-                  foundretdef:=fwpd.returndef=fwtype.typedef;
-                  if foundretdef xor (currpd.returndef=currtype.typedef) then
-                    exit;
-                end;
-            end;
-          if compare_paras(fwpd.paras,currpd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv,cpo_generic])<>te_exact then
-            exit;
-          if not foundretdef then
-            begin
-              if (df_specialization in tstoreddef(fwpd.returndef).defoptions) and (df_specialization in tstoreddef(currpd.returndef).defoptions) then
-                { for specializations we're happy with equal defs instead of exactly the same defs }
-                result:=equal_defs(fwpd.returndef,currpd.returndef)
-              else
-                { the returndef isn't a type parameter, so compare as usual }
-                result:=compare_defs(fwpd.returndef,currpd.returndef,nothingn)=te_exact;
-            end
-          else
-            result:=true;
-        end;
-
-      {
-        Add definition aprocdef to the overloaded definitions of aprocsym. If a
-        forwarddef is found and reused it returns true
-      }
-      var
-        fwpd    : tprocdef;
-        currparasym,
-        fwparasym : tsym;
-        currparacnt,
-        fwparacnt,
-        curridx,
-        fwidx,
-        virtualdirinfo,
-        i       : longint;
-        po_comp : tprocoptions;
-        paracompopt: tcompare_paras_options;
-        forwardfound : boolean;
-        symentry: TSymEntry;
-        item : tlinkedlistitem;
-      begin
-        virtualdirinfo:=-1;
-        forwardfound:=false;
-
-        { check overloaded functions if the same function already exists }
-        for i:=0 to tprocsym(currpd.procsym).ProcdefList.Count-1 do
-         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;
-
-           { check the parameters, for delphi/tp it is possible to
-             leave the parameters away in the implementation (forwarddef=false).
-             But for an overload declared function this is not allowed }
-           if { check if empty implementation arguments match is allowed }
-              (
-               not(m_repeat_forward in current_settings.modeswitches) and
-               not(currpd.forwarddef) and
-               is_bareprocdef(currpd) and
-               not(po_overload in fwpd.procoptions)
-              ) or
-              (
-                fwpd.is_generic and
-                currpd.is_generic and
-                equal_generic_procdefs(fwpd,currpd)
-              ) or
-              { check arguments, we need to check only the user visible parameters. The hidden parameters
-                can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV)
-
-                don't check default values here, because routines that are the same except for their default
-                values should be reported as mismatches (since you can't overload based on different default
-                parameter values) }
-              (
-               (compare_paras(fwpd.paras,currpd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and
-               (compare_defs(fwpd.returndef,currpd.returndef,nothingn)=te_exact)
-              ) then
-             begin
-               { Check if we've found the forwarddef, if found then
-                 we need to update the forward def with the current
-                 implementation settings }
-               if fwpd.forwarddef then
-                 begin
-                   forwardfound:=true;
-
-                   if not(m_repeat_forward in current_settings.modeswitches) and
-                      (fwpd.proccalloption<>currpd.proccalloption) then
-                     paracompopt:=[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv]
-                   else
-                     paracompopt:=[cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv];
-
-                   { Check calling convention }
-                   if (fwpd.proccalloption<>currpd.proccalloption) then
-                    begin
-                      { In delphi it is possible to specify the calling
-                        convention in the interface or implementation if
-                        there was no convention specified in the other
-                        part }
-                      if (m_delphi in current_settings.modeswitches) then
-                        begin
-                          if not(po_hascallingconvention in currpd.procoptions) then
-                            currpd.proccalloption:=fwpd.proccalloption
-                          else
-                            if not(po_hascallingconvention in fwpd.procoptions) then
-                              fwpd.proccalloption:=currpd.proccalloption
-                          else
-                            begin
-                              MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
-                              tprocsym(currpd.procsym).write_parameter_lists(currpd);
-                              { restore interface settings }
-                              currpd.proccalloption:=fwpd.proccalloption;
-                            end;
-                        end
-                      else
-                        begin
-                          MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
-                          tprocsym(currpd.procsym).write_parameter_lists(currpd);
-                          { restore interface settings }
-                          currpd.proccalloption:=fwpd.proccalloption;
-                        end;
-                    end;
-
-                   { Check static }
-                   if (po_staticmethod in fwpd.procoptions) then
-                    begin
-                      if not (po_staticmethod in currpd.procoptions) then
-                       begin
-                         include(currpd.procoptions, po_staticmethod);
-                         if (po_classmethod in currpd.procoptions) then
-                          begin
-                           { remove self from the hidden paras }
-                           symentry:=currpd.parast.Find('self');
-                           if symentry<>nil then
-                            begin
-                              currpd.parast.Delete(symentry);
-                              currpd.calcparas;
-                            end;
-                          end;
-                       end;
-                    end;
-
-                   { Check if the procedure type and return type are correct,
-                     also the parameters must match also with the type and that
-                     if the implementation has default parameters, the interface
-                     also has them and that if they both have them, that they
-                     have the same value }
-                   if ((m_repeat_forward in current_settings.modeswitches) or
-                       not is_bareprocdef(currpd)) and
-                       (
-                         (
-                           fwpd.is_generic and
-                           currpd.is_generic and
-                           not equal_generic_procdefs(fwpd,currpd)
-                         ) or
-                         (
-                           (
-                             not fwpd.is_generic or
-                             not currpd.is_generic
-                           ) and
-                           (
-                             (compare_paras(fwpd.paras,currpd.paras,cp_all,paracompopt)<>te_exact) or
-                             (compare_defs(fwpd.returndef,currpd.returndef,nothingn)<>te_exact)
-                           )
-                         )
-                       ) then
-                     begin
-                       MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
-                                   fwpd.fullprocname(false));
-                       tprocsym(currpd.procsym).write_parameter_lists(currpd);
-                       break;
-                     end;
-
-                   { Check if both are declared forward }
-                   if fwpd.forwarddef and currpd.forwarddef then
-                    begin
-                      MessagePos1(currpd.fileinfo,parser_e_function_already_declared_public_forward,
-                                  currpd.fullprocname(false));
-                    end;
-
-                   { internconst or internproc only need to be defined once }
-                   if (fwpd.proccalloption=pocall_internproc) then
-                    currpd.proccalloption:=fwpd.proccalloption
-                   else
-                    if (currpd.proccalloption=pocall_internproc) then
-                     fwpd.proccalloption:=currpd.proccalloption;
-
-                   { Check procedure options, Delphi requires that class is
-                     repeated in the implementation for class methods }
-                   if (m_fpc in current_settings.modeswitches) then
-                     po_comp:=[po_classmethod,po_varargs,po_methodpointer,po_interrupt]
-                   else
-                     po_comp:=[po_classmethod,po_methodpointer];
-
-                   if ((po_comp * fwpd.procoptions)<>(po_comp * currpd.procoptions)) or
-                      (fwpd.proctypeoption <> currpd.proctypeoption) or
-                      { if the implementation version has an "overload" modifier,
-                        the interface version must also have it (otherwise we can
-                        get annoying crashes due to interface crc changes) }
-                      (not(po_overload in fwpd.procoptions) and
-                       (po_overload in currpd.procoptions)) then
-                     begin
-                       MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
-                                   fwpd.fullprocname(false));
-                       tprocsym(fwpd.procsym).write_parameter_lists(fwpd);
-                       { This error is non-fatal, we can recover }
-                     end;
-
-                   { Forward declaration is external? }
-                   if (po_external in fwpd.procoptions) then
-                     MessagePos(currpd.fileinfo,parser_e_proc_already_external);
-
-                   { check for conflicts with "virtual" if this is a virtual
-                     method, as "virtual" cannot be repeated in the
-                     implementation and hence does not get checked against }
-                   if (po_virtualmethod in fwpd.procoptions) then
-                     begin
-                       if virtualdirinfo=-1 then
-                         begin
-                           virtualdirinfo:=find_proc_directive_index(_VIRTUAL);
-                           if virtualdirinfo=-1 then
-                             internalerror(2018010101);
-                         end;
-                       po_comp := (proc_direcdata[virtualdirinfo].mutexclpo * currpd.procoptions);
-                       if po_comp<>[] then
-                         MessagePos2(currpd.fileinfo,parser_e_proc_dir_conflict,tokeninfo^[_VIRTUAL].str,get_first_proc_str(po_comp));
-                     end;
-                    { Check parameters }
-                   if (m_repeat_forward in current_settings.modeswitches) or
-                      (currpd.minparacount>0) then
-                    begin
-                      { If mangled names are equal then they have the same amount of arguments }
-                      { We can check the names of the arguments }
-                      { both symtables are in the same order from left to right }
-                      curridx:=0;
-                      fwidx:=0;
-                      currparacnt:=currpd.parast.SymList.Count;
-                      fwparacnt:=fwpd.parast.SymList.Count;
-                      repeat
-                        { skip default parameter constsyms }
-                        while (curridx<currparacnt) and
-                              (tsym(currpd.parast.SymList[curridx]).typ<>paravarsym) do
-                          inc(curridx);
-                        while (fwidx<fwparacnt) and
-                              (tsym(fwpd.parast.SymList[fwidx]).typ<>paravarsym) do
-                          inc(fwidx);
-                        { stop when one of the two lists is at the end }
-                        if (fwidx>=fwparacnt) or (curridx>=currparacnt) then
-                          break;
-                        { compare names of parameters, ignore implictly
-                          renamed parameters }
-                        currparasym:=tsym(currpd.parast.SymList[curridx]);
-                        fwparasym:=tsym(fwpd.parast.SymList[fwidx]);
-                        if not(sp_implicitrename in currparasym.symoptions) and
-                           not(sp_implicitrename in fwparasym.symoptions) then
-                          begin
-                            if (currparasym.name<>fwparasym.name) then
-                              begin
-                                MessagePos3(currpd.fileinfo,parser_e_header_different_var_names,
-                                            tprocsym(currpd.procsym).realname,fwparasym.realname,currparasym.realname);
-                                break;
-                              end;
-                          end;
-                        { next parameter }
-                        inc(curridx);
-                        inc(fwidx);
-                      until false;
-                    end;
-                   { check that the type parameter names for generic methods match;
-                     we check this here and not in equal_generic_procdefs as the defs
-                     might still be different due to their parameters, so we'd generate
-                     errors without any need }
-                   if currpd.is_generic and fwpd.is_generic then
-                     { an error here is recoverable, so we simply continue }
-                     check_generic_parameters(fwpd,currpd);
-                   { Everything is checked, now we can update the forward declaration
-                     with the new data from the implementation }
-                   fwpd.forwarddef:=currpd.forwarddef;
-                   fwpd.hasforward:=true;
-                   fwpd.procoptions:=fwpd.procoptions+currpd.procoptions;
-
-                   { marked as local but exported from unit? }
-                   if (po_kylixlocal in fwpd.procoptions) and (fwpd.owner.symtabletype=globalsymtable) then
-                     MessagePos(fwpd.fileinfo,type_e_cant_export_local);
-
-                   if fwpd.extnumber=$ffff then
-                     fwpd.extnumber:=currpd.extnumber;
-                   while not currpd.aliasnames.empty do
-                     fwpd.aliasnames.insert(currpd.aliasnames.getfirst);
-                   { update fileinfo so position references the implementation,
-                     also update funcretsym if it is already generated }
-                   fwpd.fileinfo:=currpd.fileinfo;
-                   if assigned(fwpd.funcretsym) then
-                     fwpd.funcretsym.fileinfo:=currpd.fileinfo;
-                   if assigned(currpd.deprecatedmsg) then
-                     begin
-                       stringdispose(fwpd.deprecatedmsg);
-                       fwpd.deprecatedmsg:=stringdup(currpd.deprecatedmsg^);
-                     end;
-                   { import names }
-                   if assigned(currpd.import_dll) then
-                     begin
-                       stringdispose(fwpd.import_dll);
-                       fwpd.import_dll:=stringdup(currpd.import_dll^);
-                     end;
-                   if assigned(currpd.import_name) then
-                     begin
-                       stringdispose(fwpd.import_name);
-                       fwpd.import_name:=stringdup(currpd.import_name^);
-                     end;
-                   fwpd.import_nr:=currpd.import_nr;
-                   { for compilerproc defines we need to rename and update the
-                     symbolname to lowercase so users can' access it (can't do
-                     it immediately, because then the implementation symbol
-                     won't be matched) }
-                   if po_compilerproc in fwpd.procoptions then
-                     begin
-                       compilerproc_set_symbol_name(fwpd);
-                       current_module.add_public_asmsym(fwpd.procsym.realname,AB_GLOBAL,AT_FUNCTION);
-                     end;
-                   if po_public in fwpd.procoptions then
-                     begin
-                       item:=fwpd.aliasnames.first;
-                       while assigned(item) do
-                         begin
-                           current_module.add_public_asmsym(TCmdStrListItem(item).str,AB_GLOBAL,AT_FUNCTION);
-                           item:=item.next;
-                         end;
-                     end;
-
-                   { Release current procdef }
-                   currpd.owner.deletedef(currpd);
-                   currpd:=fwpd;
-                 end
-               else
-                begin
-                  { abstract methods aren't forward defined, but this }
-                  { needs another error message                   }
-                  if (po_abstractmethod in fwpd.procoptions) then
-                    MessagePos(currpd.fileinfo,parser_e_abstract_no_definition)
-                  else
-                    begin
-                      MessagePos(currpd.fileinfo,parser_e_overloaded_have_same_parameters);
-                      tprocsym(currpd.procsym).write_parameter_lists(currpd);
-                    end;
-                 end;
-
-               { we found one proc with the same arguments, there are no others
-                 so we can stop }
-               break;
-             end;
-
-           { check for allowing overload directive }
-           if not(m_fpc in current_settings.modeswitches) then
-            begin
-              { overload directive turns on overloading }
-              if ((po_overload in currpd.procoptions) or
-                  (po_overload in fwpd.procoptions)) then
-               begin
-                 { check if all procs have overloading, but not if the proc is a method or
-                   already declared forward, then the check is already done }
-                 if not(fwpd.hasforward or
-                        assigned(currpd.struct) or
-                        (currpd.forwarddef<>fwpd.forwarddef) or
-                        ((po_overload in currpd.procoptions) and
-                         (po_overload in fwpd.procoptions))) then
-                  begin
-                    MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
-                    break;
-                  end
-               end
-              else
-               begin
-                 if not(fwpd.forwarddef) then
-                  begin
-                    if (m_tp7 in current_settings.modeswitches) then
-                      MessagePos(currpd.fileinfo,parser_e_procedure_overloading_is_off)
-                    else
-                      MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
-                    break;
-                  end;
-               end;
-            end; { equal arguments }
-         end;
-
-        { if we didn't reuse a forwarddef then we add the procdef to the overloaded
-          list }
-        if not forwardfound then
-          begin
-            { can happen in Delphi mode }
-            if (currpd.proctypeoption = potype_function) and
-               is_void(currpd.returndef) then
-              MessagePos1(currpd.fileinfo,parser_e_no_funcret_specified,currpd.procsym.realname);
-            tprocsym(currpd.procsym).ProcdefList.Add(currpd);
-            if not currpd.forwarddef and (po_public in currpd.procoptions) then
-              begin
-                item:=currpd.aliasnames.first;
-                while assigned(item) do
-                  begin
-                    current_module.add_public_asmsym(TCmdStrListItem(item).str,AB_GLOBAL,AT_FUNCTION);
-                    item:=item.next;
-                  end;
-              end;
-          end;
-
-        proc_add_definition:=forwardfound;
-      end;
-
 end.

compiler/pdecvar.pas

@@ -56,7 +56,7 @@ implementation
        globtype,globals,tokens,verbose,constexp,
        systems,
        { symtable }
-       symconst,symbase,defutil,defcmp,symcreat,
+       symconst,symbase,defutil,defcmp,symutil,symcreat,
 {$if defined(i386) or defined(i8086)}
        symcpu,
 {$endif}
@@ -260,7 +260,7 @@ implementation
             var
               sym: tprocsym;
             begin
-              handle_calling_convention(pd);
+              handle_calling_convention(pd,hcc_default_actions_intf);
               sym:=cprocsym.create(prefix+lower(p.realname));
               symtablestack.top.insert(sym);
               pd.procsym:=sym;
@@ -539,7 +539,7 @@ implementation
                       begin
                         readprocdef.returndef:=p.propdef;
                         { Insert hidden parameters }
-                        handle_calling_convention(readprocdef);
+                        handle_calling_convention(readprocdef,hcc_default_actions_intf);
                       end;
                     p.add_getter_or_setter_for_sym(palt_read,sym,def,readprocdef);
                   end;
@@ -562,7 +562,7 @@ implementation
                         hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
                         writeprocdef.parast.insert(hparavs);
                         { Insert hidden parameters }
-                        handle_calling_convention(writeprocdef);
+                        handle_calling_convention(writeprocdef,hcc_default_actions_intf);
                       end;
                     p.add_getter_or_setter_for_sym(palt_write,sym,def,writeprocdef);
                   end;
@@ -650,7 +650,7 @@ implementation
                                    end;
 
                                  { Insert hidden parameters }
-                                 handle_calling_convention(storedprocdef);
+                                 handle_calling_convention(storedprocdef,hcc_default_actions_intf);
                                  p.propaccesslist[palt_stored].procdef:=Tprocsym(sym).Find_procdef_bypara(storedprocdef.paras,storedprocdef.returndef,[cpo_allowdefaults,cpo_ignorehidden]);
                                  if not assigned(p.propaccesslist[palt_stored].procdef) then
                                    message(parser_e_ill_property_storage_sym);
@@ -1459,7 +1459,7 @@ implementation
                  { Add calling convention for procvar }
                  if (hdef.typ=procvardef) and
                     (hdef.typesym=nil) then
-                   handle_calling_convention(tprocvardef(hdef));
+                   handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
                  read_default_value(sc);
                  hasdefaultvalue:=true;
                end
@@ -1477,7 +1477,7 @@ implementation
                  { Parse procvar directives after ; }
                  maybe_parse_proc_directives(hdef);
                  { Add calling convention for procvar }
-                 handle_calling_convention(tprocvardef(hdef));
+                 handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
                  { Handling of Delphi typed const = initialized vars }
                  if (token=_EQ) and
                     not(m_tp7 in current_settings.modeswitches) and
@@ -1768,7 +1768,7 @@ implementation
              { Add calling convention for procvar }
              if (hdef.typ=procvardef) and
                 (hdef.typesym=nil) then
-               handle_calling_convention(tprocvardef(hdef));
+               handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
 
              if (vd_object in options) then
                begin

compiler/pgenutil.pas

@@ -1077,7 +1077,7 @@ uses
                         end;
                       if replaydepth>current_scanner.replay_stack_depth then
                         parse_var_proc_directives(ttypesym(srsym));
-                      handle_calling_convention(tprocvardef(result));
+                      handle_calling_convention(tprocvardef(result),hcc_default_actions_intf);
                       if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then
                         begin
                           try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
@@ -1095,7 +1095,10 @@ uses
                       parse_proc_directives(pd,pdflags);
                       while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
                         consume(_SEMICOLON);
-                      handle_calling_convention(tprocdef(result),hcc_all);
+                      if parse_generic then
+                        handle_calling_convention(tprocdef(result),hcc_default_actions_intf)
+                      else
+                        handle_calling_convention(tprocdef(result),hcc_default_actions_impl);
                       proc_add_definition(tprocdef(result));
                       { for partial specializations we implicitely declare the routine as
                         having its implementation although we'll not specialize it in reality }

compiler/pmodules.pas

@@ -676,7 +676,7 @@ implementation
           pd.proccalloption:=pocall_stdcall
         else
           pd.proccalloption:=pocall_cdecl;
-        handle_calling_convention(pd);
+        handle_calling_convention(pd,hcc_default_actions_impl);
         { set procinfo and current_procinfo.procdef }
         result:=tcgprocinfo(cprocinfo.create(nil));
         result.procdef:=pd;

compiler/pparautl.pas

@@ -26,7 +26,7 @@ unit pparautl;
 interface
 
     uses
-      symdef;
+      symconst,symdef;
 
     procedure insert_funcret_para(pd:tabstractprocdef);
     procedure insert_parentfp_para(pd:tabstractprocdef);
@@ -34,25 +34,43 @@ interface
     procedure insert_funcret_local(pd:tprocdef);
     procedure insert_hidden_para(p:TObject;arg:pointer);
     procedure check_c_para(pd:Tabstractprocdef);
+    procedure insert_record_hidden_paras(astruct: trecorddef);
 
-  type
-    // flags of handle_calling_convention routine
-    thccflag=(
-      hcc_check,                // perform checks and outup errors if found
-      hcc_insert_hidden_paras   // insert hidden parameters
-    );
-    thccflags=set of thccflag;
-  const
-    hcc_all=[hcc_check,hcc_insert_hidden_paras];
+    type
+      // flags of the *handle_calling_convention routines
+      thccflag=(
+        hcc_declaration,          // declaration (as opposed to definition, i.e. interface rather than implementation)
+        hcc_check,                // perform checks and outup errors if found
+        hcc_insert_hidden_paras   // insert hidden parameters
+      );
+      thccflags=set of thccflag;
 
-    procedure handle_calling_convention(pd:tabstractprocdef;flags:thccflags=hcc_all);
+    const
+      hcc_default_actions_intf=[hcc_declaration,hcc_check,hcc_insert_hidden_paras];
+      hcc_default_actions_impl=[hcc_check,hcc_insert_hidden_paras];
+      hcc_default_actions_parse=[hcc_check,hcc_insert_hidden_paras];
+      PD_VIRTUAL_MUTEXCLPO = [po_interrupt,po_exports,po_overridingmethod,po_inline,po_staticmethod];
+
+    procedure handle_calling_convention(pd:tabstractprocdef;flags:thccflags);
+    function proc_add_definition(var currpd:tprocdef):boolean;
+
+    { create "parent frame pointer" record skeleton for procdef, in which local
+      variables and parameters from pd accessed from nested routines can be
+      stored }
+    procedure build_parentfpstruct(pd: tprocdef);
 
 implementation
 
     uses
-      globals,globtype,verbose,systems,
-      symconst,symtype,symbase,symsym,symtable,symcreat,defutil,blockutl,
-      pbase,paramgr;
+      globals,globtype,cclasses,cutils,verbose,systems,fmodule,
+      tokens,
+      symtype,symbase,symsym,symtable,symutil,defutil,defcmp,blockutl,
+{$ifdef jvm}
+      jvmdef,
+{$endif jvm}
+      node,nbas,
+      aasmbase,
+      paramgr;
 
 
     procedure insert_funcret_para(pd:tabstractprocdef);
@@ -140,8 +158,8 @@ implementation
               begin
                 if not assigned(tprocdef(pd.owner.defowner).parentfpstruct) then
                   build_parentfpstruct(tprocdef(pd.owner.defowner));
-                vs:=cparavarsym.create('$parentfp',paranr,vs_value
-                      ,tprocdef(pd.owner.defowner).parentfpstructptrtype,[vo_is_parentfp,vo_is_hidden_para]);
+                vs:=cparavarsym.create('$parentfp',paranr,vs_value,
+                      tprocdef(pd.owner.defowner).parentfpstructptrtype,[vo_is_parentfp,vo_is_hidden_para]);
               end;
             pd.parast.insert(vs);
 
@@ -430,6 +448,29 @@ implementation
       end;
 
 
+    procedure insert_record_hidden_paras(astruct: trecorddef);
+      var
+        pd: tdef;
+        i: longint;
+        oldpos: tfileposinfo;
+      begin
+        // handle calling conventions of record methods
+        oldpos:=current_filepos;
+        { don't keep track of procdefs in a separate list, because the
+          compiler may add additional procdefs (e.g. property wrappers for
+          the jvm backend) }
+        for i := 0 to astruct.symtable.deflist.count - 1 do
+          begin
+            pd:=tdef(astruct.symtable.deflist[i]);
+            if pd.typ<>procdef then
+              continue;
+            current_filepos:=tprocdef(pd).fileinfo;
+            handle_calling_convention(tprocdef(pd),[hcc_declaration,hcc_insert_hidden_paras]);
+          end;
+        current_filepos:=oldpos;
+      end;
+
+
     procedure set_addr_param_regable(p:TObject;arg:pointer);
       begin
         if (tsym(p).typ<>paravarsym) then
@@ -443,7 +484,7 @@ implementation
       end;
 
 
-    procedure handle_calling_convention(pd:tabstractprocdef;flags:thccflags=hcc_all);
+    procedure handle_calling_convention(pd:tabstractprocdef;flags:thccflags);
       begin
         if hcc_check in flags then
           begin
@@ -504,7 +545,7 @@ implementation
                { check first for external in the interface, if available there
                  then the cdecl must also be there since there is no implementation
                  available to contain it }
-               if parse_only then
+               if hcc_declaration in flags then
                 begin
                   { if external is available, then cdecl must also be available,
                     procvars don't need external }
@@ -554,4 +595,512 @@ implementation
       end;
 
 
+    function proc_add_definition(var currpd:tprocdef):boolean;
+
+      function check_generic_parameters(fwpd,currpd:tprocdef):boolean;
+        var
+          i : longint;
+          fwtype,
+          currtype : ttypesym;
+        begin
+          result:=true;
+          if fwpd.genericparas.count<>currpd.genericparas.count then
+            internalerror(2018090101);
+          for i:=0 to fwpd.genericparas.count-1 do
+            begin
+              fwtype:=ttypesym(fwpd.genericparas[i]);
+              currtype:=ttypesym(currpd.genericparas[i]);
+              if fwtype.name<>currtype.name then
+                begin
+                  messagepos1(currtype.fileinfo,sym_e_generic_type_param_mismatch,currtype.realname);
+                  messagepos1(fwtype.fileinfo,sym_e_generic_type_param_decl,fwtype.realname);
+                  result:=false;
+                end;
+            end;
+        end;
+
+
+      function equal_generic_procdefs(fwpd,currpd:tprocdef):boolean;
+        var
+          i : longint;
+          fwtype,
+          currtype : ttypesym;
+          foundretdef : boolean;
+        begin
+          result:=false;
+          if fwpd.genericparas.count<>currpd.genericparas.count then
+            exit;
+          { comparing generic declarations is a bit more cumbersome as the
+            defs of the generic parameter types are not equal, especially if the
+            declaration contains constraints; essentially we have two cases:
+            - proc declared in interface of unit (or in class/record/object)
+              and defined in implementation; here the fwpd might contain
+              constraints while currpd must only contain undefineddefs
+            - forward declaration in implementation }
+          foundretdef:=false;
+          for i:=0 to fwpd.genericparas.count-1 do
+            begin
+              fwtype:=ttypesym(fwpd.genericparas[i]);
+              currtype:=ttypesym(currpd.genericparas[i]);
+              { if the type in the currpd isn't a pure undefineddef, then we can
+                stop right there }
+              if (currtype.typedef.typ<>undefineddef) or (df_genconstraint in currtype.typedef.defoptions) then
+                exit;
+              if not foundretdef then
+                begin
+                  { if the returndef is the same as this parameter's def then this
+                    needs to be the case for both procdefs }
+                  foundretdef:=fwpd.returndef=fwtype.typedef;
+                  if foundretdef xor (currpd.returndef=currtype.typedef) then
+                    exit;
+                end;
+            end;
+          if compare_paras(fwpd.paras,currpd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv,cpo_generic])<>te_exact then
+            exit;
+          if not foundretdef then
+            begin
+              if (df_specialization in tstoreddef(fwpd.returndef).defoptions) and (df_specialization in tstoreddef(currpd.returndef).defoptions) then
+                { for specializations we're happy with equal defs instead of exactly the same defs }
+                result:=equal_defs(fwpd.returndef,currpd.returndef)
+              else
+                { the returndef isn't a type parameter, so compare as usual }
+                result:=compare_defs(fwpd.returndef,currpd.returndef,nothingn)=te_exact;
+            end
+          else
+            result:=true;
+        end;
+
+      {
+        Add definition aprocdef to the overloaded definitions of aprocsym. If a
+        forwarddef is found and reused it returns true
+      }
+      var
+        fwpd    : tprocdef;
+        currparasym,
+        fwparasym : tsym;
+        currparacnt,
+        fwparacnt,
+        curridx,
+        fwidx,
+        i       : longint;
+        po_comp : tprocoptions;
+        paracompopt: tcompare_paras_options;
+        forwardfound : boolean;
+        symentry: TSymEntry;
+        item : tlinkedlistitem;
+      begin
+        forwardfound:=false;
+
+        { check overloaded functions if the same function already exists }
+        for i:=0 to tprocsym(currpd.procsym).ProcdefList.Count-1 do
+         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;
+
+           { check the parameters, for delphi/tp it is possible to
+             leave the parameters away in the implementation (forwarddef=false).
+             But for an overload declared function this is not allowed }
+           if { check if empty implementation arguments match is allowed }
+              (
+               not(m_repeat_forward in current_settings.modeswitches) and
+               not(currpd.forwarddef) and
+               is_bareprocdef(currpd) and
+               not(po_overload in fwpd.procoptions)
+              ) or
+              (
+                fwpd.is_generic and
+                currpd.is_generic and
+                equal_generic_procdefs(fwpd,currpd)
+              ) or
+              { check arguments, we need to check only the user visible parameters. The hidden parameters
+                can be in a different location because of the calling convention, eg. L-R vs. R-L order (PFV)
+
+                don't check default values here, because routines that are the same except for their default
+                values should be reported as mismatches (since you can't overload based on different default
+                parameter values) }
+              (
+               (compare_paras(fwpd.paras,currpd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and
+               (compare_defs(fwpd.returndef,currpd.returndef,nothingn)=te_exact)
+              ) then
+             begin
+               { Check if we've found the forwarddef, if found then
+                 we need to update the forward def with the current
+                 implementation settings }
+               if fwpd.forwarddef then
+                 begin
+                   forwardfound:=true;
+
+                   if not(m_repeat_forward in current_settings.modeswitches) and
+                      (fwpd.proccalloption<>currpd.proccalloption) then
+                     paracompopt:=[cpo_ignorehidden,cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv]
+                   else
+                     paracompopt:=[cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv];
+
+                   { Check calling convention }
+                   if (fwpd.proccalloption<>currpd.proccalloption) then
+                    begin
+                      { In delphi it is possible to specify the calling
+                        convention in the interface or implementation if
+                        there was no convention specified in the other
+                        part }
+                      if (m_delphi in current_settings.modeswitches) then
+                        begin
+                          if not(po_hascallingconvention in currpd.procoptions) then
+                            currpd.proccalloption:=fwpd.proccalloption
+                          else
+                            if not(po_hascallingconvention in fwpd.procoptions) then
+                              fwpd.proccalloption:=currpd.proccalloption
+                          else
+                            begin
+                              MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
+                              tprocsym(currpd.procsym).write_parameter_lists(currpd);
+                              { restore interface settings }
+                              currpd.proccalloption:=fwpd.proccalloption;
+                            end;
+                        end
+                      else
+                        begin
+                          MessagePos(currpd.fileinfo,parser_e_call_convention_dont_match_forward);
+                          tprocsym(currpd.procsym).write_parameter_lists(currpd);
+                          { restore interface settings }
+                          currpd.proccalloption:=fwpd.proccalloption;
+                        end;
+                    end;
+
+                   { Check static }
+                   if (po_staticmethod in fwpd.procoptions) then
+                    begin
+                      if not (po_staticmethod in currpd.procoptions) then
+                       begin
+                         include(currpd.procoptions, po_staticmethod);
+                         if (po_classmethod in currpd.procoptions) then
+                          begin
+                           { remove self from the hidden paras }
+                           symentry:=currpd.parast.Find('self');
+                           if symentry<>nil then
+                            begin
+                              currpd.parast.Delete(symentry);
+                              currpd.calcparas;
+                            end;
+                          end;
+                       end;
+                    end;
+
+                   { Check if the procedure type and return type are correct,
+                     also the parameters must match also with the type and that
+                     if the implementation has default parameters, the interface
+                     also has them and that if they both have them, that they
+                     have the same value }
+                   if ((m_repeat_forward in current_settings.modeswitches) or
+                       not is_bareprocdef(currpd)) and
+                       (
+                         (
+                           fwpd.is_generic and
+                           currpd.is_generic and
+                           not equal_generic_procdefs(fwpd,currpd)
+                         ) or
+                         (
+                           (
+                             not fwpd.is_generic or
+                             not currpd.is_generic
+                           ) and
+                           (
+                             (compare_paras(fwpd.paras,currpd.paras,cp_all,paracompopt)<>te_exact) or
+                             (compare_defs(fwpd.returndef,currpd.returndef,nothingn)<>te_exact)
+                           )
+                         )
+                       ) then
+                     begin
+                       MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
+                                   fwpd.fullprocname(false));
+                       tprocsym(currpd.procsym).write_parameter_lists(currpd);
+                       break;
+                     end;
+
+                   { Check if both are declared forward }
+                   if fwpd.forwarddef and currpd.forwarddef then
+                    begin
+                      MessagePos1(currpd.fileinfo,parser_e_function_already_declared_public_forward,
+                                  currpd.fullprocname(false));
+                    end;
+
+                   { internconst or internproc only need to be defined once }
+                   if (fwpd.proccalloption=pocall_internproc) then
+                    currpd.proccalloption:=fwpd.proccalloption
+                   else
+                    if (currpd.proccalloption=pocall_internproc) then
+                     fwpd.proccalloption:=currpd.proccalloption;
+
+                   { Check procedure options, Delphi requires that class is
+                     repeated in the implementation for class methods }
+                   if (m_fpc in current_settings.modeswitches) then
+                     po_comp:=[po_classmethod,po_varargs,po_methodpointer,po_interrupt]
+                   else
+                     po_comp:=[po_classmethod,po_methodpointer];
+
+                   if ((po_comp * fwpd.procoptions)<>(po_comp * currpd.procoptions)) or
+                      (fwpd.proctypeoption <> currpd.proctypeoption) or
+                      { if the implementation version has an "overload" modifier,
+                        the interface version must also have it (otherwise we can
+                        get annoying crashes due to interface crc changes) }
+                      (not(po_overload in fwpd.procoptions) and
+                       (po_overload in currpd.procoptions)) then
+                     begin
+                       MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
+                                   fwpd.fullprocname(false));
+                       tprocsym(fwpd.procsym).write_parameter_lists(fwpd);
+                       { This error is non-fatal, we can recover }
+                     end;
+
+                   { Forward declaration is external? }
+                   if (po_external in fwpd.procoptions) then
+                     MessagePos(currpd.fileinfo,parser_e_proc_already_external);
+
+                   { check for conflicts with "virtual" if this is a virtual
+                     method, as "virtual" cannot be repeated in the
+                     implementation and hence does not get checked against }
+                   if (po_virtualmethod in fwpd.procoptions) then
+                     begin
+                       po_comp:=currpd.procoptions*PD_VIRTUAL_MUTEXCLPO;
+                       if po_comp<>[] then
+                         MessagePos2(currpd.fileinfo,parser_e_proc_dir_conflict,tokeninfo^[_VIRTUAL].str,get_first_proc_str(po_comp));
+                     end;
+                    { Check parameters }
+                   if (m_repeat_forward in current_settings.modeswitches) or
+                      (currpd.minparacount>0) then
+                    begin
+                      { If mangled names are equal then they have the same amount of arguments }
+                      { We can check the names of the arguments }
+                      { both symtables are in the same order from left to right }
+                      curridx:=0;
+                      fwidx:=0;
+                      currparacnt:=currpd.parast.SymList.Count;
+                      fwparacnt:=fwpd.parast.SymList.Count;
+                      repeat
+                        { skip default parameter constsyms }
+                        while (curridx<currparacnt) and
+                              (tsym(currpd.parast.SymList[curridx]).typ<>paravarsym) do
+                          inc(curridx);
+                        while (fwidx<fwparacnt) and
+                              (tsym(fwpd.parast.SymList[fwidx]).typ<>paravarsym) do
+                          inc(fwidx);
+                        { stop when one of the two lists is at the end }
+                        if (fwidx>=fwparacnt) or (curridx>=currparacnt) then
+                          break;
+                        { compare names of parameters, ignore implictly
+                          renamed parameters }
+                        currparasym:=tsym(currpd.parast.SymList[curridx]);
+                        fwparasym:=tsym(fwpd.parast.SymList[fwidx]);
+                        if not(sp_implicitrename in currparasym.symoptions) and
+                           not(sp_implicitrename in fwparasym.symoptions) then
+                          begin
+                            if (currparasym.name<>fwparasym.name) then
+                              begin
+                                MessagePos3(currpd.fileinfo,parser_e_header_different_var_names,
+                                            tprocsym(currpd.procsym).realname,fwparasym.realname,currparasym.realname);
+                                break;
+                              end;
+                          end;
+                        { next parameter }
+                        inc(curridx);
+                        inc(fwidx);
+                      until false;
+                    end;
+                   { check that the type parameter names for generic methods match;
+                     we check this here and not in equal_generic_procdefs as the defs
+                     might still be different due to their parameters, so we'd generate
+                     errors without any need }
+                   if currpd.is_generic and fwpd.is_generic then
+                     { an error here is recoverable, so we simply continue }
+                     check_generic_parameters(fwpd,currpd);
+                   { Everything is checked, now we can update the forward declaration
+                     with the new data from the implementation }
+                   fwpd.forwarddef:=currpd.forwarddef;
+                   fwpd.hasforward:=true;
+                   fwpd.procoptions:=fwpd.procoptions+currpd.procoptions;
+
+                   { marked as local but exported from unit? }
+                   if (po_kylixlocal in fwpd.procoptions) and (fwpd.owner.symtabletype=globalsymtable) then
+                     MessagePos(fwpd.fileinfo,type_e_cant_export_local);
+
+                   if fwpd.extnumber=$ffff then
+                     fwpd.extnumber:=currpd.extnumber;
+                   while not currpd.aliasnames.empty do
+                     fwpd.aliasnames.insert(currpd.aliasnames.getfirst);
+                   { update fileinfo so position references the implementation,
+                     also update funcretsym if it is already generated }
+                   fwpd.fileinfo:=currpd.fileinfo;
+                   if assigned(fwpd.funcretsym) then
+                     fwpd.funcretsym.fileinfo:=currpd.fileinfo;
+                   if assigned(currpd.deprecatedmsg) then
+                     begin
+                       stringdispose(fwpd.deprecatedmsg);
+                       fwpd.deprecatedmsg:=stringdup(currpd.deprecatedmsg^);
+                     end;
+                   { import names }
+                   if assigned(currpd.import_dll) then
+                     begin
+                       stringdispose(fwpd.import_dll);
+                       fwpd.import_dll:=stringdup(currpd.import_dll^);
+                     end;
+                   if assigned(currpd.import_name) then
+                     begin
+                       stringdispose(fwpd.import_name);
+                       fwpd.import_name:=stringdup(currpd.import_name^);
+                     end;
+                   fwpd.import_nr:=currpd.import_nr;
+                   { for compilerproc defines we need to rename and update the
+                     symbolname to lowercase so users can' access it (can't do
+                     it immediately, because then the implementation symbol
+                     won't be matched) }
+                   if po_compilerproc in fwpd.procoptions then
+                     begin
+                       fwpd.setcompilerprocname;
+                       current_module.add_public_asmsym(fwpd.procsym.realname,AB_GLOBAL,AT_FUNCTION);
+                     end;
+                   if po_public in fwpd.procoptions then
+                     begin
+                       item:=fwpd.aliasnames.first;
+                       while assigned(item) do
+                         begin
+                           current_module.add_public_asmsym(TCmdStrListItem(item).str,AB_GLOBAL,AT_FUNCTION);
+                           item:=item.next;
+                         end;
+                     end;
+
+                   { Release current procdef }
+                   currpd.owner.deletedef(currpd);
+                   currpd:=fwpd;
+                 end
+               else
+                begin
+                  { abstract methods aren't forward defined, but this }
+                  { needs another error message                   }
+                  if (po_abstractmethod in fwpd.procoptions) then
+                    MessagePos(currpd.fileinfo,parser_e_abstract_no_definition)
+                  else
+                    begin
+                      MessagePos(currpd.fileinfo,parser_e_overloaded_have_same_parameters);
+                      tprocsym(currpd.procsym).write_parameter_lists(currpd);
+                    end;
+                 end;
+
+               { we found one proc with the same arguments, there are no others
+                 so we can stop }
+               break;
+             end;
+
+           { check for allowing overload directive }
+           if not(m_fpc in current_settings.modeswitches) then
+            begin
+              { overload directive turns on overloading }
+              if ((po_overload in currpd.procoptions) or
+                  (po_overload in fwpd.procoptions)) then
+               begin
+                 { check if all procs have overloading, but not if the proc is a method or
+                   already declared forward, then the check is already done }
+                 if not(fwpd.hasforward or
+                        assigned(currpd.struct) or
+                        (currpd.forwarddef<>fwpd.forwarddef) or
+                        ((po_overload in currpd.procoptions) and
+                         (po_overload in fwpd.procoptions))) then
+                  begin
+                    MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
+                    break;
+                  end
+               end
+              else
+               begin
+                 if not(fwpd.forwarddef) then
+                  begin
+                    if (m_tp7 in current_settings.modeswitches) then
+                      MessagePos(currpd.fileinfo,parser_e_procedure_overloading_is_off)
+                    else
+                      MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
+                    break;
+                  end;
+               end;
+            end; { equal arguments }
+         end;
+
+        { if we didn't reuse a forwarddef then we add the procdef to the overloaded
+          list }
+        if not forwardfound then
+          begin
+            { can happen in Delphi mode }
+            if (currpd.proctypeoption = potype_function) and
+               is_void(currpd.returndef) then
+              MessagePos1(currpd.fileinfo,parser_e_no_funcret_specified,currpd.procsym.realname);
+            tprocsym(currpd.procsym).ProcdefList.Add(currpd);
+            if not currpd.forwarddef and (po_public in currpd.procoptions) then
+              begin
+                item:=currpd.aliasnames.first;
+                while assigned(item) do
+                  begin
+                    current_module.add_public_asmsym(TCmdStrListItem(item).str,AB_GLOBAL,AT_FUNCTION);
+                    item:=item.next;
+                  end;
+              end;
+          end;
+
+        proc_add_definition:=forwardfound;
+      end;
+
+
+    procedure build_parentfpstruct(pd: tprocdef);
+      var
+        nestedvars: tsym;
+        nestedvarsst: tsymtable;
+        pnestedvarsdef,
+        nestedvarsdef: tdef;
+        old_symtablestack: tsymtablestack;
+      begin
+        { make sure the defs are not registered in the current symtablestack,
+          because they may be for a parent procdef (changeowner does remove a def
+          from the symtable in which it was originally created, so that by itself
+          is not enough) }
+        old_symtablestack:=symtablestack;
+        symtablestack:=old_symtablestack.getcopyuntil(current_module.localsymtable);
+        { create struct to hold local variables and parameters that are
+          accessed from within nested routines (start with extra dollar to prevent
+          the JVM from thinking this is a nested class in the unit) }
+        nestedvarsst:=trecordsymtable.create('$'+current_module.realmodulename^+'$$_fpc_nestedvars$'+pd.unique_id_str,
+          current_settings.alignment.localalignmax,current_settings.alignment.localalignmin,current_settings.alignment.maxCrecordalign);
+        nestedvarsdef:=crecorddef.create(nestedvarsst.name^,nestedvarsst);
+  {$ifdef jvm}
+        maybe_guarantee_record_typesym(nestedvarsdef,nestedvarsdef.owner);
+        { don't add clone/FpcDeepCopy, because the field names are not all
+          representable in source form and we don't need them anyway }
+        symtablestack.push(trecorddef(nestedvarsdef).symtable);
+        maybe_add_public_default_java_constructor(trecorddef(nestedvarsdef));
+        insert_record_hidden_paras(trecorddef(nestedvarsdef));
+        symtablestack.pop(trecorddef(nestedvarsdef).symtable);
+  {$endif}
+        symtablestack.free;
+        symtablestack:=old_symtablestack.getcopyuntil(pd.localst);
+        pnestedvarsdef:=cpointerdef.getreusable(nestedvarsdef);
+        if not(po_assembler in pd.procoptions) then
+          begin
+            nestedvars:=clocalvarsym.create('$nestedvars',vs_var,nestedvarsdef,[],true);
+            include(nestedvars.symoptions,sp_internal);
+            pd.localst.insert(nestedvars);
+            pd.parentfpstruct:=nestedvars;
+            pd.parentfpinitblock:=cblocknode.create(nil);
+          end;
+        symtablestack.free;
+        pd.parentfpstructptrtype:=pnestedvarsdef;
+
+        symtablestack:=old_symtablestack;
+      end;
+
 end.

compiler/procdefutil.pas

@@ -0,0 +1,88 @@
+{
+    Copyright (c) 2018 by Jonas Maebe
+
+    This unit provides helpers for creating procdefs
+
+    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 procdefutil;
+
+interface
+
+uses
+  symconst,symtype,symdef;
+
+{ create a nested procdef that will be used to outline code from a procedure;
+  astruct should usually be nil, except in special cases like the Windows SEH
+  exception handling funclets }
+function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef;
+
+implementation
+
+  uses
+    cutils,
+    symbase,symsym,symtable,pparautl;
+
+
+  function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef;
+    var
+      st:TSymTable;
+      checkstack: psymtablestackitem;
+      oldsymtablestack: tsymtablestack;
+      sym:tprocsym;
+    begin
+      { get actual procedure symtable (skip withsymtables, etc.) }
+      st:=nil;
+      checkstack:=symtablestack.stack;
+      while assigned(checkstack) do
+        begin
+          st:=checkstack^.symtable;
+          if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
+            break;
+          checkstack:=checkstack^.next;
+        end;
+      { Create a nested procedure, even from main_program_level.
+        Furthermore, force procdef and procsym into the same symtable
+        (by default, defs are registered with symtablestack.top which may be
+        something temporary like exceptsymtable - in that case, procdef can be
+        destroyed before procsym, leaving invalid pointers). }
+      oldsymtablestack:=symtablestack;
+      symtablestack:=nil;
+      result:=cprocdef.create(max(normal_function_level,st.symtablelevel)+1,true);
+      result.returndef:=resultdef;
+      symtablestack:=oldsymtablestack;
+      st.insertdef(result);
+      result.struct:=astruct;
+      { tabstractprocdef constructor sets po_delphi_nested_cc whenever
+        nested procvars modeswitch is active. We must be independent of this switch. }
+      exclude(result.procoptions,po_delphi_nested_cc);
+      result.proctypeoption:=potype;
+      handle_calling_convention(result,hcc_default_actions_impl);
+      sym:=cprocsym.create(basesymname+result.unique_id_str);
+      st.insert(sym);
+
+      result.procsym:=sym;
+      proc_add_definition(result);
+      { the code will be assigned directly to the "code" field later }
+      result.forwarddef:=false;
+      result.aliasnames.insert(result.mangledname);
+    end;
+
+
+end.
+

compiler/procinfo.pas

@@ -31,7 +31,8 @@ unit procinfo;
       { global }
       globtype,
       { symtable }
-      symconst,symdef,symsym,
+      symconst,symtype,symdef,symsym,
+      node,
       { aasm }
       cpubase,cgbase,cgutils,
       aasmbase,aasmdata;
@@ -168,6 +169,8 @@ unit procinfo;
           function has_nestedprocs: boolean;
           function get_normal_proc: tprocinfo;
 
+          function create_for_outlining(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef; entrynodeinfo: tnode): tprocinfo;
+
           { Add to parent's list of nested procedures even if parent is a 'main' procedure }
           procedure force_nested;
 
@@ -189,7 +192,8 @@ unit procinfo;
 implementation
 
     uses
-      cutils,systems;
+      globals,cutils,systems,
+      procdefutil;
 
 {****************************************************************************
                                  TProcInfo
@@ -273,6 +277,17 @@ implementation
           result:=result.parent;
       end;
 
+    function tprocinfo.create_for_outlining(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef; entrynodeinfo: tnode): tprocinfo;
+      begin
+        result:=cprocinfo.create(self);
+        result.force_nested;
+        result.procdef:=create_outline_procdef(basesymname,astruct,potype,resultdef);
+        result.entrypos:=entrynodeinfo.fileinfo;
+        result.entryswitches:=entrynodeinfo.localswitches;
+        result.exitpos:=current_filepos; // filepos of last node?
+        result.exitswitches:=current_settings.localswitches; // localswitches of last node?
+      end;
+
     procedure tprocinfo.allocate_push_parasize(size:longint);
       begin
         if size>maxpushedparasize then

compiler/psub.pas

@@ -2260,7 +2260,10 @@ implementation
               Consume(_SEMICOLON);
 
              { Set calling convention }
-             handle_calling_convention(pd);
+             if parse_only then
+               handle_calling_convention(pd,hcc_default_actions_intf)
+             else
+               handle_calling_convention(pd,hcc_default_actions_impl)
            end;
 
          { search for forward declarations }

compiler/ptype.pas

@@ -1596,7 +1596,7 @@ implementation
                     newtype.free;
                   end;
                 { Add implicit hidden parameters and function result }
-                handle_calling_convention(pd);
+                handle_calling_convention(pd,hcc_default_actions_intf);
               end;
             { restore old state }
             parse_generic:=old_parse_generic;

compiler/symcreat.pas

@@ -97,10 +97,6 @@ interface
     tprocdef.getcopyas(procdef,pc_bareproc) }
   procedure finish_copied_procdef(var pd: tprocdef; const realname: string; newparentst: tsymtable; newstruct: tabstractrecorddef);
 
-  { create "parent frame pointer" record skeleton for procdef, in which local
-    variables and parameters from pd accessed from nested routines can be
-    stored }
-  procedure build_parentfpstruct(pd: tprocdef);
   { checks whether sym (a local or para of pd) already has a counterpart in
     pd's parentfpstruct, and if not adds a new field to the struct with type
     "vardef" (can be different from sym's type in case it's a call-by-reference
@@ -118,8 +114,6 @@ interface
   { finalises the parentfpstruct (alignment padding, ...) }
   procedure finish_parentfpstruct(pd: tprocdef);
 
-  procedure maybe_guarantee_record_typesym(var def: tdef; st: tsymtable);
-
   { turns a fieldvarsym into a class/static field definition, and returns the
     created staticvarsym that is responsible for allocating the global storage }
   function make_field_static(recst: tsymtable; fieldvs: tfieldvarsym): tstaticvarsym;
@@ -131,11 +125,13 @@ interface
 
   function generate_pkg_stub(pd:tprocdef):tnode;
 
+
+
 implementation
 
   uses
     cutils,cclasses,globals,verbose,systems,comphook,fmodule,constexp,
-    symtable,defutil,
+    symtable,defutil,symutil,
     pbase,pdecobj,pdecsub,psub,ptconst,pparautl,
 {$ifdef jvm}
     pjvm,jvmdef,
@@ -1228,53 +1224,6 @@ implementation
     end;
 
 
-  procedure build_parentfpstruct(pd: tprocdef);
-    var
-      nestedvars: tsym;
-      nestedvarsst: tsymtable;
-      pnestedvarsdef,
-      nestedvarsdef: tdef;
-      old_symtablestack: tsymtablestack;
-    begin
-      { make sure the defs are not registered in the current symtablestack,
-        because they may be for a parent procdef (changeowner does remove a def
-        from the symtable in which it was originally created, so that by itself
-        is not enough) }
-      old_symtablestack:=symtablestack;
-      symtablestack:=old_symtablestack.getcopyuntil(current_module.localsymtable);
-      { create struct to hold local variables and parameters that are
-        accessed from within nested routines (start with extra dollar to prevent
-        the JVM from thinking this is a nested class in the unit) }
-      nestedvarsst:=trecordsymtable.create('$'+current_module.realmodulename^+'$$_fpc_nestedvars$'+pd.unique_id_str,
-        current_settings.alignment.localalignmax,current_settings.alignment.localalignmin,current_settings.alignment.maxCrecordalign);
-      nestedvarsdef:=crecorddef.create(nestedvarsst.name^,nestedvarsst);
-{$ifdef jvm}
-      maybe_guarantee_record_typesym(nestedvarsdef,nestedvarsdef.owner);
-      { don't add clone/FpcDeepCopy, because the field names are not all
-        representable in source form and we don't need them anyway }
-      symtablestack.push(trecorddef(nestedvarsdef).symtable);
-      maybe_add_public_default_java_constructor(trecorddef(nestedvarsdef));
-      insert_record_hidden_paras(trecorddef(nestedvarsdef));
-      symtablestack.pop(trecorddef(nestedvarsdef).symtable);
-{$endif}
-      symtablestack.free;
-      symtablestack:=old_symtablestack.getcopyuntil(pd.localst);
-      pnestedvarsdef:=cpointerdef.getreusable(nestedvarsdef);
-      if not(po_assembler in pd.procoptions) then
-        begin
-          nestedvars:=clocalvarsym.create('$nestedvars',vs_var,nestedvarsdef,[],true);
-          include(nestedvars.symoptions,sp_internal);
-          pd.localst.insert(nestedvars);
-          pd.parentfpstruct:=nestedvars;
-          pd.parentfpinitblock:=cblocknode.create(nil);
-        end;
-      symtablestack.free;
-      pd.parentfpstructptrtype:=pnestedvarsdef;
-
-      symtablestack:=old_symtablestack;
-    end;
-
-
   function maybe_add_sym_to_parentfpstruct(pd: tprocdef; sym: tsym; vardef: tdef; addrparam: boolean): tsym;
     var
       fieldvardef,
@@ -1400,26 +1349,6 @@ implementation
     end;
 
 
-  procedure maybe_guarantee_record_typesym(var def: tdef; st: tsymtable);
-    var
-      ts: ttypesym;
-    begin
-      { create a dummy typesym for the JVM target, because the record
-        has to be wrapped by a class }
-      if (target_info.system in systems_jvm) and
-         (def.typ=recorddef) and
-         not assigned(def.typesym) then
-        begin
-          ts:=ctypesym.create(trecorddef(def).symtable.realname^,def,true);
-          st.insert(ts);
-          ts.visibility:=vis_strictprivate;
-          { this typesym can't be used by any Pascal code, so make sure we don't
-            print a hint about it being unused }
-          addsymref(ts);
-        end;
-    end;
-
-
   function make_field_static(recst: tsymtable; fieldvs: tfieldvarsym): tstaticvarsym;
     var
       static_name: string;
@@ -1521,6 +1450,5 @@ implementation
         result:=cnothingnode.create;
     end;
 
-
 end.
 

compiler/symdef.pas

@@ -818,6 +818,7 @@ interface
           function  GetTypeName : string;override;
           function  mangledname : TSymStr; virtual;
           procedure setmangledname(const s : TSymStr);
+          procedure setcompilerprocname;
           function  fullprocname(showhidden:boolean):string;
           function  customprocname(pno: tprocnameoptions):ansistring;
           function  defaultmangledname: TSymStr;
@@ -6505,6 +6506,12 @@ implementation
       end;
 
 
+    procedure tprocdef.setcompilerprocname;
+      begin
+        procsym.realname:='$'+lower(procsym.name);
+      end;
+
+
 {***************************************************************************
                                  TPROCVARDEF
 ***************************************************************************}

compiler/symutil.pas

@@ -26,18 +26,24 @@ unit symutil;
 interface
 
     uses
-       symbase,symsym;
+       symconst,symbase,symtype,symsym;
 
     function is_funcret_sym(p:TSymEntry):boolean;
 
     function equal_constsym(sym1,sym2:tconstsym; nanequal: boolean):boolean;
 
+    function get_first_proc_str(Options: TProcOptions): ShortString;
+
+    procedure maybe_guarantee_record_typesym(var def: tdef; st: tsymtable);
+
 
 implementation
 
     uses
-       globtype,cpuinfo,constexp,
-       symconst,widestr;
+       systems,
+       globtype,cpuinfo,constexp,verbose,
+       widestr,
+       symdef;
 
 
     function is_funcret_sym(p:TSymEntry):boolean;
@@ -95,5 +101,45 @@ implementation
         end;
       end;
 
+
+    { get_first_proc_str - returns the token string of the first option that
+      appears in the list }
+    function get_first_proc_str(Options: TProcOptions): ShortString;
+      var
+        X: TProcOption;
+      begin
+        if Options = [] then
+          InternalError(2018051700);
+
+        get_first_proc_str := '';
+
+        for X in Options do
+          begin
+            get_first_proc_str := ProcOptionKeywords[X];
+            Exit;
+          end;
+      end;
+
+
+    procedure maybe_guarantee_record_typesym(var def: tdef; st: tsymtable);
+      var
+        ts: ttypesym;
+      begin
+        { create a dummy typesym for the JVM target, because the record
+          has to be wrapped by a class }
+        if (target_info.system in systems_jvm) and
+           (def.typ=recorddef) and
+           not assigned(def.typesym) then
+          begin
+            ts:=ctypesym.create(trecorddef(def).symtable.realname^,def,true);
+            st.insert(ts);
+            ts.visibility:=vis_strictprivate;
+            { this typesym can't be used by any Pascal code, so make sure we don't
+              print a hint about it being unused }
+            include(ts.symoptions,sp_internal);
+          end;
+      end;
+
+
 end.
 

compiler/x86_64/nx64flw.pas

@@ -158,16 +158,9 @@ constructor tx64tryfinallynode.create(l, r: TNode);
         behavior causes compilation errors because real nested procedures
         aren't allowed for generics. Not creating them doesn't harm because
         generic node tree is discarded without generating code. }
-       not (df_generic in current_procinfo.procdef.defoptions)
-       then
+       not (df_generic in current_procinfo.procdef.defoptions) then
       begin
-        finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
-        finalizepi.force_nested;
-        finalizepi.procdef:=create_finalizer_procdef;
-        finalizepi.entrypos:=r.fileinfo;
-        finalizepi.entryswitches:=r.localswitches;
-        finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
-        finalizepi.exitswitches:=current_settings.localswitches;
+        finalizepi:=tcgprocinfo(current_procinfo.create_for_outlining('$fin$',current_procinfo.procdef.struct,potype_exceptfilter,voidtype,r));
         { the init/final code is messing with asm nodes, so inform the compiler about this }
         include(finalizepi.flags,pi_has_assembler_block);
         { Regvar optimization for symbols is suppressed when using exceptions, but
@@ -184,14 +177,7 @@ constructor tx64tryfinallynode.create_implicit(l, r: TNode);
         if df_generic in current_procinfo.procdef.defoptions then
           InternalError(2013012501);
 
-        finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
-        finalizepi.force_nested;
-        finalizepi.procdef:=create_finalizer_procdef;
-
-        finalizepi.entrypos:=current_filepos;
-        finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
-        finalizepi.entryswitches:=r.localswitches;
-        finalizepi.exitswitches:=current_settings.localswitches;
+        finalizepi:=tcgprocinfo(current_procinfo.create_for_outlining('$fin$',current_procinfo.procdef.struct,potype_exceptfilter,voidtype,r));
         include(finalizepi.flags,pi_do_call);
         { the init/final code is messing with asm nodes, so inform the compiler about this }
         include(finalizepi.flags,pi_has_assembler_block);