* fixed generation of constants containing a vmt

* better error message if such a construct is used in fpc where it isn't allowed

git-svn-id: trunk@5838 -

.gitattributes

@@ -7889,6 +7889,7 @@ tests/webtbs/tw5094.pp -text
 tests/webtbs/tw5100.pp svneol=native#text/plain
 tests/webtbs/tw5100a.pp svneol=native#text/plain
 tests/webtbs/tw5641.pp svneol=native#text/plain
+tests/webtbs/tw6129.pp svneol=native#text/plain
 tests/webtbs/tw6184.pp -text
 tests/webtbs/tw6203.pp svneol=native#text/plain
 tests/webtbs/tw6435.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -453,7 +453,7 @@ parser_e_double_caselabel=03037_E_duplicate case label
 parser_e_case_lower_less_than_upper_bound=03038_E_Upper bound of case range is less than lower bound
 % The upper bound of a \var{case} label is less than the lower bound and this
 % is useless
-parser_e_type_const_not_possible=03039_E_typed constants of classes are not allowed
+parser_e_type_const_not_possible=03039_E_typed constants of classes or interfaces are not allowed
 % You cannot declare a constant of type class or object.
 parser_e_no_overloaded_procvars=03040_E_functions variables of overloaded functions are not allowed
 % You are trying to assign an overloaded function to a procedural variable.
@@ -1110,6 +1110,10 @@ parser_e_special_onlygenerics=03228_E_Specialization is only supported for gener
 parser_e_no_generics_as_params=03229_E_Generics can't be used as parameters when spezializing generics
 % When specializing a generic, only non-generic types can be used as parameters
 %
+parser_e_type_object_constants=03230_E_Constants of objects containing a VMT aren't allowed
+% If an object requires a VMT either because it contains a constructor or virtual methods,
+% it's not allowed to create constants of it. In TP and Delphi mode this is allowed
+% for compatibility reasons.
 #
 # Type Checking
 #

compiler/msgidx.inc

@@ -314,6 +314,7 @@ const
   parser_e_no_funcret_specified=03227;
   parser_e_special_onlygenerics=03228;
   parser_e_no_generics_as_params=03229;
+  parser_e_type_object_constants=03230;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -714,9 +715,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 42410;
+  MsgTxtSize = 42485;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,82,230,79,63,48,106,22,135,60,
+    24,82,231,79,63,48,106,22,135,60,
     41,1,1,1,1,1,1,1,1,1
   );

compiler/ptconst.pas

@@ -908,6 +908,7 @@ implementation
           st     : tsymtable;
           curroffset : aint;
           s,sorg : TIDString;
+          vmtwritten : boolean;
         begin
           { no support for packed object }
           if is_packed_record_or_object(def) then
@@ -935,12 +936,13 @@ implementation
           if (oo_has_vmt in def.objectoptions) and
              (m_fpc in current_settings.modeswitches) then
             begin
-              Message(parser_e_type_const_not_possible);
+              Message(parser_e_type_object_constants);
               exit;
             end;
 
           consume(_LKLAMMER);
           curroffset:=0;
+          vmtwritten:=false;
           while token<>_RKLAMMER do
             begin
               s:=pattern;
@@ -974,7 +976,8 @@ implementation
                       message(parser_e_invalid_record_const);
 
                     { check in VMT needs to be added for TP mode }
-                    if not(m_fpc in current_settings.modeswitches) and
+                    if not(vmtwritten) and
+                       not(m_fpc in current_settings.modeswitches) and
                        (oo_has_vmt in def.objectoptions) and
                        (def.vmt_offset<fieldoffset) then
                       begin
@@ -983,6 +986,7 @@ implementation
                         list.concat(tai_const.createname(def.vmt_mangledname,0));
                         { this is more general }
                         curroffset:=def.vmt_offset + sizeof(aint);
+                        vmtwritten:=true;
                       end;
 
                     { if needed fill }

tests/webtbs/tw6129.pp

@@ -0,0 +1,44 @@
+{$mode tp}
+program objarray;
+
+type
+
+TAny = object
+public
+  constructor Init;
+end;
+
+TNameIndex = object(TAny)
+  Name : ^string;
+  Index: integer;
+end;
+
+constructor TAny.Init;
+begin
+end;
+
+const
+
+S0: string[5]='Obj-0';
+S1: string[5]='Obj-1';
+S2: string[5]='Obj-2';
+
+Table: array[0..2] of TNameIndex = (
+  (Name:@S0; Index:0),
+  (Name:@S1; Index:1),
+  (Name:@S2; Index:2)
+);
+
+begin
+  WriteLn('@S0            = ',longint(@S0));
+  WriteLn('@S1            = ',longint(@S1));
+  WriteLn('@S2            = ',longint(@S2));
+
+  WriteLn('Table[0].Name  = ',longint(Table[0].Name));
+  WriteLn('Table[1].Name  = ',longint(Table[1].Name));
+  WriteLn('Table[2].Name  = ',longint(Table[2].Name));
+
+  WriteLn('Table[0].Name^ = ',Table[0].Name^);
+  WriteLn('Table[1].Name^ = ',Table[1].Name^);
+  WriteLn('Table[2].Name^ = ',Table[2].Name^);
+end.