This patch implements Ada 2012 AI (AI12-0022) which intorduces a new
expression type "raiae expression". This can appear within an expression
and results in raising the given exception. Most importantly, if this
form is used in an assertion such as a precondition, it can be used to
change the exception that is signalled.
The following test, compiled with -gnata, outputs
OK 1
OK 2
OK 3
1. pragma Ada_2012;
2. with Text_IO; use Text_IO;
3. procedure RaiseX is
4. X : Integer;
5.
6. begin
7. begin
8. X := 41;
9. if X >= 42 or else raise Tasking_Error then
10. raise Program_Error;
11. end if;
12. exception
13. when Tasking_Error =>
14. Put_Line ("OK 1");
15. end;
16.
17. declare
18. function F (M : Integer) return Integer;
19. pragma Precondition (M /= 0 or else raise Storage_Error);
20.
21. function F (M : Integer) return Integer is
22. begin
23. return 42 / M;
24. end F;
25.
26. begin
27. X := F (0);
28. exception
29. when Storage_Error =>
30. Put_Line ("OK 2");
31. end;
32.
33. declare
34. function F (B : Integer) return Integer is
35. (if B < 0 then B else raise Storage_Error);
36. begin
37. X := F (12);
38. exception
39. when Storage_Error =>
40. Put_Line ("OK 3");
41. end;
42. end RaiseX;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-11 Robert Dewar <de...@adacore.com>
* exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure.
* exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression.
* expander.adb: Add call to Expand_N_Raise_Expression.
* par-ch11.adb (P_Raise_Expression): New procedure.
* par-ch4.adb (P_Relation): Handle Raise_Expression.
* par.adb (P_Raise_Expression): New procedure.
* sem.adb: Add handling for N_Raise_Expression.
* sem_ch11.ads, sem_ch11.adb (Analyze_Raise_Expression): New procedure.
* sem_res.adb (Resolve): Add handling for N_Raise_Expression.
* sinfo.ads, sinfo.adb (N_Raise_Expression): New node.
* sprint.adb (Sprint_Node_Actual): Add handling for N_Raise_Expression.
* stand.ads (Any_Type): Document use with N_Raise_Expression.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 197743)
+++ exp_util.adb (working copy)
@@ -3674,6 +3674,7 @@
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Quantified_Expression |
+ N_Raise_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 197743)
+++ sinfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1233,6 +1233,7 @@
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Simple_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
@@ -2130,6 +2131,7 @@
or else NT (N).Nkind = N_Package_Renaming_Declaration
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Requeue_Statement
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
@@ -4305,6 +4307,7 @@
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
+ or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Simple_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
@@ -5202,6 +5205,7 @@
or else NT (N).Nkind = N_Package_Renaming_Declaration
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Raise_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Requeue_Statement
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 197743)
+++ sinfo.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3545,6 +3545,7 @@
-- RELATION ::=
-- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
+ -- | RAISE_EXPRESSION
-- MEMBERSHIP_CHOICE_LIST ::=
-- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
@@ -6119,7 +6120,8 @@
-- In Ada 2005, we have
- -- RAISE_STATEMENT ::= raise; | raise exception_NAME [with EXPRESSION];
+ -- RAISE_STATEMENT ::=
+ -- raise; | raise exception_NAME [with string_EXPRESSION];
-- N_Raise_Statement
-- Sloc points to RAISE
@@ -6127,6 +6129,18 @@
-- Expression (Node3) (set to Empty if no expression present)
-- From_At_End (Flag4-Sem)
+ ----------------------------
+ -- 11.3 Raise Expression --
+ ----------------------------
+
+ -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]
+
+ -- N_Raise_Expression
+ -- Sloc points to RAISE
+ -- Name (Node2) (always present)
+ -- Expression (Node3) (set to Empty if no expression present)
+ -- plus fields for expression
+
-------------------------------
-- 12.1 Generic Declaration --
-------------------------------
@@ -7664,6 +7678,7 @@
N_Allocator,
N_Case_Expression,
N_Extension_Aggregate,
+ N_Raise_Expression,
N_Range,
N_Real_Literal,
N_Reference,
@@ -11348,6 +11363,13 @@
4 => False, -- unused
5 => False), -- unused
+ N_Raise_Expression =>
+ (1 => False, -- unused
+ 2 => True, -- Name (Node2)
+ 3 => True, -- Expression (Node3)
+ 4 => False, -- unused
+ 5 => False), -- Etype (Node5-Sem)
+
N_Generic_Subprogram_Declaration =>
(1 => True, -- Specification (Node1)
2 => True, -- Generic_Formal_Declarations (List2)
Index: par-ch11.adb
===================================================================
--- par-ch11.adb (revision 197743)
+++ par-ch11.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -199,11 +199,43 @@
return Error;
end P_Exception_Choice;
+ ----------------------------
+ -- 11.3 Raise Expression --
+ ----------------------------
+
+ -- RAISE_EXPRESSION ::= raise [exception_NAME [with string_EXPRESSION]]
+
+ -- The caller has verified that the initial token is RAISE
+
+ -- Error recovery: can raise Error_Resync
+
+ function P_Raise_Expression return Node_Id is
+ Raise_Node : Node_Id;
+
+ begin
+ if Ada_Version < Ada_2012 then
+ Error_Msg_SC ("raise expression is an Ada 2012 feature");
+ Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
+ end if;
+
+ Raise_Node := New_Node (N_Raise_Expression, Token_Ptr);
+ Scan; -- past RAISE
+
+ Set_Name (Raise_Node, P_Name);
+
+ if Token = Tok_With then
+ Scan; -- past WITH
+ Set_Expression (Raise_Node, P_Expression);
+ end if;
+
+ return Raise_Node;
+ end P_Raise_Expression;
+
---------------------------
-- 11.3 Raise Statement --
---------------------------
- -- RAISE_STATEMENT ::= raise [exception_NAME];
+ -- RAISE_STATEMENT ::= raise [exception_NAME with string_EXPRESSION];
-- The caller has verified that the initial token is RAISE
Index: sem.adb
===================================================================
--- sem.adb (revision 197743)
+++ sem.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -470,6 +470,9 @@
when N_Quantified_Expression =>
Analyze_Quantified_Expression (N);
+ when N_Raise_Expression =>
+ Analyze_Raise_Expression (N);
+
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
Index: par-ch4.adb
===================================================================
--- par-ch4.adb (revision 197743)
+++ par-ch4.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1818,6 +1818,7 @@
-- RELATION ::=
-- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
+ -- | RAISE_EXPRESSION
-- MEMBERSHIP_CHOICE_LIST ::=
-- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
@@ -1825,6 +1826,8 @@
-- MEMBERSHIP_CHOICE ::=
-- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
+ -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]
+
-- On return, Expr_Form indicates the categorization of the expression
-- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
@@ -1839,6 +1842,15 @@
Optok : Source_Ptr;
begin
+ -- First check for raise expression
+
+ if Token = Tok_Raise then
+ Expr_Form := EF_Non_Simple;
+ return P_Raise_Expression;
+ end if;
+
+ -- All other cases
+
Node1 := P_Simple_Expression;
if Token not in Token_Class_Relop then
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 197743)
+++ sem_res.adb (working copy)
@@ -2060,9 +2060,11 @@
Analyze_Dimension (N);
return;
- -- Return if type = Any_Type (previous error encountered)
+ -- Return if type = Any_Type (previous error encountered). except that
+ -- a Raise_Expression node is OK: it is legitimately labeled this way
+ -- since it provides no information on the context.
- elsif Etype (N) = Any_Type then
+ elsif Etype (N) = Any_Type and then Nkind (N) /= N_Raise_Expression then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
return;
end if;
@@ -2804,8 +2806,13 @@
when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type);
+ -- Why is the following null, needs a comment ???
+
when N_Quantified_Expression => null;
+ when N_Raise_Expression
+ => Set_Etype (N, Ctx_Type);
+
when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type);
Index: expander.adb
===================================================================
--- expander.adb (revision 197743)
+++ expander.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -388,6 +388,9 @@
when N_Raise_Constraint_Error =>
Expand_N_Raise_Constraint_Error (N);
+ when N_Raise_Expression =>
+ Expand_N_Raise_Expression (N);
+
when N_Raise_Program_Error =>
Expand_N_Raise_Program_Error (N);
Index: par.adb
===================================================================
--- par.adb (revision 197743)
+++ par.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -838,6 +838,7 @@
package Ch11 is
function P_Handled_Sequence_Of_Statements return Node_Id;
+ function P_Raise_Expression return Node_Id;
function P_Raise_Statement return Node_Id;
function Parse_Exception_Handlers return List_Id;
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 197743)
+++ exp_ch11.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1431,6 +1431,44 @@
Possible_Local_Raise (N, Standard_Constraint_Error);
end Expand_N_Raise_Constraint_Error;
+ -------------------------------
+ -- Expand_N_Raise_Expression --
+ -------------------------------
+
+ procedure Expand_N_Raise_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ RCE : Node_Id;
+
+ begin
+ Possible_Local_Raise (N, Name (N));
+
+ -- Later we must teach the back end/gigi how to deal with this, but
+ -- for now we will assume the type is Standard_Boolean and transform
+ -- the node to:
+
+ -- do
+ -- raise X [with string]
+ -- in
+ -- raise Consraint_Error;
+
+ -- The raise constraint error can never be executed. It is just a dummy
+ -- node that can be labeled with an arbitrary type.
+
+ RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise);
+ Set_Etype (RCE, Typ);
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Raise_Statement (Loc,
+ Name => Name (N),
+ Expression => Expression (N))),
+ Expression => RCE));
+
+ Analyze_And_Resolve (N, Typ);
+ end Expand_N_Raise_Expression;
+
----------------------------------
-- Expand_N_Raise_Program_Error --
----------------------------------
Index: exp_ch11.ads
===================================================================
--- exp_ch11.ads (revision 197743)
+++ exp_ch11.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,7 @@
procedure Expand_N_Exception_Declaration (N : Node_Id);
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id);
procedure Expand_N_Raise_Constraint_Error (N : Node_Id);
+ procedure Expand_N_Raise_Expression (N : Node_Id);
procedure Expand_N_Raise_Program_Error (N : Node_Id);
procedure Expand_N_Raise_Statement (N : Node_Id);
procedure Expand_N_Raise_Storage_Error (N : Node_Id);
Index: stand.ads
===================================================================
--- stand.ads (revision 197743)
+++ stand.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -362,11 +362,26 @@
-- identifier references to prevent cascaded errors.
Any_Type : Entity_Id;
- -- Used to represent some unknown type. Plays an important role in
- -- avoiding cascaded errors, since any node that remains labeled with
- -- this type corresponds to an already issued error message. Any_Type
- -- is propagated to avoid cascaded errors from a single type error.
+ -- Used to represent some unknown type. Any_Type is the type of an
+ -- unresolved operator, and it is the type of a node where a type error
+ -- has been detected. Any_Type plays an important role in avoiding
+ -- cascaded errors, because it is compatible with all other types, and is
+ -- propagated to any expression that has a subexpression of Any_Type.
+ -- When resolving operators, Any_Type is the initial type of the node
+ -- before any of its candidate interpretations has been examined. If after
+ -- examining all of them the type is still Any_Type, the node has no
+ -- possible interpretation and an error can be emitted (and Any_Type will
+ -- be propagated upwards).
+ -- There is one situation in which Any_Type is used to legitimately
+ -- represent a case where the type is not known pre-resolution, and
+ -- that is for the N_Raise_Expression node. In this case, the Etype
+ -- being set to Any_Type is normal and does not represent an error.
+ -- In particular, it is compatible with the type of any constituend of
+ -- the enclosing expression, if any. The type is eventually replaced
+ -- with the type of the context, which plays no role in the resolution
+ -- of the Raise_Expression.
+
Any_Access : Entity_Id;
-- Used to resolve the overloaded literal NULL
Index: sem_ch11.adb
===================================================================
--- sem_ch11.adb (revision 197743)
+++ sem_ch11.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -424,6 +424,60 @@
end if;
end Analyze_Handled_Statements;
+ ------------------------------
+ -- Analyze_Raise_Expression --
+ ------------------------------
+
+ procedure Analyze_Raise_Expression (N : Node_Id) is
+ Exception_Id : constant Node_Id := Name (N);
+ Exception_Name : Entity_Id := Empty;
+
+ begin
+ Check_SPARK_Restriction ("raise expression is not allowed", N);
+
+ -- Check exception restrictions on the original source
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Exceptions, N);
+ end if;
+
+ Analyze (Exception_Id);
+
+ if Is_Entity_Name (Exception_Id) then
+ Exception_Name := Entity (Exception_Id);
+ end if;
+
+ if No (Exception_Name)
+ or else Ekind (Exception_Name) /= E_Exception
+ then
+ Error_Msg_N
+ ("exception name expected in raise statement", Exception_Id);
+ else
+ Set_Is_Raised (Exception_Name);
+ end if;
+
+ -- Deal with RAISE WITH case
+
+ if Present (Expression (N)) then
+ Check_Compiler_Unit (Expression (N));
+ Analyze_And_Resolve (Expression (N), Standard_String);
+ end if;
+
+ -- Check obsolescent use of Numeric_Error
+
+ if Exception_Name = Standard_Numeric_Error then
+ Check_Restriction (No_Obsolescent_Features, Exception_Id);
+ end if;
+
+ -- Kill last assignment indication
+
+ Kill_Current_Values (Last_Assignment_Only => True);
+
+ -- Set type as Any_Type since we have no information at all on the type
+
+ Set_Etype (N, Any_Type);
+ end Analyze_Raise_Expression;
+
-----------------------------
-- Analyze_Raise_Statement --
-----------------------------
Index: sem_ch11.ads
===================================================================
--- sem_ch11.ads (revision 197743)
+++ sem_ch11.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,6 +27,7 @@
package Sem_Ch11 is
procedure Analyze_Exception_Declaration (N : Node_Id);
procedure Analyze_Handled_Statements (N : Node_Id);
+ procedure Analyze_Raise_Expression (N : Node_Id);
procedure Analyze_Raise_Statement (N : Node_Id);
procedure Analyze_Raise_xxx_Error (N : Node_Id);
procedure Analyze_Subprogram_Info (N : Node_Id);
Index: sprint.adb
===================================================================
--- sprint.adb (revision 197743)
+++ sprint.adb (working copy)
@@ -1993,6 +1993,7 @@
if not Has_Parens then
Write_Char ('(');
end if;
+
Write_Str_With_Col_Check_Sloc ("if ");
Sprint_Node (Condition);
Write_Str_With_Col_Check (" then ");
@@ -2763,6 +2764,32 @@
Write_Str (" => ");
Sprint_Node (Condition (Node));
+ when N_Raise_Expression =>
+ declare
+ Has_Parens : constant Boolean := Paren_Count (Node) > 0;
+
+ begin
+ -- The syntax for raise_expression does not include parentheses
+ -- but sometimes parentheses are required, so unconditionally
+ -- generate them here unless already present.
+
+ if not Has_Parens then
+ Write_Char ('(');
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str_With_Col_Check (" with ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ if not Has_Parens then
+ Write_Char (')');
+ end if;
+ end;
+
when N_Raise_Constraint_Error =>
-- This node can be used either as a subexpression or as a
