+ defcmp: structural equivalence for COM interfacesblaise

~ pdecobj, pdecsub: parsing mode for routines: normal, class method, nameless routine, method reference
= pdecsub: factored out parse_proc_parameter_dec(); code simplifications
+ symdef: tprocdef.add_to_procsym()
+ ptype, tokens: new UDT -- method reference

git-svn-id: http://svn.freepascal.org/svn/fpc/branches/blaise@20212 3ad0048d-3df7-0310-abae-a5850022a9f2

8 files changed, 167 insertions, 95 deletions

diff --git a/closures/compiler/defcmp.pas b/closures/compiler/defcmp.pas
index 25c4ca4f11..9f8e98c03f 100644
--- a/closures/compiler/defcmp.pas
+++ b/closures/compiler/defcmp.pas
@@ -145,7 +145,7 @@ implementation
     uses
       verbose,systems,constexp,
       symtable,symsym,
-      defutil,symutil;
+      defutil,symutil,pnameless;
 
 
     function compare_defs_ext(def_from,def_to : tdef;
@@ -1390,6 +1390,15 @@ implementation
                        doconv:=tc_variant_2_interface;
                        eq:=te_convert_l2;
                      end
+                   { interface coercion }
+                   else if (def_from.typ=objectdef) and
+                     (tobjectdef(def_from).objecttype=odt_interfacecom) and
+                     (tobjectdef(def_to).objecttype=odt_interfacecom) and
+                     are_compatible_interfaces(tobjectdef(def_to),tobjectdef(def_from)) then
+                     begin
+                       doconv:=tc_equal;
+                       eq:=te_convert_l1;
+                     end
                    { ugly, but delphi allows it }
                    else if (def_from.typ in [orddef,enumdef]) and
                      (m_delphi in current_settings.modeswitches) and
diff --git a/closures/compiler/pdecobj.pas b/closures/compiler/pdecobj.pas
index 098dcc67d1..afb037d800 100644
--- a/closures/compiler/pdecobj.pas
+++ b/closures/compiler/pdecobj.pas
@@ -65,7 +65,7 @@ implementation
         result:=nil;
         consume(_CONSTRUCTOR);
         { must be at same level as in implementation }
-        parse_proc_head(current_structdef,potype_class_constructor,pd);
+        parse_proc_head(current_structdef,potype_class_constructor,ppm_class_method,pd);
         if not assigned(pd) then
           begin
             consume(_SEMICOLON);
@@ -89,7 +89,7 @@ implementation
         result:=nil;
         consume(_CONSTRUCTOR);
         { must be at same level as in implementation }
-        parse_proc_head(current_structdef,potype_constructor,pd);
+        parse_proc_head(current_structdef,potype_constructor,ppm_normal,pd);
         if not assigned(pd) then
           begin
             consume(_SEMICOLON);
@@ -178,7 +178,7 @@ implementation
       begin
         result:=nil;
         consume(_DESTRUCTOR);
-        parse_proc_head(current_structdef,potype_class_destructor,pd);
+        parse_proc_head(current_structdef,potype_class_destructor,ppm_class_method,pd);
         if not assigned(pd) then
           begin
             consume(_SEMICOLON);
@@ -201,7 +201,7 @@ implementation
       begin
         result:=nil;
         consume(_DESTRUCTOR);
-        parse_proc_head(current_structdef,potype_destructor,pd);
+        parse_proc_head(current_structdef,potype_destructor,ppm_normal,pd);
         if not assigned(pd) then
           begin
             consume(_SEMICOLON);
@@ -893,7 +893,7 @@ implementation
 
                 oldparse_only:=parse_only;
                 parse_only:=true;
-                pd:=parse_proc_dec(is_classdef,current_structdef);
+                pd:=parse_proc_dec(current_structdef,as_procparsemode(is_classdef));
 
                 { this is for error recovery as well as forward }
                 { interface mappings, i.e. mapping to a method  }
diff --git a/closures/compiler/pdecsub.pas b/closures/compiler/pdecsub.pas
index b73c4b3a3a..22dc7df7da 100644
--- a/closures/compiler/pdecsub.pas
+++ b/closures/compiler/pdecsub.pas
@@ -63,8 +63,12 @@ interface
     procedure parse_var_proc_directives(sym:tsym);
     procedure parse_object_proc_directives(pd:tabstractprocdef);
     procedure parse_record_proc_directives(pd:tabstractprocdef);
-    function  parse_proc_head(astruct:tabstractrecorddef;potype:tproctypeoption;out pd:tprocdef):boolean;
-    function  parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef;
+
+    type tprocparsemode = (ppm_normal, ppm_class_method, ppm_nameless_routine, ppm_method_reference);
+    // TODO: operator :=/Explicit (const is_class_method: boolean) result: tprocparsemode;
+    function as_procparsemode(const is_class_method: boolean): tprocparsemode; inline;
+    function parse_proc_head(astruct: tabstractrecorddef; potype: tproctypeoption; const procparsemode: tprocparsemode; out pd: tprocdef): boolean;
+    function parse_proc_dec(astruct: tabstractrecorddef; const procparsemode: tprocparsemode = ppm_normal): tprocdef;
 
     { helper functions - they insert nested objects hierarcy to the symtablestack
       with object hierarchy
@@ -799,7 +803,48 @@ implementation
       end;
 
 
-    function parse_proc_head(astruct:tabstractrecorddef;potype:tproctypeoption;out pd:tprocdef):boolean;
+    procedure parse_proc_parameter_dec(const pd: tprocdef); inline;
+      var
+        popclass : integer;
+        old_current_structdef: tabstractrecorddef;
+        old_current_genericdef,
+        old_current_specializedef: tstoreddef;
+      begin
+        { Add ObjectSymtable to be able to find nested type definitions }
+        popclass:=0;
+        if assigned(pd.struct) and // TODO: skip for nameless? or no need
+           (pd.parast.symtablelevel>=normal_function_level) and
+           not(symtablestack.top.symtabletype in [ObjectSymtable,recordsymtable]) then
+          begin
+            popclass:=push_nested_hierarchy(pd.struct);
+            old_current_structdef:=current_structdef;
+            old_current_genericdef:=current_genericdef;
+            old_current_specializedef:=current_specializedef;
+            current_structdef:=pd.struct;
+            if df_generic in current_structdef.defoptions then
+              current_genericdef:=current_structdef;
+            if df_specialization in current_structdef.defoptions then
+              current_specializedef:=current_structdef;
+          end;
+        { Add parameter symtable }
+        if pd.parast.symtabletype<>staticsymtable then
+          symtablestack.push(pd.parast);
+        parse_parameter_dec(pd);
+        if pd.parast.symtabletype<>staticsymtable then
+          symtablestack.pop(pd.parast);
+        if popclass>0 then
+          begin
+            current_structdef:=old_current_structdef;
+            current_genericdef:=old_current_genericdef;
+            current_specializedef:=old_current_specializedef;
+            dec(popclass,pop_nested_hierarchy(pd.struct));
+            if popclass<>0 then
+              internalerror(201011260); // 11 nov 2010 index 0
+          end;
+      end;
+
+
+    function parse_proc_head(astruct: tabstractrecorddef; potype: tproctypeoption; const procparsemode: tprocparsemode; out pd: tprocdef): boolean;
       var
         hs       : string;
         orgsp,sp : TIDString;
@@ -810,12 +855,8 @@ implementation
         st,
         genericst: TSymtable;
         aprocsym : tprocsym;
-        popclass : integer;
         ImplIntf : TImplementedInterface;
         old_parse_generic : boolean;
-        old_current_structdef: tabstractrecorddef;
-        old_current_genericdef,
-        old_current_specializedef: tstoreddef;
         lasttoken,lastidtoken: ttoken;
 
         procedure parse_operator_name;
@@ -982,7 +1023,20 @@ implementation
         pd:=nil;
         aprocsym:=nil;
 
-        consume_proc_name;
+        case procparsemode of
+          ppm_nameless_routine:
+            begin
+              sp:='Nameless_'+inttostr(procstartfilepos.line)+'_'+inttostr(procstartfilepos.column);
+              orgsp:=upcase(sp);
+            end;
+          ppm_method_reference:
+            begin
+              sp:='Invoke';
+              orgsp:=upcase(sp);
+            end;
+          else
+            consume_proc_name;
+        end;
 
         { examine interface map: function/procedure iname.functionname=locfuncname }
         if assigned(astruct) and
@@ -1016,7 +1070,11 @@ implementation
 
         { method  ? }
         srsym:=nil;
-        if (consume_generic_type_parameter or not assigned(astruct)) and
+        if procparsemode=ppm_nameless_routine then
+          // Do nothing. This check here:
+          //   a) skips below checks and searches, speeding things up;
+          //   b) makes sure we do not try to parse generic type parameters.
+        else if (consume_generic_type_parameter or not assigned(astruct)) and
            (symtablestack.top.symtablelevel=main_program_level) and
            try_to_consume(_POINT) then
          begin
@@ -1135,33 +1193,39 @@ implementation
           begin
             { create a new procsym and set the real filepos }
             current_tokenpos:=procstartfilepos;
-            { for operator we have only one procsym for each overloaded
-              operation }
-            if (potype=potype_operator) then
-              begin
+            case potype of
+              potype_operator:
+              begin // we have only one procsym for each overloaded operator
                 aprocsym:=Tprocsym(symtablestack.top.Find(sp));
                 if aprocsym=nil then
                   aprocsym:=tprocsym.create('$'+sp);
-              end
-            else
-            if (potype in [potype_class_constructor,potype_class_destructor]) then
-              aprocsym:=tprocsym.create('$'+lower(sp))
-            else
-              aprocsym:=tprocsym.create(orgsp);
+              end;
+              potype_class_constructor,potype_class_destructor:
+                aprocsym:=tprocsym.create('$'+lower(sp))
+              else
+                aprocsym:=tprocsym.create(orgsp);
+            end;
             symtablestack.top.insert(aprocsym);
           end;
 
-        { to get the correct symtablelevel we must ignore ObjectSymtables }
-        st:=nil;
-        checkstack:=symtablestack.stack;
-        while assigned(checkstack) do
+        if procparsemode=ppm_nameless_routine then
           begin
-            st:=checkstack^.symtable;
-            if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
-              break;
-            checkstack:=checkstack^.next;
-          end;
-        pd:=tprocdef.create(st.symtablelevel+1);
+            pd:=tprocdef.create(normal_function_level);
+            include(pd.procoptions,po_nameless);
+          end
+        else begin // TODO: surely, there should be a simpler way:
+          { to get the correct symtablelevel we must ignore ObjectSymtables }
+          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;
+          pd:=tprocdef.create(st.symtablelevel+1);
+        end;
         pd.struct:=astruct;
         pd.procsym:=aprocsym;
         pd.proctypeoption:=potype;
@@ -1210,46 +1274,23 @@ implementation
 
         { parse parameters }
         if token=_LKLAMMER then
-          begin
-            { Add ObjectSymtable to be able to find nested type definitions }
-            popclass:=0;
-            if assigned(pd.struct) and
-               (pd.parast.symtablelevel>=normal_function_level) and
-               not(symtablestack.top.symtabletype in [ObjectSymtable,recordsymtable]) then
-              begin
-                popclass:=push_nested_hierarchy(pd.struct);
-                old_current_structdef:=current_structdef;
-                old_current_genericdef:=current_genericdef;
-                old_current_specializedef:=current_specializedef;
-                current_structdef:=pd.struct;
-                if assigned(current_structdef) and (df_generic in current_structdef.defoptions) then
-                  current_genericdef:=current_structdef;
-                if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
-                  current_specializedef:=current_structdef;
-              end;
-            { Add parameter symtable }
-            if pd.parast.symtabletype<>staticsymtable then
-              symtablestack.push(pd.parast);
-            parse_parameter_dec(pd);
-            if pd.parast.symtabletype<>staticsymtable then
-              symtablestack.pop(pd.parast);
-            if popclass>0 then
-              begin
-                current_structdef:=old_current_structdef;
-                current_genericdef:=old_current_genericdef;
-                current_specializedef:=old_current_specializedef;
-                dec(popclass,pop_nested_hierarchy(pd.struct));
-                if popclass<>0 then
-                  internalerror(201011260); // 11 nov 2010 index 0
-              end;
-          end;
+          parse_proc_parameter_dec(pd);
 
         parse_generic:=old_parse_generic;
         result:=true;
       end;
 
 
-    function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef;
+    function as_procparsemode(const is_class_method: boolean): tprocparsemode; inline;
+      begin
+        if is_class_method then
+          result := ppm_class_method
+        else
+          result := ppm_normal
+      end;
+
+
+    function parse_proc_dec(astruct: tabstractrecorddef; const procparsemode: tprocparsemode = ppm_normal): tprocdef;
       var
         pd: tprocdef;
         locationstr: string;
@@ -1277,9 +1318,9 @@ implementation
                 old_current_genericdef:=current_genericdef;
                 old_current_specializedef:=current_specializedef;
                 current_structdef:=pd.struct;
-                if assigned(current_structdef) and (df_generic in current_structdef.defoptions) then
+                if df_generic in current_structdef.defoptions then
                   current_genericdef:=current_structdef;
-                if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
+                if df_specialization in current_structdef.defoptions then
                   current_specializedef:=current_structdef;
               end;
             single_type(pd.returndef,[stoAllowSpecialization]);
@@ -1306,7 +1347,7 @@ implementation
           _FUNCTION :
             begin
               consume(_FUNCTION);
-              if parse_proc_head(astruct,potype_function,pd) then
+              if parse_proc_head(astruct,potype_function,procparsemode,pd) then
                 begin
                   { pd=nil when it is a interface mapping }
                   if assigned(pd) then
@@ -1350,7 +1391,7 @@ implementation
                             consume_all_until(_SEMICOLON);
                           end;
                        end;
-                      if isclassmethod then
+                      if procparsemode=ppm_class_method then
                        include(pd.procoptions,po_classmethod);
                     end;
                 end
@@ -1365,13 +1406,13 @@ implementation
           _PROCEDURE :
             begin
               consume(_PROCEDURE);
-              if parse_proc_head(astruct,potype_procedure,pd) then
+              if parse_proc_head(astruct,potype_procedure,procparsemode,pd) then
                 begin
                   { pd=nil when it is an interface mapping }
                   if assigned(pd) then
                     begin
                       pd.returndef:=voidtype;
-                      if isclassmethod then
+                      if procparsemode=ppm_class_method then
                         include(pd.procoptions,po_classmethod);
                     end;
                 end;
@@ -1380,11 +1421,11 @@ implementation
           _CONSTRUCTOR :
             begin
               consume(_CONSTRUCTOR);
-              if isclassmethod then
-                parse_proc_head(astruct,potype_class_constructor,pd)
+              if procparsemode=ppm_class_method then
+                parse_proc_head(astruct,potype_class_constructor,procparsemode,pd)
               else
-                parse_proc_head(astruct,potype_constructor,pd);
-              if not isclassmethod and
+                parse_proc_head(astruct,potype_constructor,procparsemode,pd);
+              if (procparsemode<>ppm_class_method) and
                  assigned(pd) and
                  assigned(pd.struct) then
                 begin
@@ -1406,26 +1447,25 @@ implementation
           _DESTRUCTOR :
             begin
               consume(_DESTRUCTOR);
-              if isclassmethod then
-                parse_proc_head(astruct,potype_class_destructor,pd)
+              if procparsemode=ppm_class_method then
+                parse_proc_head(astruct,potype_class_destructor,procparsemode,pd)
               else
-                parse_proc_head(astruct,potype_destructor,pd);
+                parse_proc_head(astruct,potype_destructor,procparsemode,pd);
               if assigned(pd) then
                 pd.returndef:=voidtype;
             end;
-        else
-          if (token=_OPERATOR) or
-             (isclassmethod and (idtoken=_OPERATOR)) then
+
+          _OPERATOR:
             begin
               consume(_OPERATOR);
-              parse_proc_head(astruct,potype_operator,pd);
+              parse_proc_head(astruct,potype_operator,procparsemode,pd);
               if assigned(pd) then
                 begin
                   { operators always need to be searched in all units }
                   include(pd.procoptions,po_overload);
                   if pd.parast.symtablelevel>normal_function_level then
                     Message(parser_e_no_local_operator);
-                  if isclassmethod then
+                  if procparsemode=ppm_class_method then
                     include(pd.procoptions,po_classmethod);
                   if token<>_ID then
                     begin
@@ -1497,7 +1537,8 @@ implementation
                 message(parser_e_field_not_allowed_here);
                 consume_all_until(_SEMICOLON);
               end;
-            consume(_SEMICOLON);
+            if not (procparsemode in [ppm_nameless_routine,ppm_method_reference]) then
+              consume(_SEMICOLON);
           end;
         result:=pd;
 
@@ -3379,7 +3420,7 @@ const
             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);
+            currpd.add_to_procsym;
           end;
 
         proc_add_definition:=forwardfound;
diff --git a/closures/compiler/pmodules.pas b/closures/compiler/pmodules.pas
index d8c64a1124..d336ba4d68 100644
--- a/closures/compiler/pmodules.pas
+++ b/closures/compiler/pmodules.pas
@@ -927,8 +927,7 @@ implementation
         st.insert(ps);
         pd:=tprocdef.create(main_program_level);
         include(pd.procoptions,po_global);
-        pd.procsym:=ps;
-        ps.ProcdefList.Add(pd);
+        pd.add_to_procsym(ps);
         { set procdef options }
         pd.proctypeoption:=potype;
         pd.proccalloption:=pocall_default;
diff --git a/closures/compiler/psub.pas b/closures/compiler/psub.pas
index f3d681889e..3ff77154fb 100644
--- a/closures/compiler/psub.pas
+++ b/closures/compiler/psub.pas
@@ -28,7 +28,8 @@ interface
     uses
       cclasses,globals,
       node,nbas,
-      symdef,procinfo,optdfa;
+      symdef,procinfo,optdfa,
+      pdecsub;
 
     type
       tcgprocinfo = class(tprocinfo)
diff --git a/closures/compiler/ptype.pas b/closures/compiler/ptype.pas
index ab5fc03d2e..6cb1ec6b64 100644
--- a/closures/compiler/ptype.pas
+++ b/closures/compiler/ptype.pas
@@ -72,7 +72,7 @@ implementation
        nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
        { parser }
        scanner,
-       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil;
+       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,pnameless;
 
 
     procedure resolve_forward_types;
@@ -539,7 +539,7 @@ implementation
                       begin
                         oldparse_only:=parse_only;
                         parse_only:=true;
-                        pd:=parse_proc_dec(is_classdef,current_structdef);
+                        pd:=parse_proc_dec(current_structdef,ppm_class_method);
 
                         { this is for error recovery as well as forward }
                         { interface mappings, i.e. mapping to a method  }
@@ -604,7 +604,7 @@ implementation
               begin
                 oldparse_only:=parse_only;
                 parse_only:=true;
-                pd:=parse_proc_dec(is_classdef,current_structdef);
+                pd:=parse_proc_dec(current_structdef,as_procparsemode(is_classdef));
 
                 { this is for error recovery as well as forward }
                 { interface mappings, i.e. mapping to a method  }
@@ -1501,6 +1501,11 @@ implementation
               begin
                 def:=procvar_dec(genericdef,genericlist);
               end;
+            _ID:
+              if idtoken=_REFERENCE then // TODO: $mode Delphi only?
+                def:=parse_method_reference(name)
+              else
+                expr_type;
             else
               if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
                 begin
diff --git a/closures/compiler/symdef.pas b/closures/compiler/symdef.pas
index 4dea14eb01..3e80f620f4 100644
--- a/closures/compiler/symdef.pas
+++ b/closures/compiler/symdef.pas
@@ -580,6 +580,8 @@ interface
           function  is_methodpointer:boolean;override;
           function  is_addressonly:boolean;override;
           procedure make_external;
+          procedure add_to_procsym; overload; inline;
+          procedure add_to_procsym(sym: {tprocsym}tsym); overload; inline;
        end;
 
        { single linked list of overloaded procs }
@@ -3934,6 +3936,19 @@ implementation
       end;
 
 
+    procedure tprocdef.add_to_procsym; inline;
+      begin
+        tprocsym(procsym).ProcdefList.Add(self);
+      end;
+
+
+    procedure tprocdef.add_to_procsym(sym: {tprocsym}tsym); inline;
+      begin
+        procsym:=sym;
+        add_to_procsym;
+      end;
+
+
     procedure tprocdef.buildderef;
       begin
          inherited buildderef;
diff --git a/closures/compiler/tokens.pas b/closures/compiler/tokens.pas
index 404e20602d..6c79c0f3f2 100644
--- a/closures/compiler/tokens.pas
+++ b/closures/compiler/tokens.pas
@@ -257,6 +257,7 @@ type
     _PROCEDURE,
     _PROTECTED,
     _PUBLISHED,
+    _REFERENCE,
     _SOFTFLOAT,
     _THREADVAR,
     _WRITEONLY,
@@ -554,6 +555,7 @@ const
       (str:'PROCEDURE'     ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'PROTECTED'     ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'PUBLISHED'     ;special:false;keyword:m_none;op:NOTOKEN),
+      (str:'REFERENCE'     ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'SOFTFLOAT'     ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'THREADVAR'     ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'WRITEONLY'     ;special:false;keyword:m_none;op:NOTOKEN),