* finished basic support for calling methods from external C++ classes

(slightly modified patch by Sven Barth, mantis #15082)

git-svn-id: trunk@14185 -

.gitattributes

@@ -8240,22 +8240,27 @@ tests/test/cg/obj/beos/i386/ctest.o -text
 tests/test/cg/obj/beos/i386/tcext3.o -text
 tests/test/cg/obj/beos/i386/tcext4.o -text
 tests/test/cg/obj/beos/i386/tcext5.o -text
+tests/test/cg/obj/cpptcl1.cpp svneol=native#text/plain
 tests/test/cg/obj/darwin/arm/ctest.o -text
 tests/test/cg/obj/darwin/arm/tcext3.o -text
 tests/test/cg/obj/darwin/arm/tcext4.o -text
 tests/test/cg/obj/darwin/arm/tcext5.o -text
+tests/test/cg/obj/darwin/i386/cpptcl1.o -text
 tests/test/cg/obj/darwin/i386/ctest.o -text
 tests/test/cg/obj/darwin/i386/tcext3.o -text
 tests/test/cg/obj/darwin/i386/tcext4.o -text
 tests/test/cg/obj/darwin/i386/tcext5.o -text
+tests/test/cg/obj/darwin/powerpc/cpptcl1.o -text
 tests/test/cg/obj/darwin/powerpc/ctest.o -text
 tests/test/cg/obj/darwin/powerpc/tcext3.o -text
 tests/test/cg/obj/darwin/powerpc/tcext4.o -text
 tests/test/cg/obj/darwin/powerpc/tcext5.o -text
+tests/test/cg/obj/darwin/powerpc64/cpptcl1.o -text
 tests/test/cg/obj/darwin/powerpc64/ctest.o -text
 tests/test/cg/obj/darwin/powerpc64/tcext3.o -text
 tests/test/cg/obj/darwin/powerpc64/tcext4.o -text
 tests/test/cg/obj/darwin/powerpc64/tcext5.o -text
+tests/test/cg/obj/darwin/x86_64/cpptcl1.o -text
 tests/test/cg/obj/darwin/x86_64/ctest.o -text
 tests/test/cg/obj/darwin/x86_64/tcext3.o -text
 tests/test/cg/obj/darwin/x86_64/tcext4.o -text
@@ -8284,6 +8289,7 @@ tests/test/cg/obj/linux/arm/ctest.o -text
 tests/test/cg/obj/linux/arm/tcext3.o -text
 tests/test/cg/obj/linux/arm/tcext4.o -text
 tests/test/cg/obj/linux/arm/tcext5.o -text
+tests/test/cg/obj/linux/i386/cpptcl1.o -text
 tests/test/cg/obj/linux/i386/ctest.o -text
 tests/test/cg/obj/linux/i386/tcext3.o -text
 tests/test/cg/obj/linux/i386/tcext4.o -text
@@ -8425,6 +8431,7 @@ tests/test/cg/tcnvset.pp svneol=native#text/plain
 tests/test/cg/tcnvstr1.pp svneol=native#text/plain
 tests/test/cg/tcnvstr2.pp svneol=native#text/plain
 tests/test/cg/tcnvstr3.pp svneol=native#text/plain
+tests/test/cg/tcppcl1.pp svneol=native#text/plain
 tests/test/cg/tderef.pp svneol=native#text/plain
 tests/test/cg/tdivz1.pp svneol=native#text/plain
 tests/test/cg/tdivz2.pp svneol=native#text/plain

compiler/pdecl.pas

@@ -47,6 +47,7 @@ interface
 implementation
 
     uses
+       SysUtils,
        { common }
        cutils,cclasses,
        { global }
@@ -283,6 +284,50 @@ implementation
 
     procedure types_dec;
 
+      procedure get_cpp_class_external_status(od: tobjectdef);
+        var
+          hs: string;
+
+        begin
+          { C++ classes can be external -> all methods inside are external
+           (defined at the class level instead of per method, so that you cannot
+           define some methods as external and some not)
+          }
+          if (token=_ID) and
+             (idtoken=_EXTERNAL) then
+            begin
+              consume(_EXTERNAL);
+              { copied from pdecsub.pd_external }
+              if not(token=_SEMICOLON) and not(idtoken=_NAME) then
+                begin
+                  { Always add library prefix and suffix to create an uniform name }
+                  hs:=get_stringconst;
+                  if ExtractFileExt(hs)='' then
+                    hs:=ChangeFileExt(hs,target_info.sharedlibext);
+                  if Copy(hs,1,length(target_info.sharedlibprefix))<>target_info.sharedlibprefix then
+                    hs:=target_info.sharedlibprefix+hs;
+                  od.import_lib:=stringdup(hs);
+                end;
+              include(od.objectoptions, oo_is_external);
+              { check if we shall use another name for the class }
+              if (token=_ID) and
+                 (idtoken=_NAME) then
+                begin
+                  consume(_NAME);
+                  od.objextname:=stringdup(get_stringconst);
+                end
+              else
+                od.objextname:=stringdup(od.objrealname^);
+              consume(_SEMICOLON);
+              { now all methods need to be external }
+              od.make_all_methods_external;
+              include(od.objectoptions,oo_is_external);
+            end
+          else
+            od.objextname:=stringdup(od.objrealname^);
+          { ToDo: read the namespace of the class (influences the mangled name)}
+        end;
+
       procedure get_objc_class_or_protocol_external_status(od: tobjectdef);
         begin
           { Objective-C classes can be external -> all messages inside are
@@ -520,6 +565,9 @@ implementation
                     if is_objc_class_or_protocol(hdef) then
                       get_objc_class_or_protocol_external_status(tobjectdef(hdef));
 
+                    if is_cppclass(hdef) then
+                      get_cpp_class_external_status(tobjectdef(hdef));
+
                     { Build VMT indexes, skip for type renaming and forward classes }
                     if (hdef.typesym=newtype) and
                        not(oo_is_forward in tobjectdef(hdef).objectoptions) and
@@ -539,6 +587,9 @@ implementation
                     }
                     if is_objc_class_or_protocol(hdef) then
                       tobjectdef(hdef).finish_objc_data;
+
+                    if is_cppclass(hdef) then
+                      tobjectdef(hdef).finish_cpp_data;
                   end;
                 recorddef :
                   begin

compiler/pdecobj.pas

@@ -486,12 +486,9 @@ implementation
 
 
         procedure chkcpp(pd:tprocdef);
-        begin
+          begin
-           if is_cppclass(pd._class) then
+            { nothing currently }
-            begin
+          end;
-              pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
-            end;
-        end;
 
         procedure maybe_parse_hint_directives(pd:tprocdef);
         var

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion = 104;
+  CurrentPPUVersion = 105;
 
 { buffer sizes }
   maxentrysize = 1024;

compiler/symdef.pas

@@ -240,6 +240,8 @@ interface
           childof        : tobjectdef;
           childofderef   : tderef;
 
+          { for C++ classes: name of the library this class is imported from }
+          import_lib,
           objname,
           objrealname,
           { for Objective-C: protocols and classes can have the same name there }
@@ -308,9 +310,12 @@ interface
           procedure register_maybe_created_object_type;
           procedure register_created_classref_type;
           procedure register_vmt_call(index:longint);
-          { ObjC }
+          { ObjC & C++ }
           procedure make_all_methods_external;
+          { ObjC }
           procedure finish_objc_data;
+          { C++ }
+          procedure finish_cpp_data;
        end;
 
        tclassrefdef = class(tabstractpointerdef)
@@ -3437,12 +3442,25 @@ implementation
       function getcppparaname(p : tdef) : string;
 
         const
+{$ifdef NAMEMANGLING_GCC2}
            ordtype2str : array[tordtype] of string[2] = (
              '',
              'Uc','Us','Ui','Us',
              'Sc','s','i','x',
              'b','b','b','b','b',
              'c','w','x');
+{$else NAMEMANGLING_GCC2}
+           ordtype2str : array[tordtype] of string[1] = (
+             'v',
+             'h','t','j','y',
+             'a','s','i','x',
+             'b','b','b','b','b',
+             'c','w','x');
+
+           floattype2str : array[tfloattype] of string[1] = (
+             'f','d','e',
+             'd','d','g');
+{$endif NAMEMANGLING_GCC2}
 
         var
            s : string;
@@ -3453,6 +3471,10 @@ implementation
                 s:=ordtype2str[torddef(p).ordtype];
               pointerdef:
                 s:='P'+getcppparaname(tpointerdef(p).pointeddef);
+{$ifndef NAMEMANGLING_GCC2}
+              floatdef:
+                s:=floattype2str[tfloatdef(p).floattype];
+{$endif NAMEMANGLING_GCC2}
               else
                 internalerror(2103001);
            end;
@@ -3465,9 +3487,9 @@ implementation
          i    : integer;
 
       begin
-        { outdated gcc 2.x name mangling scheme }
 {$ifdef NAMEMANGLING_GCC2}
 
+        { outdated gcc 2.x name mangling scheme }
          s := procsym.realname;
          if procsym.owner.symtabletype=ObjectSymtable then
            begin
@@ -3510,14 +3532,15 @@ implementation
          else
            s:=s+'v';
          cplusplusmangledname:=s;
-{$endif NAMEMANGLING_GCC2}
+{$else NAMEMANGLING_GCC2}
 
-         { gcc 3.x name mangling scheme }
+         { gcc 3.x and 4.x name mangling scheme }
+         { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
          if procsym.owner.symtabletype=ObjectSymtable then
            begin
              s:='_ZN';
 
-             s2:=tobjectdef(procsym.owner.defowner).objrealname^;
+             s2:=tobjectdef(procsym.owner.defowner).objextname^;
              s:=s+tostr(length(s2))+s2;
              case proctypeoption of
                 potype_constructor:
@@ -3539,6 +3562,12 @@ implementation
              for i:=0 to paras.count-1 do
                begin
                  hp:=tparavarsym(paras[i]);
+                 { no hidden parameters form part of a C++ mangled name:
+                     a) self is not included
+                     b) there are no "high" or other hidden parameters
+                 }
+                 if vo_is_hidden_para in hp.varoptions then
+                   continue;
                  s2:=getcppparaname(hp.vardef);
                  if hp.varspez in [vs_var,vs_out] then
                    s2:='R'+s2;
@@ -3548,6 +3577,7 @@ implementation
          else
            s:=s+'v';
          cplusplusmangledname:=s;
+{$endif NAMEMANGLING_GCC2}
       end;
 
 
@@ -3778,6 +3808,10 @@ implementation
          { only used for external Objective-C classes/protocols }
          if (objextname^='') then
            stringdispose(objextname);
+         import_lib:=stringdup(ppufile.getstring);
+         { only used for external C++ classes }
+         if (import_lib^='') then
+           stringdispose(import_lib);
          symtable:=tObjectSymtable.create(self,objrealname^,0);
          tObjectSymtable(symtable).datasize:=ppufile.getaint;
          tObjectSymtable(symtable).fieldalignment:=ppufile.getbyte;
@@ -3857,6 +3891,7 @@ implementation
          stringdispose(objname);
          stringdispose(objrealname);
          stringdispose(objextname);
+         stringdispose(import_lib);
          stringdispose(iidstr);
          if assigned(ImplementedInterfaces) then
            begin
@@ -3897,6 +3932,8 @@ implementation
           tobjectdef(result).objrealname:=stringdup(objrealname^);
         if assigned(objextname) then
           tobjectdef(result).objextname:=stringdup(objextname^);
+        if assigned(import_lib) then
+          tobjectdef(result).import_lib:=stringdup(import_lib^);
         tobjectdef(result).objectoptions:=objectoptions;
         include(tobjectdef(result).defoptions,df_copied_def);
         tobjectdef(result).vmt_offset:=vmt_offset;
@@ -3933,6 +3970,10 @@ implementation
            ppufile.putstring(objextname^)
          else
            ppufile.putstring('');
+         if assigned(import_lib) then
+           ppufile.putstring(import_lib^)
+         else
+           ppufile.putstring('');
          ppufile.putaint(tObjectSymtable(symtable).datasize);
          ppufile.putbyte(tObjectSymtable(symtable).fieldalignment);
          ppufile.putbyte(tObjectSymtable(symtable).recordalignment);
@@ -4681,6 +4722,37 @@ implementation
       end;
 
 
+    procedure do_cpp_import_info(data: tobject; arg: pointer);
+      var
+        def: tdef absolute data;
+        pd: tprocdef absolute data;
+      begin
+        if (def.typ=procdef) then
+          begin
+            pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
+            if (oo_is_external in pd._class.objectoptions) then
+              begin
+                { copied from psub.read_proc }
+                if assigned(pd._class.import_lib) then
+                   current_module.AddExternalImport(pd._class.import_lib^,pd.mangledname,0,false,false)
+                 else
+                   begin
+                     { add import name to external list for DLL scanning }
+                     if tf_has_dllscanner in target_info.flags then
+                       current_module.dllscannerinputlist.Add(pd.mangledname,pd);
+                   end;
+
+              end;
+          end;
+      end;
+
+
+    procedure tobjectdef.finish_cpp_data;
+      begin
+        self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
+      end;
+
+
 {****************************************************************************
                              TImplementedInterface
 ****************************************************************************}

tests/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/11/13]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/11/15]
 #
 default: allexectests
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@@ -1489,11 +1489,13 @@ ifneq ($(TEST_ABI),)
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext3.o test/cg
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext4.o test/cg
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext5.o test/cg
+	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/cpptcl1.o test/cg
 else
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/ctest.o test/cg
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext3.o test/cg
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext4.o test/cg
 	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext5.o test/cg
+	$(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/cpptcl1.o test/cg
 endif
 	-$(MKDIRTREE) $(TEST_OUTPUTDIR)/test/units/system
 	$(COPY) test/units/system/test*.txt $(TEST_OUTPUTDIR)/test/units/system

tests/Makefile.fpc

@@ -174,11 +174,13 @@ ifneq ($(TEST_ABI),)
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext3.o test/cg
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext4.o test/cg
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/tcext5.o test/cg
+        $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)-$(TEST_ABI)/cpptcl1.o test/cg
 else
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/ctest.o test/cg
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext3.o test/cg
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext4.o test/cg
         $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/tcext5.o test/cg
+        $(COPY) test/cg/obj/$(TEST_OS_TARGET)/$(TEST_CPU_TARGET)/cpptcl1.o test/cg
 endif
         -$(MKDIRTREE) $(TEST_OUTPUTDIR)/test/units/system
         $(COPY) test/units/system/test*.txt $(TEST_OUTPUTDIR)/test/units/system

tests/test/cg/obj/cpptcl1.cpp

@@ -0,0 +1,77 @@
+// compile as
+// gcc -fno-exceptions -c -o cpptestclass1.o cpptestclass1.cpp
+
+class TestClass
+{
+  public:
+    static void Test1();
+    /* boolean */
+    static void Test2(bool aArg1);
+    /* unsigned ordinals */
+    static void Test3(unsigned char aArg1);
+    static void Test4(unsigned short aArg1);
+    static void Test5(unsigned int aArg1);
+    static void Test6(unsigned long long aArg1);
+    /* signed ordinals */
+    static void Test7(signed char aArg1);
+    static void Test8(signed short aArg1);
+    static void Test9(signed int aArg1);
+    static void Test10(signed long long aArg1);
+    /* floating point */
+    static void Test11(float aArg1);
+    static void Test12(double aArg1);
+    /* chars */
+    static void Test13(char aArg1);
+    static void Test14(wchar_t aArg1);
+    /* pointers */
+    static void Test15(void* aArg1);
+    static void Test16(char* aArg1);
+    static void Test17(wchar_t* aArg1);
+    static void Test18(unsigned int* aArg1);
+    static void Test19(float* aArg1);
+    /* by reference */
+    static void Test20(signed int& aArg1);
+    static void Test21(unsigned int& aArg1);
+    static void Test22(void*& aArg1);
+    static void Test23(char& aArg1);
+    static void Test24(float& aArg1);
+    /* combinations */
+    static void Test25(unsigned char aArg1, unsigned short aArg2, unsigned int aArg3, unsigned long long aArg4);
+    static void Test26(void* aArg1, char& aArg2, float aArg3);
+};
+
+void TestClass::Test1() { };
+/* boolean */
+void TestClass::Test2(bool aArg1){ };
+/* unsigned ordinals */
+void TestClass::Test3(unsigned char aArg1){ };
+void TestClass::Test4(unsigned short aArg1){ };
+void TestClass::Test5(unsigned int aArg1){ };
+void TestClass::Test6(unsigned long long aArg1){ };
+/* signed ordinals */
+void TestClass::Test7(signed char aArg1){ };
+void TestClass::Test8(signed short aArg1){ };
+void TestClass::Test9(signed int aArg1){ };
+void TestClass::Test10(signed long long aArg1){ };
+/* floating point */
+void TestClass::Test11(float aArg1){ };
+void TestClass::Test12(double aArg1){ };
+/* chars */
+void TestClass::Test13(char aArg1){ };
+void TestClass::Test14(wchar_t aArg1){ };
+/* pointers */
+void TestClass::Test15(void* aArg1){ };
+void TestClass::Test16(char* aArg1){ };
+void TestClass::Test17(wchar_t* aArg1){ };
+void TestClass::Test18(unsigned int* aArg1){ };
+void TestClass::Test19(float* aArg1){ };
+/* by reference */
+void TestClass::Test20(signed int& aArg1){ };
+void TestClass::Test21(unsigned int& aArg1){ };
+void TestClass::Test22(void*& aArg1){ };
+void TestClass::Test23(char& aArg1){ };
+void TestClass::Test24(float& aArg1){ };
+/* combinations */
+void TestClass::Test25(unsigned char aArg1, unsigned short aArg2, unsigned int aArg3, unsigned long long aArg4){ };
+void TestClass::Test26(void* aArg1, char& aArg2, float aArg3){ };
+

tests/test/cg/tcppcl1.pp

@@ -0,0 +1,95 @@
+{%CPU=i386}
+{%TARGET=linux,darwin}
+{ Test the C++ name mangling for different parameter combinations }
+program tcppclass1;
+
+{$mode objfpc}
+{$L cpptcl1.o}
+
+type
+  TestClass = cppclass
+    class procedure Test1;
+    { boolean }
+    class procedure Test2(aArg1: Boolean);
+    { unsigned ordinals }
+    class procedure Test3(aArg1: Byte);
+    class procedure Test4(aArg1: Word);
+    class procedure Test5(aArg1: LongWord);
+    class procedure Test6(aArg1: QWord);
+    { signed ordinals }
+    class procedure Test7(aArg1: ShortInt);
+    class procedure Test8(aArg1: SmallInt);
+    class procedure Test9(aArg1: LongInt);
+    class procedure Test10(aArg1: Int64);
+    { floating point }
+    class procedure Test11(aArg1: Single);
+    class procedure Test12(aArg1: Double);
+    { chars }
+    class procedure Test13(aArg1: Char);
+    class procedure Test14(aArg1: WideChar);
+    { pointers }
+    class procedure Test15(aArg1: Pointer);
+    class procedure Test16(aArg1: PChar);
+    class procedure Test17(aArg1: PWideChar);
+    class procedure Test18(aArg1: PLongWord);
+    class procedure Test19(aArg1: PSingle);
+    { by reference }
+    class procedure Test20(var aArg1: LongInt);
+    class procedure Test21(var aArg1: LongWord);
+    class procedure Test22(var aArg1: Pointer);
+    class procedure Test23(var aArg1: Char);
+    class procedure Test24(var aArg1: Single);
+    { combinations }
+    class procedure Test25(aArg1: Byte; aArg2: Word; aArg3: LongWord; aArg4: QWord);
+    class procedure Test26(aArg1: Pointer; var aArg2: Char; aArg3: Single);
+  end; external;
+
+const
+  HelloWorld = 'Hello World';
+var
+  li: LongInt = -42;
+  lw: LongWord = 42;
+  p: Pointer = Nil;
+  c: Char = 'a';
+  s: Single = 3.1416;
+begin
+  try
+    TestClass.Test1;
+    { boolean}
+    TestClass.Test2(True);
+    { unsigned ordinals }
+    TestClass.Test3(42);
+    TestClass.Test4(42);
+    TestClass.Test5(42);
+    TestClass.Test6(42);
+    { signed ordinals }
+    TestClass.Test7(-42);
+    TestClass.Test8(-42);
+    TestClass.Test9(-42);
+    TestClass.Test10(-42);
+    { floating point }
+    TestClass.Test11(3.1416);
+    TestClass.Test12(3.1416);
+    { chars }
+    TestClass.Test13('a');
+    TestClass.Test14('a');
+    { pointers }
+    TestClass.Test15(Nil);
+    TestClass.Test16(Nil);
+    TestClass.Test17(Nil);
+    TestClass.Test18(Nil);
+    TestClass.Test19(Nil);
+    { by reference }
+    TestClass.Test20(li);
+    TestClass.Test21(lw);
+    TestClass.Test22(p);
+    TestClass.Test23(c);
+    TestClass.Test24(s);
+    { combinations }
+    TestClass.Test25(42, 42, 42, 42);
+    TestClass.Test26(Nil, c, 3.1416);
+  except
+    ExitCode := 1;
+  end;
+end.
+