diff options
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/a-except.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 621 | ||||
| -rw-r--r-- | gcc/ada/sem_res.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 47 | ||||
| -rw-r--r-- | gcc/ada/types.h | 40 |
7 files changed, 563 insertions, 264 deletions
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 7325723..0c9bc68 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -41,6 +41,9 @@ -- The base version of this unit Ada.Exceptions omits the Wide version of -- Exception_Name and is used to build the compiler and other basic tools. +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. @@ -555,23 +558,24 @@ package body Ada.Exceptions is Rmsg_14 : constant String := "access before elaboration" & NUL; Rmsg_15 : constant String := "accessibility check failed" & NUL; Rmsg_16 : constant String := "all guards closed" & NUL; - Rmsg_17 : constant String := "duplicated entry address" & NUL; - Rmsg_18 : constant String := "explicit raise" & NUL; - Rmsg_19 : constant String := "finalize/adjust raised exception" & NUL; - Rmsg_20 : constant String := "implicit return with No_Return" & NUL; - Rmsg_21 : constant String := "misaligned address value" & NUL; - Rmsg_22 : constant String := "missing return" & NUL; - Rmsg_23 : constant String := "overlaid controlled object" & NUL; - Rmsg_24 : constant String := "potentially blocking operation" & NUL; - Rmsg_25 : constant String := "stubbed subprogram called" & NUL; - Rmsg_26 : constant String := "unchecked union restriction" & NUL; - Rmsg_27 : constant String := "illegal use of remote access-to-" & + Rmsg_17 : constant String := "Current_Task referenced in entry" & + " body" & NUL; + Rmsg_18 : constant String := "duplicated entry address" & NUL; + Rmsg_19 : constant String := "explicit raise" & NUL; + Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_21 : constant String := "implicit return with No_Return" & NUL; + Rmsg_22 : constant String := "misaligned address value" & NUL; + Rmsg_23 : constant String := "missing return" & NUL; + Rmsg_24 : constant String := "overlaid controlled object" & NUL; + Rmsg_25 : constant String := "potentially blocking operation" & NUL; + Rmsg_26 : constant String := "stubbed subprogram called" & NUL; + Rmsg_27 : constant String := "unchecked union restriction" & NUL; + Rmsg_28 : constant String := "illegal use of remote access-to-" & "class-wide type, see RM E.4(18)" & NUL; - Rmsg_28 : constant String := "empty storage pool" & NUL; - Rmsg_29 : constant String := "explicit raise" & NUL; - Rmsg_30 : constant String := "infinite recursion" & NUL; - Rmsg_31 : constant String := "object too large" & NUL; - Rmsg_32 : constant String := "restriction violation" & NUL; + Rmsg_29 : constant String := "empty storage pool" & NUL; + Rmsg_30 : constant String := "explicit raise" & NUL; + Rmsg_31 : constant String := "infinite recursion" & NUL; + Rmsg_32 : constant String := "object too large" & NUL; ----------------------- -- Polling Interface -- @@ -1106,7 +1110,7 @@ package body Ada.Exceptions is procedure Rcheck_28 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address); + Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); end Rcheck_28; procedure Rcheck_29 (File : System.Address; Line : Integer) is diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 2539501..44c7640 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -31,8 +31,10 @@ -- -- ------------------------------------------------------------------------------ --- This version of Ada.Exceptions is a full Ada 95 version, but lacks the --- additional definitions of Exception_Name returning Wide_[Wide_]String. +-- This version of Ada.Exceptions is a full Ada 95 version, and Ada 2005 +-- features such as the additional definitions of Exception_Name returning +-- Wide_[Wide_]String. + -- It is used for building the compiler and the basic tools, since these -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files @@ -40,6 +42,9 @@ -- 2005 functionality is required. in particular, it is used for building -- run times on all targets. +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. @@ -206,7 +211,7 @@ package body Ada.Exceptions is (Excep : EOA; Current : EOA; Reraised : Boolean := False); - -- Dummy routine used to share a-exexda.adb, do nothing. + -- Dummy routine used to share a-exexda.adb, do nothing end Exception_Propagation; @@ -504,23 +509,24 @@ package body Ada.Exceptions is Rmsg_14 : constant String := "access before elaboration" & NUL; Rmsg_15 : constant String := "accessibility check failed" & NUL; Rmsg_16 : constant String := "all guards closed" & NUL; - Rmsg_17 : constant String := "duplicated entry address" & NUL; - Rmsg_18 : constant String := "explicit raise" & NUL; - Rmsg_19 : constant String := "finalize/adjust raised exception" & NUL; - Rmsg_20 : constant String := "implicit return with No_Return" & NUL; - Rmsg_21 : constant String := "misaligned address value" & NUL; - Rmsg_22 : constant String := "missing return" & NUL; - Rmsg_23 : constant String := "overlaid controlled object" & NUL; - Rmsg_24 : constant String := "potentially blocking operation" & NUL; - Rmsg_25 : constant String := "stubbed subprogram called" & NUL; - Rmsg_26 : constant String := "unchecked union restriction" & NUL; - Rmsg_27 : constant String := "illegal use of remote access-to-" & + Rmsg_17 : constant String := "Current_Task referenced in entry" & + " body" & NUL; + Rmsg_18 : constant String := "duplicated entry address" & NUL; + Rmsg_19 : constant String := "explicit raise" & NUL; + Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_21 : constant String := "implicit return with No_Return" & NUL; + Rmsg_22 : constant String := "misaligned address value" & NUL; + Rmsg_23 : constant String := "missing return" & NUL; + Rmsg_24 : constant String := "overlaid controlled object" & NUL; + Rmsg_25 : constant String := "potentially blocking operation" & NUL; + Rmsg_26 : constant String := "stubbed subprogram called" & NUL; + Rmsg_27 : constant String := "unchecked union restriction" & NUL; + Rmsg_28 : constant String := "illegal use of remote access-to-" & "class-wide type, see RM E.4(18)" & NUL; - Rmsg_28 : constant String := "empty storage pool" & NUL; - Rmsg_29 : constant String := "explicit raise" & NUL; - Rmsg_30 : constant String := "infinite recursion" & NUL; - Rmsg_31 : constant String := "object too large" & NUL; - Rmsg_32 : constant String := "restriction violation" & NUL; + Rmsg_29 : constant String := "empty storage pool" & NUL; + Rmsg_30 : constant String := "explicit raise" & NUL; + Rmsg_31 : constant String := "infinite recursion" & NUL; + Rmsg_32 : constant String := "object too large" & NUL; ----------------------- -- Polling Interface -- @@ -802,11 +808,7 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end if; - -- Note: if E is null, then we simply return, which is correct Ada 95 - -- semantics. If we are operating in Ada 2005 mode, then the expander - -- generates a raise Constraint_Error immediately following the call - -- to provide the required Ada 2005 semantics (see AI-329). We do it - -- this way to avoid having run time dependencies on the Ada version. + -- Note: if E is null then just return (Ada 95 semantics) return; end Raise_Exception; @@ -1072,7 +1074,7 @@ package body Ada.Exceptions is procedure Rcheck_28 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address); + Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); end Rcheck_28; procedure Rcheck_29 (File : System.Address; Line : Integer) is diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index e010c56..2dae518 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,8 +35,7 @@ -- -- ------------------------------------------------------------------------------ --- This version of Ada.Exceptions is a full Ada 95 version, but lacks the --- additional definitions of Exception_Name returning Wide_[Wide_]String. +-- This version of Ada.Exceptions is a full Ada 95 version. -- It is used for building the compiler and the basic tools, since these -- builds may be done with bootstrap compilers that cannot handle these -- additions. The full version of Ada.Exceptions can be found in the files @@ -57,14 +56,17 @@ package Ada.Exceptions is pragma Warnings (Off); pragma Preelaborate_05; pragma Warnings (On); - -- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we - -- can compile this using older compiler versions, which will ignore the - -- pragma, which is fine for the bootstrap. + -- We make this preelaborable in Ada 2005 mode. If we did not do this, then + -- run time units used by the compiler (e.g. s-soflin.ads) would run + -- into trouble. Conformance is not an issue, since this version is used + -- only by the compiler. type Exception_Id is private; + Null_Id : constant Exception_Id; type Exception_Occurrence is limited private; + type Exception_Occurrence_Access is access all Exception_Occurrence; Null_Occurrence : constant Exception_Occurrence; @@ -76,11 +78,11 @@ package Ada.Exceptions is procedure Raise_Exception (E : Exception_Id; Message : String := ""); -- Note: it would be really nice to give a pragma No_Return for this - -- procedure, but it would be wrong, since Raise_Exception does return - -- if given the null exception. However we do special case the name in - -- the test in the compiler for issuing a warning for a missing return - -- after this call. Program_Error seems reasonable enough in such a case. - -- See also the routine Raise_Exception_Always in the private part. + -- procedure, but it would be wrong, since Raise_Exception does return if + -- given the null exception in Ada 95 mode. However we do special case the + -- name in the test in the compiler for issuing a warning for a missing + -- return after this call. Program_Error seems reasonable enough in such a + -- case. See also the routine Raise_Exception_Always in the private part. function Exception_Message (X : Exception_Occurrence) return String; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 1a9ab72..ee263fe 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -241,11 +241,11 @@ package body Sem_Res is if Nkind (C) = N_Character_Literal then Error_Msg_N ("ambiguous character literal", C); Error_Msg_N - ("\possible interpretations: Character, Wide_Character!", C); + ("\\possible interpretations: Character, Wide_Character!", C); E := Current_Entity (C); while Present (E) loop - Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); + Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); E := Homonym (E); end loop; end if; @@ -1823,12 +1823,20 @@ package body Sem_Res is -- message only at the start of an ambiguous set. if not Ambiguous then - Error_Msg_NE - ("ambiguous expression (cannot resolve&)!", - N, It.Nam); + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + then + Error_Msg_N + ("ambiguous expression " + & "(cannot resolve indirect call)!", N); + else + Error_Msg_NE + ("ambiguous expression (cannot resolve&)!", + N, It.Nam); + end if; Error_Msg_N - ("possible interpretation#!", N); + ("\\possible interpretation#!", N); Ambiguous := True; end if; @@ -1857,7 +1865,7 @@ package body Sem_Res is elsif Nkind (N) in N_Binary_Op and then Scope (It.Nam) = Standard_Standard and then not Is_Overloaded (Left_Opnd (N)) - and then Scope (Base_Type (Etype (Left_Opnd (N)))) + and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= Standard_Standard then Err_Type := First_Subtype (Etype (Left_Opnd (N))); @@ -1867,6 +1875,20 @@ package body Sem_Res is then Error_Msg_Sloc := Sloc (Parent (Err_Type)); end if; + + -- If this is an indirect call, use the subprogram_type + -- in the message, to have a meaningful location. + -- Indicate as well if this is an inherited operation, + -- created by a type declaration. + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Type (It.Nam) + then + Err_Type := It.Nam; + Error_Msg_Sloc := + Sloc (Associated_Node_For_Itype (Err_Type)); + else Err_Type := Empty; end if; @@ -1876,9 +1898,15 @@ package body Sem_Res is and then Present (Err_Type) then Error_Msg_N - ("possible interpretation (predefined)#!", N); + ("\\possible interpretation (predefined)#!", N); + + elsif + Nkind (Parent (It.Nam)) = N_Full_Type_Declaration + then + Error_Msg_N + ("\\possible interpretation (inherited)#!", N); else - Error_Msg_N ("possible interpretation#!", N); + Error_Msg_N ("\\possible interpretation#!", N); end if; end if; @@ -2012,16 +2040,14 @@ package body Sem_Res is Set_Etype (N, Typ); return; - -- Check for an aggregate. Sometimes we can get bogus - -- aggregates from misuse of parentheses, and we are - -- about to complain about the aggregate without even - -- looking inside it. + -- Check for an aggregate. Sometimes we can get bogus aggregates + -- from misuse of parentheses, and we are about to complain about + -- the aggregate without even looking inside it. - -- Instead, if we have an aggregate of type Any_Composite, - -- then analyze and resolve the component fields, and then - -- only issue another message if we get no errors doing - -- this (otherwise assume that the errors in the aggregate - -- caused the problem). + -- Instead, if we have an aggregate of type Any_Composite, then + -- analyze and resolve the component fields, and then only issue + -- another message if we get no errors doing this (otherwise + -- assume that the errors in the aggregate caused the problem). elsif Nkind (N) = N_Aggregate and then Etype (N) = Any_Composite @@ -2034,12 +2060,16 @@ package body Sem_Res is declare procedure Check_Aggr (Aggr : Node_Id); - -- Check one aggregate, and set Found to True if we - -- have a definite error in any of its elements + -- Check one aggregate, and set Found to True if we have a + -- definite error in any of its elements procedure Check_Elmt (Aelmt : Node_Id); - -- Check one element of aggregate and set Found to - -- True if we definitely have an error in the element. + -- Check one element of aggregate and set Found to True if + -- we definitely have an error in the element. + + ---------------- + -- Check_Aggr -- + ---------------- procedure Check_Aggr (Aggr : Node_Id) is Elmt : Node_Id; @@ -2056,7 +2086,16 @@ package body Sem_Res is if Present (Component_Associations (Aggr)) then Elmt := First (Component_Associations (Aggr)); while Present (Elmt) loop - Check_Elmt (Expression (Elmt)); + + -- Nothing to check is this is a default- + -- initialized component. The box will be + -- be replaced by the appropriate call during + -- late expansion. + + if not Box_Present (Elmt) then + Check_Elmt (Expression (Elmt)); + end if; + Next (Elmt); end loop; end if; @@ -2131,7 +2170,7 @@ package body Sem_Res is It : Interp; begin - Error_Msg_N ("\possible interpretations:", N); + Error_Msg_N ("\\possible interpretations:", N); Get_First_Interp (Name (N), Index, It); while Present (It.Nam) loop @@ -2254,7 +2293,7 @@ package body Sem_Res is when N_Identifier => Resolve_Entity_Name (N, Ctx_Type); - when N_In | N_Not_In + when N_Membership_Test => Resolve_Membership_Op (N, Ctx_Type); when N_Indexed_Component @@ -3167,7 +3206,12 @@ package body Sem_Res is Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Typ); - else + + -- Do not apply Ada 2005 accessibility checks on a class-wide + -- allocator if the type given in the allocator is a formal + -- type. A run-time check will be performed in the instance. + + elsif not Is_Generic_Type (Exp_Typ) then Error_Msg_N ("type in allocator has deeper level than" & " designated class-wide type", E); end if; @@ -3219,6 +3263,9 @@ package body Sem_Res is -- We do the resolution using the base type, because intermediate values -- in expressions always are of the base type, not a subtype of it. + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; + -- Returns True if N is in a context that expects "any real type" + function Is_Integer_Or_Universal (N : Node_Id) return Boolean; -- Return True iff given type is Integer or universal real/integer @@ -3230,6 +3277,29 @@ package body Sem_Res is procedure Set_Operand_Type (N : Node_Id); -- Set operand type to T if universal + ------------------------------- + -- Expected_Type_Is_Any_Real -- + ------------------------------- + + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is + begin + -- N is the expression after "delta" in a fixed_point_definition; + -- see RM-3.5.9(6): + + return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition + or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition + + -- N is one of the bounds in a real_range_specification; + -- see RM-3.5.7(5): + + or else Nkind (Parent (N)) = N_Real_Range_Specification + + -- N is the expression of a delta_constraint; + -- see RM-J.3(3): + + or else Nkind (Parent (N)) = N_Delta_Constraint; + end Expected_Type_Is_Any_Real; + ----------------------------- -- Is_Integer_Or_Universal -- ----------------------------- @@ -3467,10 +3537,17 @@ package body Sem_Res is Set_Mixed_Mode_Operand (R, TL); end if; + -- Check the rule in RM05-4.5.5(19.1/2) disallowing the + -- universal_fixed multiplying operators from being used when the + -- expected type is also universal_fixed. Note that B_Typ will be + -- Universal_Fixed in some cases where the expected type is actually + -- Any_Real; Expected_Type_Is_Any_Real takes care of that case. + if Etype (N) = Universal_Fixed or else Etype (N) = Any_Fixed then if B_Typ = Universal_Fixed + and then not Expected_Type_Is_Any_Real (N) and then Nkind (Parent (N)) /= N_Type_Conversion and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion then @@ -3494,7 +3571,16 @@ package body Sem_Res is N); end if; - Set_Etype (N, B_Typ); + -- The expected type is "any real type" in contexts like + -- type T is delta <universal_fixed-expression> ... + -- in which case we need to set the type to Universal_Real + -- so that static expression evaluation will work properly. + + if Expected_Type_Is_Any_Real (N) then + Set_Etype (N, Universal_Real); + else + Set_Etype (N, B_Typ); + end if; end if; elsif Is_Fixed_Point_Type (B_Typ) @@ -3582,9 +3668,30 @@ package body Sem_Res is (Is_Real_Type (Etype (Rop)) and then Expr_Value_R (Rop) = Ureal_0)) then - Apply_Compile_Time_Constraint_Error - (N, "division by zero?", CE_Divide_By_Zero, - Loc => Sloc (Right_Opnd (N))); + -- Specialize the warning message according to the operation + + case Nkind (N) is + when N_Op_Divide => + Apply_Compile_Time_Constraint_Error + (N, "division by zero?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Rem => + Apply_Compile_Time_Constraint_Error + (N, "rem with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Mod => + Apply_Compile_Time_Constraint_Error + (N, "mod with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + -- Division by zero can only happen with division, rem, + -- and mod operations. + + when others => + raise Program_Error; + end case; -- Otherwise just set the flag to check at run time @@ -3610,6 +3717,7 @@ package body Sem_Res is It : Interp; Norm_OK : Boolean; Scop : Entity_Id; + Rtype : Entity_Id; begin -- The context imposes a unique interpretation with type Typ on a @@ -3656,7 +3764,7 @@ package body Sem_Res is -- For an indirect call, we always invalidate checks, since we do not -- know whether the subprogram is local or global. Yes we could do -- better here, e.g. by knowing that there are no local subprograms, - -- but it does not seem worth the effort. Similarly, we kill al + -- but it does not seem worth the effort. Similarly, we kill all -- knowledge of current constant values. Kill_Current_Values; @@ -3718,10 +3826,20 @@ package body Sem_Res is P := Parent (P); exit when No (P); - if Nkind (P) = N_Entry_Body then + if Nkind (P) = N_Entry_Body + or else (Nkind (P) = N_Subprogram_Body + and then Is_Entry_Barrier_Function (P)) + then + Rtype := Etype (N); Error_Msg_NE - ("& should not be used in entry body ('R'M C.7(17))", + ("& should not be used in entry body ('R'M C.7(17))?", N, Nam); + Error_Msg_NE + ("\Program_Error will be raised at run time?", N, Nam); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Current_Task_In_Entry_Body)); + Set_Etype (N, Rtype); exit; end if; end loop; @@ -3734,25 +3852,6 @@ package body Sem_Res is Error_Msg_N ("cannot call thread body directly", N); end if; - -- If the subprogram is not global, then kill all checks. This is a bit - -- conservative, since in many cases we could do better, but it is not - -- worth the effort. Similarly, we kill constant values. However we do - -- not need to do this for internal entities (unless they are inherited - -- user-defined subprograms), since they are not in the business of - -- molesting global values. - - if not Is_Library_Level_Entity (Nam) - and then (Comes_From_Source (Nam) - or else (Present (Alias (Nam)) - and then Comes_From_Source (Alias (Nam)))) - then - Kill_Current_Values; - end if; - - -- Check for call to subprogram marked Is_Obsolescent - - Check_Obsolescent (Nam, N); - -- Check that a procedure call does not occur in the context of the -- entry call statement of a conditional or timed entry call. Note that -- the case of a call to a subprogram renaming of an entry will also be @@ -3914,15 +4013,16 @@ package body Sem_Res is -- the case of a possible run-time detectable infinite recursion. else - while Scop /= Standard_Standard loop + Scope_Loop : while Scop /= Standard_Standard loop if Nam = Scop then + -- Although in general recursion is not statically checkable, -- the case of calling an immediately containing subprogram -- is easy to catch. Check_Restriction (No_Recursion, N); - -- If the recursive call is to a parameterless procedure, then + -- If the recursive call is to a parameterless subprogram, then -- even if we can't statically detect infinite recursion, this -- is pretty suspicious, and we output a warning. Furthermore, -- we will try later to detect some cases here at run time by @@ -3938,16 +4038,58 @@ package body Sem_Res is and then not Error_Posted (N) and then Nkind (Parent (N)) /= N_Exception_Handler then + -- For the case of a procedure call. We give the message + -- only if the call is the first statement in a sequence of + -- statements, or if all previous statements are simple + -- assignments. This is simply a heuristic to decrease false + -- positives, without losing too many good warnings. The + -- idea is that these previous statements may affect global + -- variables the procedure depends on. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_List_Member (N) + then + declare + P : Node_Id; + begin + P := Prev (N); + while Present (P) loop + if Nkind (P) /= N_Assignment_Statement then + exit Scope_Loop; + end if; + + Prev (P); + end loop; + end; + end if; + + -- Do not give warning if we are in a conditional context + + declare + K : constant Node_Kind := Nkind (Parent (N)); + begin + if (K = N_Loop_Statement + and then Present (Iteration_Scheme (Parent (N)))) + or else K = N_If_Statement + or else K = N_Elsif_Part + or else K = N_Case_Statement_Alternative + then + exit Scope_Loop; + end if; + end; + + -- Here warning is to be issued + Set_Has_Recursive_Call (Nam); Error_Msg_N ("possible infinite recursion?", N); Error_Msg_N ("\Storage_Error may be raised at run time?", N); end if; - exit; + exit Scope_Loop; end if; Scop := Scope (Scop); - end loop; + end loop Scope_Loop; end if; -- If subprogram name is a predefined operator, it was given in @@ -4044,6 +4186,25 @@ package body Sem_Res is return; end if; + -- If the subprogram is not global, then kill all checks. This is a bit + -- conservative, since in many cases we could do better, but it is not + -- worth the effort. Similarly, we kill constant values. However we do + -- not need to do this for internal entities (unless they are inherited + -- user-defined subprograms), since they are not in the business of + -- molesting global values. + + -- Note: we do not do this step till after resolving the actuals. That + -- way we still take advantage of the current value information while + -- scanning the actuals. + + if not Is_Library_Level_Entity (Nam) + and then (Comes_From_Source (Nam) + or else (Present (Alias (Nam)) + and then Comes_From_Source (Alias (Nam)))) + then + Kill_Current_Values; + end if; + -- If the subprogram is a primitive operation, check whether or not -- it is a correct dispatching call. @@ -5180,6 +5341,7 @@ package body Sem_Res is end loop; end if; + Warn_On_Suspicious_Index (Name, First (Expressions (N))); Eval_Indexed_Component (N); end Resolve_Indexed_Component; @@ -5557,14 +5719,14 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (Func); Error_Msg_N ("\ambiguous call to function#", Arg); Error_Msg_NE - ("\interpretation as call yields&", Arg, Typ); + ("\\interpretation as call yields&", Arg, Typ); Error_Msg_NE - ("\interpretation as indexing of call yields&", + ("\\interpretation as indexing of call yields&", Arg, Component_Type (Typ)); else - Error_Msg_N ("ambiguous operand for concatenation!", - Arg); + Error_Msg_N + ("ambiguous operand for concatenation!", Arg); Get_First_Interp (Arg, I, It); while Present (It.Nam) loop Error_Msg_Sloc := Sloc (It.Nam); @@ -5573,7 +5735,7 @@ package body Sem_Res is or else Base_Type (It.Typ) = Base_Type (Component_Type (Typ)) then - Error_Msg_N ("\possible interpretation#", Arg); + Error_Msg_N ("\\possible interpretation#", Arg); end if; Get_Next_Interp (I, It); @@ -5723,6 +5885,10 @@ package body Sem_Res is -- and the not in question is the left operand of this operation. -- Note that if the not is in parens, then false is returned. + ----------------------- + -- Parent_Is_Boolean -- + ----------------------- + function Parent_Is_Boolean return Boolean is begin if Paren_Count (N) /= 0 then @@ -5742,7 +5908,7 @@ package body Sem_Res is N_In | N_Not_In | N_And_Then | - N_Or_Else => + N_Or_Else => return Left_Opnd (Parent (N)) = N; @@ -5765,11 +5931,15 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + -- Straigtforward case of incorrect arguments + if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; + -- Special case of probable missing parens + elsif Typ = Universal_Integer or else Typ = Any_Modular then if Parent_Is_Boolean then Error_Msg_N @@ -5783,8 +5953,15 @@ package body Sem_Res is Set_Etype (N, Any_Type); return; + -- OK resolution of not + else - if not Is_Boolean_Type (Typ) + -- Warn if non-boolean types involved. This is a case like not a < b + -- where a and b are modular, where we will get (not a) < b and most + -- likely not (a < b) was intended. + + if Warn_On_Questionable_Missing_Parens + and then not Is_Boolean_Type (Typ) and then Parent_Is_Boolean then Error_Msg_N ("?not expression should be parenthesized here", N); @@ -6111,7 +6288,7 @@ package body Sem_Res is Resolve (P, It1.Typ); Set_Etype (N, Typ); - Set_Entity (S, Comp1); + Set_Entity_With_Style_Check (S, Comp1); else -- Resolve prefix with its type @@ -6119,6 +6296,16 @@ package body Sem_Res is Resolve (P, T); end if; + -- Generate cross-reference. We needed to wait until full overloading + -- resolution was complete to do this, since otherwise we can't tell if + -- we are an Lvalue of not. + + if May_Be_Lvalue (N) then + Generate_Reference (Entity (S), S, 'm'); + else + Generate_Reference (Entity (S), S, 'r'); + end if; + -- If prefix is an access type, the node will be transformed into an -- explicit dereference during expansion. The type of the node is the -- designated type of that of the prefix. @@ -6317,6 +6504,12 @@ package body Sem_Res is end if; Set_Slice_Subtype (N); + + if Nkind (Drange) = N_Range then + Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); + Warn_On_Suspicious_Index (Name, High_Bound (Drange)); + end if; + Eval_Slice (N); end Resolve_Slice; @@ -6654,9 +6847,12 @@ package body Sem_Res is and then Realval (Rop) /= Ureal_0 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) then - Error_Msg_N ("universal real operand can only be interpreted?", - Rop); - Error_Msg_N ("\as Duration, and will lose precision?", Rop); + Error_Msg_N + ("universal real operand can only " & + "be interpreted as Duration?", + Rop); + Error_Msg_N + ("\precision will be lost in the conversion", Rop); end if; elsif Is_Numeric_Type (Typ) @@ -6734,7 +6930,7 @@ package body Sem_Res is -- Ada 2005 (AI-251): Handle conversions to abstract interface types - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 and then Expander_Active then if Is_Access_Type (Target_Type) then Target_Type := Directly_Designated_Type (Target_Type); end if; @@ -6770,9 +6966,18 @@ package body Sem_Res is -- conversion at run-time. Expand_Interface_Conversion (N, Is_Static => False); + else Expand_Interface_Conversion (N); end if; + + -- Ada 2005 (AI-251): Conversion from a class-wide interface to a + -- tagged type + + elsif Is_Class_Wide_Type (Opnd_Type) + and then Is_Interface (Opnd_Type) + then + Expand_Interface_Conversion (N, Is_Static => False); end if; end if; end Resolve_Type_Conversion; @@ -6791,10 +6996,11 @@ package body Sem_Res is begin -- Generate warning for expressions like -5 mod 3 - if Paren_Count (N) = 0 - and then Nkind (N) = N_Op_Minus + if Warn_On_Questionable_Missing_Parens + and then Paren_Count (N) = 0 + and then (Nkind (N) = N_Op_Minus or else Nkind (N) = N_Op_Plus) and then Paren_Count (Right_Opnd (N)) = 0 - and then Nkind (Right_Opnd (N)) = N_Op_Mod + and then Nkind (Right_Opnd (N)) in N_Multiplying_Operator and then Comes_From_Source (N) then Error_Msg_N @@ -7161,8 +7367,8 @@ package body Sem_Res is procedure Fixed_Point_Error is begin Error_Msg_N ("ambiguous universal_fixed_expression", N); - Error_Msg_NE ("\possible interpretation as}", N, T1); - Error_Msg_NE ("\possible interpretation as}", N, T2); + Error_Msg_NE ("\\possible interpretation as}", N, T1); + Error_Msg_NE ("\\possible interpretation as}", N, T2); end Fixed_Point_Error; -- Start of processing for Unique_Fixed_Point_Type @@ -7257,6 +7463,10 @@ package body Sem_Res is Opnd_Type : Entity_Id) return Boolean; -- Specifically test for validity of tagged conversions + function Valid_Array_Conversion return Boolean; + -- Check index and component conformance, and accessibility levels + -- if the component types are anonymous access types (Ada 2005) + ---------------------- -- Conversion_Check -- ---------------------- @@ -7273,6 +7483,135 @@ package body Sem_Res is return Valid; end Conversion_Check; + ---------------------------- + -- Valid_Array_Conversion -- + ---------------------------- + + function Valid_Array_Conversion return Boolean + is + Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); + Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); + + Opnd_Index : Node_Id; + Opnd_Index_Type : Entity_Id; + + Target_Comp_Type : constant Entity_Id := + Component_Type (Target_Type); + Target_Comp_Base : constant Entity_Id := + Base_Type (Target_Comp_Type); + + Target_Index : Node_Id; + Target_Index_Type : Entity_Id; + + begin + -- Error if wrong number of dimensions + + if + Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) + then + Error_Msg_N + ("incompatible number of dimensions for conversion", Operand); + return False; + + -- Number of dimensions matches + + else + -- Loop through indexes of the two arrays + + Target_Index := First_Index (Target_Type); + Opnd_Index := First_Index (Opnd_Type); + while Present (Target_Index) and then Present (Opnd_Index) loop + Target_Index_Type := Etype (Target_Index); + Opnd_Index_Type := Etype (Opnd_Index); + + -- Error if index types are incompatible + + if not (Is_Integer_Type (Target_Index_Type) + and then Is_Integer_Type (Opnd_Index_Type)) + and then (Root_Type (Target_Index_Type) + /= Root_Type (Opnd_Index_Type)) + then + Error_Msg_N + ("incompatible index types for array conversion", + Operand); + return False; + end if; + + Next_Index (Target_Index); + Next_Index (Opnd_Index); + end loop; + + -- If component types have same base type, all set + + if Target_Comp_Base = Opnd_Comp_Base then + null; + + -- Here if base types of components are not the same. The only + -- time this is allowed is if we have anonymous access types. + + -- The conversion of arrays of anonymous access types can lead + -- to dangling pointers. AI-392 formalizes the accessibility + -- checks that must be applied to such conversions to prevent + -- out-of-scope references. + + elsif + (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type + or else + Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) + and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) + and then + Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) + then + if Type_Access_Level (Target_Type) < + Type_Access_Level (Opnd_Type) + then + if In_Instance_Body then + Error_Msg_N ("?source array type " & + "has deeper accessibility level than target", Operand); + Error_Msg_N ("\?Program_Error will be raised at run time", + Operand); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + return False; + + -- Conversion not allowed because of accessibility levels + + else + Error_Msg_N ("source array type " & + "has deeper accessibility level than target", Operand); + return False; + end if; + else + null; + end if; + + -- All other cases where component base types do not match + + else + Error_Msg_N + ("incompatible component types for array conversion", + Operand); + return False; + end if; + + -- Check that component subtypes statically match + + if Is_Constrained (Target_Comp_Type) /= + Is_Constrained (Opnd_Comp_Type) + or else not Subtypes_Statically_Match + (Target_Comp_Type, Opnd_Comp_Type) + then + Error_Msg_N + ("component subtypes must statically match", Operand); + return False; + end if; + end if; + + return True; + end Valid_Array_Conversion; + ----------------------------- -- Valid_Tagged_Conversion -- ----------------------------- @@ -7310,6 +7649,11 @@ package body Sem_Res is elsif Is_Interface (Target_Type) then return True; + elsif Is_Access_Type (Opnd_Type) + and then Is_Interface (Directly_Designated_Type (Opnd_Type)) + then + return True; + else Error_Msg_NE ("invalid tagged conversion, not compatible with}", @@ -7392,10 +7736,10 @@ package body Sem_Res is Error_Msg_N ("ambiguous operand in conversion", Operand); Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("possible interpretation#!", Operand); + Error_Msg_N ("\\possible interpretation#!", Operand); Error_Msg_Sloc := Sloc (N1); - Error_Msg_N ("possible interpretation#!", Operand); + Error_Msg_N ("\\possible interpretation#!", Operand); return False; end if; @@ -7406,27 +7750,40 @@ package body Sem_Res is end; end if; - if Chars (Current_Scope) = Name_Unchecked_Conversion then + -- Numeric types - -- This check is dubious, what if there were a user defined - -- scope whose name was Unchecked_Conversion ??? + if Is_Numeric_Type (Target_Type) then - return True; + -- A universal fixed expression can be converted to any numeric type - elsif Is_Numeric_Type (Target_Type) then if Opnd_Type = Universal_Fixed then return True; - elsif (In_Instance or else In_Inlined_Body) - and then not Comes_From_Source (N) - then - return True; + -- Also no need to check when in an instance or inlined body, because + -- the legality has been established when the template was analyzed. + -- Furthermore, numeric conversions may occur where only a private + -- view of the operand type is visible at the instanciation point. + -- This results in a spurious error if we check that the operand type + -- is a numeric type. + + -- Note: in a previous version of this unit, the following tests were + -- applied only for generated code (Comes_From_Source set to False), + -- but in fact the test is required for source code as well, since + -- this situation can arise in source code. + + elsif In_Instance or else In_Inlined_Body then + return True; + + -- Otherwise we need the conversion check else - return Conversion_Check (Is_Numeric_Type (Opnd_Type), - "illegal operand for numeric conversion"); + return Conversion_Check + (Is_Numeric_Type (Opnd_Type), + "illegal operand for numeric conversion"); end if; + -- Array types + elsif Is_Array_Type (Target_Type) then if not Is_Array_Type (Opnd_Type) or else Opnd_Type = Any_Composite @@ -7435,91 +7792,15 @@ package body Sem_Res is Error_Msg_N ("illegal operand for array conversion", Operand); return False; - - elsif Number_Dimensions (Target_Type) /= - Number_Dimensions (Opnd_Type) - then - Error_Msg_N - ("incompatible number of dimensions for conversion", Operand); - return False; - else - declare - Target_Index : Node_Id := First_Index (Target_Type); - Opnd_Index : Node_Id := First_Index (Opnd_Type); - - Target_Index_Type : Entity_Id; - Opnd_Index_Type : Entity_Id; - - Target_Comp_Type : constant Entity_Id := - Component_Type (Target_Type); - Opnd_Comp_Type : constant Entity_Id := - Component_Type (Opnd_Type); - - begin - while Present (Target_Index) and then Present (Opnd_Index) loop - Target_Index_Type := Etype (Target_Index); - Opnd_Index_Type := Etype (Opnd_Index); - - if not (Is_Integer_Type (Target_Index_Type) - and then Is_Integer_Type (Opnd_Index_Type)) - and then (Root_Type (Target_Index_Type) - /= Root_Type (Opnd_Index_Type)) - then - Error_Msg_N - ("incompatible index types for array conversion", - Operand); - return False; - end if; - - Next_Index (Target_Index); - Next_Index (Opnd_Index); - end loop; - - declare - BT : constant Entity_Id := Base_Type (Target_Comp_Type); - BO : constant Entity_Id := Base_Type (Opnd_Comp_Type); - - begin - if BT = BO then - null; - - elsif - (Ekind (BT) = E_Anonymous_Access_Type - or else Ekind (BT) = E_Anonymous_Access_Subprogram_Type) - and then Ekind (BO) = Ekind (BT) - and then Subtypes_Statically_Match - (Target_Comp_Type, Opnd_Comp_Type) - then - null; - - else - Error_Msg_N - ("incompatible component types for array conversion", - Operand); - return False; - end if; - end; - - if Is_Constrained (Target_Comp_Type) /= - Is_Constrained (Opnd_Comp_Type) - or else not Subtypes_Statically_Match - (Target_Comp_Type, Opnd_Comp_Type) - then - Error_Msg_N - ("component subtypes must statically match", Operand); - return False; - - end if; - end; + return Valid_Array_Conversion; end if; - return True; - - -- Ada 2005 (AI-251) + -- Anonymous access types where target references an interface elsif (Ekind (Target_Type) = E_General_Access_Type - or else Ekind (Target_Type) = E_Anonymous_Access_Type) + or else + Ekind (Target_Type) = E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the @@ -7602,6 +7883,8 @@ package body Sem_Res is return True; + -- General and anonymous access types + elsif (Ekind (Target_Type) = E_General_Access_Type or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then @@ -7742,6 +8025,8 @@ package body Sem_Res is end if; end; + -- Subprogram access types + elsif (Ekind (Target_Type) = E_Access_Subprogram_Type or else Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) @@ -7792,6 +8077,8 @@ package body Sem_Res is return True; + -- Remote subprogram access types + elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) then @@ -7807,6 +8094,8 @@ package body Sem_Res is N); return True; + -- Tagged types + elsif Is_Tagged_Type (Target_Type) then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index f1a098f..b83be5d 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -114,8 +114,7 @@ package Sem_Res is -- read the spec of Sem. procedure Pre_Analyze_And_Resolve (N : Node_Id); - -- Same, but use type of node because context does not impose a single - -- type. + -- Same, but use type of node because context does not impose a single type private procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index f29ec01..eccae6e 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -106,10 +106,11 @@ package Types is subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) + -- -- This definition is dubious now that we have two more wide character -- sequences that constitute a line terminator. Every reference to -- this subtype needs checking to make sure the wide character case - -- is handled appropriately. + -- is handled appropriately. ??? subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); @@ -206,7 +207,7 @@ package Types is No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node. A test for - -- a Source_Ptr value being >= No_Location is the apporoved way to test + -- a Source_Ptr value being > No_Location is the approved way to test -- for a standard value that does not include No_Location or any of the -- following special definitions. @@ -683,9 +684,10 @@ package Types is -- Types used for Pragma Suppress Management -- ----------------------------------------------- - type Check_Id is ( - Access_Check, + type Check_Id is + (Access_Check, Accessibility_Check, + Alignment_Check, Discriminant_Check, Division_Check, Elaboration_Check, @@ -695,6 +697,7 @@ package Types is Range_Check, Storage_Check, Tag_Check, + Validity_Check, All_Checks); -- The following array contains an entry for each recognized check name @@ -804,23 +807,23 @@ package Types is PE_Access_Before_Elaboration, -- 14 PE_Accessibility_Check_Failed, -- 15 PE_All_Guards_Closed, -- 16 - PE_Duplicated_Entry_Address, -- 17 - PE_Explicit_Raise, -- 18 - PE_Finalize_Raised_Exception, -- 19 - PE_Implicit_Return, -- 20 - PE_Misaligned_Address_Value, -- 21 - PE_Missing_Return, -- 22 - PE_Overlaid_Controlled_Object, -- 23 - PE_Potentially_Blocking_Operation, -- 24 - PE_Stubbed_Subprogram_Called, -- 25 - PE_Unchecked_Union_Restriction, -- 26 - PE_Illegal_RACW_E_4_18, -- 27 - - SE_Empty_Storage_Pool, -- 28 - SE_Explicit_Raise, -- 29 - SE_Infinite_Recursion, -- 30 - SE_Object_Too_Large, -- 31 - SE_Restriction_Violation); -- 32 + PE_Current_Task_In_Entry_Body, -- 17 + PE_Duplicated_Entry_Address, -- 18 + PE_Explicit_Raise, -- 19 + PE_Finalize_Raised_Exception, -- 20 + PE_Implicit_Return, -- 21 + PE_Misaligned_Address_Value, -- 22 + PE_Missing_Return, -- 23 + PE_Overlaid_Controlled_Object, -- 24 + PE_Potentially_Blocking_Operation, -- 25 + PE_Stubbed_Subprogram_Called, -- 26 + PE_Unchecked_Union_Restriction, -- 27 + PE_Illegal_RACW_E_4_18, -- 28 + + SE_Empty_Storage_Pool, -- 29 + SE_Explicit_Raise, -- 30 + SE_Infinite_Recursion, -- 31 + SE_Object_Too_Large); -- 32 subtype RT_CE_Exceptions is RT_Exception_Code range CE_Access_Check_Failed .. @@ -832,6 +835,6 @@ package Types is subtype RT_SE_Exceptions is RT_Exception_Code range SE_Empty_Storage_Pool .. - SE_Restriction_Violation; + SE_Object_Too_Large; end Types; diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 94f9b24..ca0148b 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2005, Free Software Foundation, Inc. * + * Copyright (C) 1992-2006, 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- * @@ -348,22 +348,22 @@ typedef Int Mechanism_Type; #define PE_Access_Before_Elaboration 14 #define PE_Accessibility_Check_Failed 15 #define PE_All_Guards_Closed 16 -#define PE_Duplicated_Entry_Address 17 -#define PE_Explicit_Raise 18 -#define PE_Finalize_Raised_Exception 19 -#define PE_Implicit_Return 20 -#define PE_Misaligned_Address_Value 21 -#define PE_Missing_Return 22 -#define PE_Overlaid_Controlled_Object 23 -#define PE_Potentially_Blocking_Operation 24 -#define PE_Stubbed_Subprogram_Called 25 -#define PE_Unchecked_Union_Restriction 26 -#define PE_Illegal_RACW_E_4_18 27 - -#define SE_Empty_Storage_Pool 28 -#define SE_Explicit_Raise 29 -#define SE_Infinite_Recursion 30 -#define SE_Object_Too_Large 31 -#define SE_Restriction_Violation 32 - -#define LAST_REASON_CODE 31 +#define PE_Current_Task_In_Entry_Body 17 +#define PE_Duplicated_Entry_Address 18 +#define PE_Explicit_Raise 19 +#define PE_Finalize_Raised_Exception 20 +#define PE_Implicit_Return 21 +#define PE_Misaligned_Address_Value 22 +#define PE_Missing_Return 23 +#define PE_Overlaid_Controlled_Object 24 +#define PE_Potentially_Blocking_Operation 25 +#define PE_Stubbed_Subprogram_Called 26 +#define PE_Unchecked_Union_Restriction 27 +#define PE_Illegal_RACW_E_4_18 28 + +#define SE_Empty_Storage_Pool 29 +#define SE_Explicit_Raise 30 +#define SE_Infinite_Recursion 31 +#define SE_Object_Too_Large 32 + +#define LAST_REASON_CODE 32 |