Browse Source

Add a new warning message that is generated if an instance of an abstract class is created. This message is disabled by default, but can be switched on by using {$warn 4122 on} or {$warn 4122 error}.

Please note that this warning won't be triggered if an instance of that class is created using a class variable of that class type as the compiler can not know the type contained in the variable at compile time (see also the added test).

+ msg/errore.msg: added disabled message which informs about the instantiation of an abstract class
* pexpr.pas, do_member_read: generate the message if we have a constructor call for an abstract class using a loadvmtaddrnode (thus the type name is used and not a class variable)

* msg{idx,txt}.inc: updated

+ added test

git-svn-id: trunk@28127 -
svenbarth 11 years ago
parent
commit
a7a9440692
6 changed files with 371 additions and 323 deletions
  1. 1 0
      .gitattributes
  2. 4 1
      compiler/msg/errore.msg
  3. 3 2
      compiler/msgidx.inc
  4. 323 320
      compiler/msgtxt.inc
  5. 10 0
      compiler/pexpr.pas
  6. 30 0
      tests/tbf/tb0247.pp

+ 1 - 0
.gitattributes

@@ -9616,6 +9616,7 @@ tests/tbf/tb0243.pp svneol=native#text/pascal
 tests/tbf/tb0244.pp svneol=native#text/pascal
 tests/tbf/tb0244.pp svneol=native#text/pascal
 tests/tbf/tb0245.pp svneol=native#text/pascal
 tests/tbf/tb0245.pp svneol=native#text/pascal
 tests/tbf/tb0246.pp svneol=native#text/pascal
 tests/tbf/tb0246.pp svneol=native#text/pascal
+tests/tbf/tb0247.pp svneol=native#text/pascal
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain

+ 4 - 1
compiler/msg/errore.msg

@@ -1534,7 +1534,7 @@ parser_w_ptr_type_ignored=03338_W_Pointer type "$1" ignored
 %
 %
 # Type Checking
 # Type Checking
 #
 #
-# 04121 is the last used one
+# 04122 is the last used one
 #
 #
 % \section{Type checking errors}
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
 % This section lists all errors that can occur when type checking is
@@ -1961,6 +1961,9 @@ type_e_type_not_allowed_for_type_helper=04120_E_Type "$1" cannot be extended by
 type_e_procedure_must_be_far=04121_E_Procedure or function must be far in order to allow taking its address: "$1"
 type_e_procedure_must_be_far=04121_E_Procedure or function must be far in order to allow taking its address: "$1"
 % In certain i8086 memory models (medium, large and huge), procedures and functions
 % In certain i8086 memory models (medium, large and huge), procedures and functions
 % have to be declared 'far' in order to allow their address to be taken.
 % have to be declared 'far' in order to allow their address to be taken.
+type_w_instance_abstract_class=04122_-W_Creating an instance of abstract class "$1"
+% The specified class is declared as \var{abstract} and thus no instance of this class
+% should be created. This is merely a warning for Delphi compatibility.
 % \end{description}
 % \end{description}
 #
 #
 # Symtable
 # Symtable

+ 3 - 2
compiler/msgidx.inc

@@ -552,6 +552,7 @@ const
   type_e_invalid_default_value=04119;
   type_e_invalid_default_value=04119;
   type_e_type_not_allowed_for_type_helper=04120;
   type_e_type_not_allowed_for_type_helper=04120;
   type_e_procedure_must_be_far=04121;
   type_e_procedure_must_be_far=04121;
+  type_w_instance_abstract_class=04122;
   sym_e_id_not_found=05000;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
   sym_e_duplicate_id=05002;
@@ -993,9 +994,9 @@ const
   option_info=11024;
   option_info=11024;
   option_help_pages=11025;
   option_help_pages=11025;
 
 
-  MsgTxtSize = 71922;
+  MsgTxtSize = 71975;
 
 
   MsgIdxMax : array[1..20] of longint=(
   MsgIdxMax : array[1..20] of longint=(
-    26,99,339,122,89,57,126,27,202,64,
+    26,99,339,123,89,57,126,27,202,64,
     58,20,1,1,1,1,1,1,1,1
     58,20,1,1,1,1,1,1,1,1
   );
   );

File diff suppressed because it is too large
+ 323 - 320
compiler/msgtxt.inc


+ 10 - 0
compiler/pexpr.pas

@@ -1278,6 +1278,16 @@ implementation
                              (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
                              (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
                              (tcallnode(p1).procdefinition.owner.defowner<>find_real_class_definition(tobjectdef(structh),false)) then
                              (tcallnode(p1).procdefinition.owner.defowner<>find_real_class_definition(tobjectdef(structh),false)) then
                             Message(parser_e_java_no_inherited_constructor);
                             Message(parser_e_java_no_inherited_constructor);
+                          { Provide a warning if we try to create an instance of a
+                            abstract class using the type name of that class. We
+                            must not provide a warning if we use a "class of"
+                            variable of that type though as we don't know the
+                            type of the class }
+                          if (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
+                              (oo_is_abstract in structh.objectoptions) and
+                              assigned(tcallnode(p1).methodpointer) and
+                              (tcallnode(p1).methodpointer.nodetype=loadvmtaddrn) then
+                            Message1(type_w_instance_abstract_class,structh.RttiName);
                         end;
                         end;
                    end;
                    end;
                  fieldvarsym:
                  fieldvarsym:

+ 30 - 0
tests/tbf/tb0247.pp

@@ -0,0 +1,30 @@
+{ %FAIL }
+
+program tb0247;
+
+{$WARN 4122 ERROR}
+
+{$mode objfpc}
+
+type
+  TTest = class abstract
+
+  end;
+
+  TTestClass = class of TTest;
+
+  TTestSub = class
+
+  end;
+
+var
+  o: TObject;
+  c: TTestClass;
+begin
+  { this should not create an error }
+  o := c.Create;
+  { this neither }
+  o := TTestSub.Create;
+  { but this should create an error }
+  o := TTest.Create;
+end.

Some files were not shown because too many files changed in this diff