+2013-04-23 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Fix_Error): Rewrite to do more accurate job
+ of getting proper name in the case where pragma comes from
+ aspect.
+ * sem_ch3.adb, sinfo.ads, par-ch6.adb, exp_ch6.adb: Minor reformatting.
+
+2013-04-23 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Process_PPCs): Do not filter postconditions based on
+ applicable policy.
+
+2013-04-23 Thomas Quinot <quinot@adacore.com>
+
+ * par_sco.adb (Traverse_Aux_Decls): Minor code reorganization.
+
+2013-04-23 Doug Rupp <rupp@adacore.com>
+
+ * init.c: Move facility macros outside IN_RTS.
+
+2013-04-23 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Freeze_Entity): For the case of a bit-packed
+ array time that is known at compile time to have more that
+ Integer'Last+1 elements, issue an error, since such arrays are
+ not supported.
+
2013-04-23 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Dependency_Clause): Update all calls to
-- this is harder to verify, and there may be a redundant check.
if (Present (Find_Aspect (E_Actual, Aspect_Predicate))
- or else Present
- (Find_Aspect (E_Actual, Aspect_Dynamic_Predicate))
- or else Present
- (Find_Aspect (E_Actual, Aspect_Static_Predicate)))
+ or else
+ Present (Find_Aspect (E_Actual, Aspect_Dynamic_Predicate))
+ or else
+ Present (Find_Aspect (E_Actual, Aspect_Static_Predicate)))
and then not Is_Init_Proc (Subp)
then
- if Is_Derived_Type (E_Actual)
- and then Is_Inherited_Operation_For_Type (Subp, E_Actual)
+ if (Is_Derived_Type (E_Actual)
+ and then Is_Inherited_Operation_For_Type (Subp, E_Actual))
+ or else Is_Entity_Name (Actual)
then
Append_To
(Post_Call, Make_Predicate_Check (E_Actual, Actual));
-
- elsif Is_Entity_Name (Actual) then
- Append_To
- (Post_Call, Make_Predicate_Check (E_Actual, Actual));
end if;
end if;
end if;
end if;
- -- For bit-packed arrays, check the size
+ -- Specific checks for bit-packed arrays
- if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then
- declare
- SizC : constant Node_Id := Size_Clause (E);
+ if Is_Bit_Packed_Array (E) then
- Discard : Boolean;
- pragma Warnings (Off, Discard);
+ -- Check number of elements for bit packed arrays that come
+ -- from source and have compile time known ranges. The
+ -- bit-packed arrays circuitry does not support arrays
+ -- with more than Integer'Last + 1 elements, and when this
+ -- restriction is violated, causes incorrect data access.
- begin
- -- It is not clear if it is possible to have no size
- -- clause at this stage, but it is not worth worrying
- -- about. Post error on the entity name in the size
- -- clause if present, else on the type entity itself.
+ -- For the case where this is not compile time known, a
+ -- run-time check should be generated???
- if Present (SizC) then
- Check_Size (Name (SizC), E, RM_Size (E), Discard);
- else
- Check_Size (E, E, RM_Size (E), Discard);
- end if;
- end;
+ if Comes_From_Source (E) and then Is_Constrained (E) then
+ declare
+ Elmts : Uint;
+ Index : Node_Id;
+ Ilen : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ Elmts := Uint_1;
+ Index := First_Index (E);
+ while Present (Index) loop
+ Ityp := Etype (Index);
+
+ -- Never generate an error if any index is of a
+ -- generic type. We will check this in instances.
+
+ if Is_Generic_Type (Ityp) then
+ Elmts := Uint_0;
+ exit;
+ end if;
+
+ Ilen :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Ityp, Loc),
+ Attribute_Name => Name_Range_Length);
+ Analyze_And_Resolve (Ilen);
+
+ -- No attempt is made to check number of elements
+ -- if not compile time known.
+
+ if Nkind (Ilen) /= N_Integer_Literal then
+ Elmts := Uint_0;
+ exit;
+ end if;
+
+ Elmts := Elmts * Intval (Ilen);
+ Next_Index (Index);
+ end loop;
+
+ if Elmts > Intval (High_Bound
+ (Scalar_Range
+ (Standard_Integer))) + 1
+ then
+ Error_Msg_N
+ ("bit packed array type may not have "
+ & "more than Integer''Last+1 elements", E);
+ end if;
+ end;
+ end if;
+
+ -- Check size
+
+ if Known_RM_Size (E) then
+ declare
+ SizC : constant Node_Id := Size_Clause (E);
+
+ Discard : Boolean;
+ pragma Warnings (Off, Discard);
+
+ begin
+ -- It is not clear if it is possible to have no size
+ -- clause at this stage, but it is not worth worrying
+ -- about. Post error on the entity name in the size
+ -- clause if present, else on the type entity itself.
+
+ if Present (SizC) then
+ Check_Size (Name (SizC), E, RM_Size (E), Discard);
+ else
+ Check_Size (E, E, RM_Size (E), Discard);
+ end if;
+ end;
+ end if;
end if;
-- If any of the index types was an enumeration type with a
#define lib_get_invo_handle LIB$GET_INVO_HANDLE
#endif
+/* Masks for facility identification. */
+#define FAC_MASK 0x0fff0000
+#define DECADA_M_FACILITY 0x00310000
+
/* Define macro symbols for the VMS conditions that become Ada exceptions.
It would be better to just include <ssdef.h> */
/* DEC Ada exceptions are not defined in a header file, so they
must be declared. */
-#define FAC_MASK 0x0fff0000
-#define DECADA_M_FACILITY 0x00310000
-
#define ADA$_ALREADY_OPEN 0x0031a594
#define ADA$_CONSTRAINT_ERRO 0x00318324
#define ADA$_DATA_ERROR 0x003192c4
-- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
-- SUBPROGRAM_BODY ::=
- -- SUBPROGRAM_SPECIFICATION is
+ -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is
-- DECLARATIVE_PART
-- begin
-- HANDLED_SEQUENCE_OF_STATEMENTS
From : Nat;
procedure Traverse_Aux_Decls (N : Node_Id);
- -- Traverse the Aux_Decl_Nodes of compilation unit N
+ -- Traverse the Aux_Decls_Node of compilation unit N
------------------------
-- Traverse_Aux_Decls --
ADN : constant Node_Id := Aux_Decls_Node (N);
begin
Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
- Traverse_Declarations_Or_Statements (Declarations (ADN));
Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
+
+ -- Declarations and Actions do not correspond to source constructs,
+ -- they contain only nodes from expansion, so at this point they
+ -- should still be empty:
+
+ pragma Assert (No (Declarations (ADN)));
+ pragma Assert (No (Actions (ADN)));
end Traverse_Aux_Decls;
-- Start of processing for SCO_Record
if Aliased_Present (N)
and then (not Is_Entity_Name (E)
- or else not Comes_From_Source (E))
+ or else not Comes_From_Source (E))
then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
end if;
Prag := First (Declarations (N));
while Present (Prag) loop
if Nkind (Prag) = N_Pragma then
- Check_Applicable_Policy (Prag);
- -- If pragma, capture if postconditions enabled, else ignore
+ -- Capture postcondition pragmas
- if Pragma_Name (Prag) = Name_Postcondition
- and then not Is_Ignored (Prag)
- then
+ if Pragma_Name (Prag) = Name_Postcondition then
if Plist = No_List then
Plist := Empty_List;
end if;
procedure Fix_Error (Msg : in out String);
-- This is called prior to issuing an error message. Msg is a string
- -- that typically contains the substring "pragma". If the current pragma
- -- comes from an aspect, each such "pragma" substring is replaced with
- -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
- -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
- -- In addition, if the current pragma results from rewriting another
- -- pragma, Error_Msg_Name_1 is set to the original pragma name.
+ -- that typically contains the substring "pragma". If the pragma comes
+ -- from an aspect, each such "pragma" substring is replaced with the
+ -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
+ -- aspect (which may be different from the pragma name). If the current
+ -- pragma results from rewriting another pragma, then Error_Msg_Name_1
+ -- is set to the original pragma name.
procedure Gather_Associations
(Names : Name_List;
---------------
procedure Fix_Error (Msg : in out String) is
- Orig : constant Node_Id := Original_Node (N);
-
begin
+ -- If we have a rewriting of another pragma, go to that pragma
+
+ if Is_Rewrite_Substitution (N)
+ and then Nkind (Original_Node (N)) = N_Pragma
+ then
+ Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
+ end if;
+
+ -- Case where pragma comes from an aspect specification
+
if From_Aspect_Specification (N) then
+
+ -- Change appearence of "pragma" in message to "aspect"
+
for J in Msg'First .. Msg'Last - 5 loop
if Msg (J .. J + 5) = "pragma" then
Msg (J .. J + 5) := "aspect";
end if;
end loop;
- if Error_Msg_Name_1 = Name_Precondition then
- Error_Msg_Name_1 := Name_Pre;
- elsif Error_Msg_Name_1 = Name_Postcondition then
- Error_Msg_Name_1 := Name_Post;
- end if;
+ -- Get name from corresponding aspect
- elsif Orig /= N and then Nkind (Orig) = N_Pragma then
- Error_Msg_Name_1 := Pragma_Name (Orig);
+ if Present (Corresponding_Aspect (N)) then
+ Error_Msg_Name_1 :=
+ Chars (Identifier (Corresponding_Aspect (N)));
+ end if;
end if;
end Fix_Error;
-- an Assertion_Policy pragma), then Is_Ignored is set if assertions are
-- ignored because of the absence of a -gnata switch. For any other
-- aspects or pragmas, the flag is off. If this flag is set, the
- -- aspect/pragma is fully analyzed and checked for other
- -- syntactic/semantic errors, but it does not have any semantic effect.
+ -- aspect/pragma is fully analyzed and checked for other syntactic
+ -- and semantic errors, but it does not have any semantic effect.
-- Is_In_Discriminant_Check (Flag11-Sem)
-- This flag is present in a selected component, and is used to indicate
-- where the interesting allowed cases (which do not fit the syntax of
-- the first alternative above) are
- -- ASPECT_MARK => Pre'Class | Post'Class | Type_Invariant'Class
+ -- ASPECT_MARK => Pre'Class |
+ -- Post'Class |
+ -- Type_Invariant'Class |
+ -- Invariant'Class
-- We allow this special usage in all Ada modes, but it would be a
-- pain to allow these aspects to pervade the pragma syntax, and the
--------------------------
-- SUBPROGRAM_BODY ::=
- -- SUBPROGRAM_SPECIFICATION is
+ -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is
-- DECLARATIVE_PART
-- begin
-- HANDLED_SEQUENCE_OF_STATEMENTS
projects / gcc.git / commitdiff