Patchwork [Ada] Constraints on class-wide types are ignored

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 10, 2013, 3:21 p.m.
Message ID <20130910152153.GA31274@adacore.com>
Download mbox | patch
Permalink /patch/273917/
State New
Headers show

Comments

Arnaud Charlet - Sept. 10, 2013, 3:21 p.m.
A class-wide type has anonymous discriminants, because type extensions can
add discriminants at will.  A constraint on a class-wide type is thus a partial
constraint that applies only to the known discriminants of the root type. Such
a partial constraint is a language pathology that the ARG has decided not to
test. This patch simply discards such a constraint on an access type, so that
the designated type includes all (unconstrained) extensions of the root type.

The following must compile with the warning:

   volumes.ads:9:24: warning: constraint on class-wide type ignored

---
package Volumes is
   type VolumeWidgetType (Stereo : boolean) is tagged
      record
        IsStereo : boolean := Stereo;
      end record;

   type VolumeWidget is access all VolumeWidgetType'Class;

   Mic1 : VolumeWidget (Stereo => False);

end Volumes;

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-09-10  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Process_Subtype): Discard constraint on access
	to class-wide type. Such constraints are not supported and are
	considered a language pathology.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 202461)
+++ sem_ch3.adb	(working copy)
@@ -19043,6 +19043,27 @@ 
 
          case Ekind (Base_Type (Subtype_Mark_Id)) is
             when Access_Kind =>
+
+               --  If this is a constraint on a class-wide type, discard it.
+               --  There is currently no way to express a partial discriminant
+               --  constraint on a type with unknown discriminants. This is
+               --  a pathology that the ACATS wisely decides not to test.
+
+               if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
+                  if Comes_From_Source (S) then
+                     Error_Msg_N
+                       ("constraint on class-wide type ignored?",
+                        Constraint (S));
+                  end if;
+
+                  if Nkind (P) = N_Subtype_Declaration then
+                     Set_Subtype_Indication (P,
+                        New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
+                  end if;
+
+                  return Subtype_Mark_Id;
+               end if;
+
                Constrain_Access (Def_Id, S, Related_Nod);
 
                if Expander_Active