From patchwork Fri Oct 22 14:36:00 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68864 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 05A43B70A9 for ; Sat, 23 Oct 2010 01:36:16 +1100 (EST) Received: (qmail 10166 invoked by alias); 22 Oct 2010 14:36:13 -0000 Received: (qmail 9815 invoked by uid 22791); 22 Oct 2010 14:36:09 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 22 Oct 2010 14:36:02 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 65635CB0221; Fri, 22 Oct 2010 16:36:00 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 6wc9FvWcEw+T; Fri, 22 Oct 2010 16:36:00 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 4F067CB01EC; Fri, 22 Oct 2010 16:36:00 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 2D014D9BB4; Fri, 22 Oct 2010 16:36:00 +0200 (CEST) Date: Fri, 22 Oct 2010 16:36:00 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Handling of predicate type errors in generics Message-ID: <20101022143600.GA19392@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org All errors in generics where improper use of generic actuals that have predicates should generate program error exceptions and warnings rather than errors. The following is updated output from a test that includes these cases (compiled with -gnata12 -gnatj60 -gnatld7). 1. procedure Bad_Predicates is 2. -- This test should get compile-time errors 3. 4. type Color is 5. (Red, Orange, Yellow, Green, 6. Blue, Indigo, Violet); 7. subtype RGB is Color with 8. Predicate => 9. RGB = Red or RGB in Green .. Blue; 10. subtype Other_Color is Color with 11. Predicate => Other_Color not in RGB; 12. 13. subtype Another_Color is Other_Color; | >>> info: "Another_Color" inherits predicate from "Other_Color" at line 10 14. 15. type Bad_Array is array 16. (Another_Color range <>) of Character; | >>> subtype "Another_Color" has predicate, not allowed as index subtype 17. -- ERROR: Subtype with predicate not 18. -- allowed as index subtype 19. 20. type OK_Array is array 21. (Color range <>) of Character; 22. 23. subtype Bad_Array_Subtype is 24. OK_Array (Another_Color); | >>> subtype "Another_Color" has predicate, not allowed in index constraint 25. -- ERROR: Subtype with predicate not 26. -- allowed in index_constraint 27. 28. OK : constant OK_Array := (Color => 'x'); 29. 30. Bad_Slice : constant OK_Array := 31. OK (Another_Color); | >>> subtype "Another_Color" has predicate, not allowed in slice 32. -- ERROR: Subtype with predicate not 33. -- allowed in slice 34. 35. protected type Prot is 36. entry Bad_Family 37. (Another_Color) (X : Integer); | >>> subtype "Another_Color" has predicate, not allowed in entry family 38. -- ERROR: Subtype with predicate not 39. -- allowed in entry family 40. end Prot; 41. 42. protected body Prot is 43. entry Bad_Family (for J in Another_Color) 44. (X : Integer) 45. when True 46. is 47. begin null; end; 48. end Prot; 49. 50. -- Same set of checks in a generic 51. 52. generic 53. type Another_Color is (<>); 54. package T is 55. type Bad_Array is array 56. (Another_Color range <>) of Character; 57. -- ERROR: Subtype with predicate not 58. -- allowed as index subtype 59. 60. subtype Bad_Array_Subtype is 61. Bad_Array (Another_Color); 62. -- ERROR: Subtype with predicate not 63. -- allowed in index_constraint 64. 65. protected type Prot is 66. entry Bad_Family 67. (Another_Color) (X : Integer); 68. -- ERROR: Subtype with predicate not 69. -- allowed in entry family 70. end Prot; 71. end T; 72. 73. package body T is 74. protected body Prot is 75. entry Bad_Family (for J in Another_Color) 76. (X : Integer) 77. when True 78. is 79. begin null; end; 80. end Prot; 81. end; 82. 83. package TT is new T (Another_Color); | >>> warning: in instantiation at line 56, subtype "Another_Color" has predicate, not allowed as index subtype, Program_Error will be raised at run time >>> warning: in instantiation at line 61, subtype "Another_Color" has predicate, not allowed in index constraint, Program_Error will be raised at run time >>> warning: in instantiation at line 67, subtype "Another_Color" has predicate, not allowed in entry family, Program_Error will be raised at run time 84. 85. begin 86. null; 87. end Bad_Predicates; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-22 Robert Dewar * sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order of parameters. * sem_ch13.adb (Build_Predicate_Function): Don't give inheritance messages for generic actual subtypes. * sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb (Bad_Predicated_Subtype_Use): Use this procedure. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165828) +++ sem_ch3.adb (working copy) @@ -4429,11 +4429,9 @@ package body Sem_Ch3 is -- Check error of subtype with predicate for index type - if Has_Predicates (Etype (Index)) then - Error_Msg_NE - ("subtype& has predicate, not allowed as index subtype", - Index, Etype (Index)); - end if; + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed as index subtype", + Index, Etype (Index)); -- Move to next index @@ -11402,9 +11400,9 @@ package body Sem_Ch3 is -- Check error of subtype with predicate in index constraint - elsif Has_Predicates (Entity (S)) then - Error_Msg_NE - ("subtype& has predicate, not allowed in index consraint", + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", S, Entity (S)); end if; Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 165805) +++ sem_ch9.adb (working copy) @@ -894,11 +894,9 @@ package body Sem_Ch9 is -- Check subtype with predicate in entry family - if Has_Predicates (Etype (D_Sdef)) then - Error_Msg_NE - ("subtype& has predicate, not allowed in entry family", - D_Sdef, Etype (D_Sdef)); - end if; + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); end if; -- Decorate Def_Id Index: sem_util.adb =================================================================== --- sem_util.adb (revision 165828) +++ sem_util.adb (working copy) @@ -334,21 +334,21 @@ package body Sem_Util is -------------------------------- procedure Bad_Predicated_Subtype_Use - (Typ : Entity_Id; + (Msg : String; N : Node_Id; - Msg : String) + Typ : Entity_Id) is begin if Has_Predicates (Typ) then if Is_Generic_Actual_Type (Typ) then - Error_Msg_F (Msg & '?', Typ); - Error_Msg_F ("\Program_Error will be raised at run time?", Typ); + Error_Msg_FE (Msg & '?', N, Typ); + Error_Msg_F ("\Program_Error will be raised at run time?", N); Insert_Action (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Bad_Predicated_Generic_Type)); else - Error_Msg_F (Msg, Typ); + Error_Msg_FE (Msg, N, Typ); end if; end if; end Bad_Predicated_Subtype_Use; Index: sem_util.ads =================================================================== --- sem_util.ads (revision 165828) +++ sem_util.ads (working copy) @@ -94,18 +94,19 @@ package Sem_Util is -- whether an error or warning is given. procedure Bad_Predicated_Subtype_Use - (Typ : Entity_Id; + (Msg : String; N : Node_Id; - Msg : String); + Typ : Entity_Id); -- This is called when Typ, a predicated subtype, is used in a context - -- which does not allow the use of a predicated subtype. Msg will be - -- passed to Error_Msg_F to output an appropriate message. The caller - -- should set up any insertions other than the & for the type itself. - -- Note that if Typ is a generic actual type, then the message will be - -- output as a warning, and a raise Program_Error is inserted using - -- Insert_Action with node N as the insertion point. Node N also supplies - -- the source location for construction of the raise node. If Typ is NOT a - -- type with predicates this call has no effect. + -- which does not allow the use of a predicated subtype. Msg is passed + -- to Error_Msg_FE to output an appropriate message using N as the + -- location, and Typ as the entity. The caller must set up any insertions + -- other than the & for the type itself. Note that if Typ is a generic + -- actual type, then the message will be output as a warning, and a + -- raise Program_Error is inserted using Insert_Action with node N as + -- the insertion point. Node N also supplies the source location for + -- construction of the raise node. If Typ is NOT a type with predicates + -- this call has no effect. function Build_Actual_Subtype (T : Entity_Id; Index: sem_res.adb =================================================================== --- sem_res.adb (revision 165805) +++ sem_res.adb (working copy) @@ -8481,7 +8481,7 @@ package body Sem_Res is -- Check bad use of type with predicates if Has_Predicates (Etype (Drange)) then - Error_Msg_NE + Bad_Predicated_Subtype_Use ("subtype& has predicate, not allowed in slice", Drange, Etype (Drange)); Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 165828) +++ sem_attr.adb (working copy) @@ -842,7 +842,7 @@ package body Sem_Attr is if Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Bad_Predicated_Subtype_Use - (P_Type, N, "type& has predicates, attribute % not allowed"); + ("type& has predicates, attribute % not allowed", N, P_Type); end if; end Bad_Attribute_For_Predicate; Index: sem_case.adb =================================================================== --- sem_case.adb (revision 165828) +++ sem_case.adb (working copy) @@ -866,9 +866,8 @@ package body Sem_Case is or else No (Static_Predicate (E)) then Bad_Predicated_Subtype_Use - (E, N, - "cannot use subtype& with non-static " - & "predicate as case alternative"); + ("cannot use subtype& with non-static " + & "predicate as case alternative", N, E); -- Static predicate case Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 165828) +++ sem_ch13.adb (working copy) @@ -3888,9 +3888,13 @@ package body Sem_Ch13 is Right_Opnd => Exp); end if; - -- Output info message on inheritance if required + -- Output info message on inheritance if required. Note we do not + -- give this information for generic actual types, since it is + -- unwelcome noise in that case in instantiations. - if Opt.List_Inherited_Aspects then + if Opt.List_Inherited_Aspects + and then not Is_Generic_Actual_Type (Typ) + then Error_Msg_Sloc := Sloc (Predicate_Function (T)); Error_Msg_Node_2 := T; Error_Msg_N ("?info: & inherits predicate from & #", Typ); @@ -4087,9 +4091,10 @@ package body Sem_Ch13 is function Hi_Val (N : Node_Id) return Uint is begin - if Nkind (N) = N_Identifier then + if Is_Static_Expression (N) then return Expr_Value (N); else + pragma Assert (Nkind (N) = N_Range); return Expr_Value (High_Bound (N)); end if; end Hi_Val; @@ -4100,9 +4105,10 @@ package body Sem_Ch13 is function Lo_Val (N : Node_Id) return Uint is begin - if Nkind (N) = N_Identifier then + if Is_Static_Expression (N) then return Expr_Value (N); else + pragma Assert (Nkind (N) = N_Range); return Expr_Value (Low_Bound (N)); end if; end Lo_Val; @@ -4124,19 +4130,19 @@ package body Sem_Ch13 is SHi := Hi_Val (N); end if; - -- Identifier case + -- Static expression case - else pragma Assert (Nkind (N) = N_Identifier); + elsif Is_Static_Expression (N) then + SLo := Lo_Val (N); + SHi := Hi_Val (N); - -- Static expression case + -- Identifier (other than static expression) case - if Is_Static_Expression (N) then - SLo := Lo_Val (N); - SHi := Hi_Val (N); + else pragma Assert (Nkind (N) = N_Identifier); -- Type case - elsif Is_Type (Entity (N)) then + if Is_Type (Entity (N)) then -- If type has static predicates, process them recursively