+2012-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.ads (Build_Array_Invariant_Proc): moved to body.
+ * exp_ch3.adb (Build_Array_Invariant_Proc,
+ Build_Record_Invariant_Proc): transform into functions.
+ (Insert_Component_Invariant_Checks): for composite types that have
+ components with specified invariants, build a checking procedure,
+ and make into the invariant procedure of the composite type,
+ or incorporate it into the user- defined invariant procedure if
+ one has been created.
+ * sem_ch3.adb (Array_Type_Declaration): Checking for invariants
+ on the component type is defered to the expander.
+
+2012-10-01 Thomas Quinot <quinot@adacore.com>
+
+ * xsnamest.adb, namet.h, sem_ch10.adb, s-oscons-tmplt.c,
+ xoscons.adb: Minor reformatting.
+
+2012-10-01 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Apply_Parameter_Aliasing_And_Validity_Checks):
+ Do not process subprogram renaminds because a) those cannot
+ have PPC pragmas b) the renamed entity already has the PPCs.
+ (Build_PPC_Pragma): Prepend a PPC pragma for consistency with
+ Process_PPCs.
+ * sem_ch6.adb (Last_Implicit_Declaration): Removed.
+ (Process_PPCs): Insert a post condition body at the start of the
+ declarative region of the related subprogram. This way the body
+ will not freeze anything it shouldn't.
+
2012-10-01 Robert Dewar <dewar@adacore.com>
* freeze.adb, sem_ch6.adb, opt.ads, sem_ch13.adb,
Set_Declarations (Subp_Decl, Decls);
end if;
- Append_To (Decls, Prag);
+ Prepend_To (Decls, Prag);
-- Ensure the proper visibility of the subprogram body and its
-- parameters.
or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
+ -- Do not consider subprogram renaminds because the renamed entity
+ -- already has the proper PPC pragmas.
+
+ or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
+
-- Do not process null procedures because there is no benefit of
-- adding the checks to a no action routine.
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
+ function Build_Array_Invariant_Proc
+ (A_Type : Entity_Id;
+ Nod : Node_Id) return Node_Id;
+ -- If the component of type of array type has invariants, build procedure
+ -- that checks invariant on all components of the array. Ada 2012 specifies
+ -- that an invariant on some type T must be applied to in-out parameters
+ -- and return values that include a part of type T. If the array type has
+ -- an otherwise specified invariant, the component check procedure is
+ -- called from within the user-specified invariant. Otherwise this becomes
+ -- the invariant procedure for the array type.
+
+ function Build_Record_Invariant_Proc
+ (R_Type : Entity_Id;
+ Nod : Node_Id) return Node_Id;
+ -- Ditto for record types.
+
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
-- Build record initialization procedure. N is the type declaration
-- node, and Rec_Ent is the corresponding entity for the record type.
- procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id);
- -- If the record type has components whose types have invariant, build
- -- an invariant procedure for the record type itself.
-
procedure Build_Slice_Assignment (Typ : Entity_Id);
-- Build assignment procedure for one-dimensional arrays of controlled
-- types. Other array and slice assignments are expanded in-line, but
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
+ procedure Insert_Component_Invariant_Checks
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Proc : Node_Id);
+ -- If a composite type has invariants and also has components with defined
+ -- invariants. the component invariant procedure is inserted into the user-
+ -- defined invariant procedure and added to the checks to be performed.
+
procedure Initialization_Warning (E : Entity_Id);
-- If static elaboration of the package is requested, indicate
-- when a type does meet the conditions for static initialization. If
-- Build_Array_Invariant_Proc --
--------------------------------
- procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is
+ function Build_Array_Invariant_Proc
+ (A_Type : Entity_Id;
+ Nod : Node_Id) return Node_Id
+ is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
Proc_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (A_Type), "Invariant"));
- Set_Has_Invariants (Proc_Id);
- Set_Invariant_Procedure (A_Type, Proc_Id);
+ Chars => New_External_Name (Chars (A_Type), "CInvariant"));
Body_Stmts := Check_One_Dimension (1);
Set_Debug_Info_Off (Proc_Id);
end if;
- -- The procedure body is placed after the freeze node for the type.
-
- Insert_After (Nod, Proc_Body);
- Analyze (Proc_Body);
+ return Proc_Body;
end Build_Array_Invariant_Proc;
--------------------------------
-- Build_Record_Invariant_Proc --
--------------------------------
- procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id) is
+ function Build_Record_Invariant_Proc
+ (R_Type : Entity_Id;
+ Nod : Node_Id) return Node_Id
+ is
Loc : constant Source_Ptr := Sloc (Nod);
Object_Name : constant Name_Id := New_Internal_Name ('I');
then
Stmts := Build_Invariant_Checks (Component_List (Type_Def));
else
- return;
+ return Empty;
end if;
if not Invariant_Found then
- return;
+ return Empty;
end if;
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (R_Type), "Invariant"));
- Set_Has_Invariants (Proc_Id);
- Set_Has_Invariants (R_Type);
- Set_Invariant_Procedure (R_Type, Proc_Id);
Proc_Body :=
Make_Subprogram_Body (Loc,
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
- -- The procedure body is placed after the freeze node for the type.
-
- Insert_After (Nod, Proc_Body);
- Analyze (Proc_Body);
+ return Proc_Body;
+ -- Insert_After (Nod, Proc_Body);
+ -- Analyze (Proc_Body);
end Build_Record_Invariant_Proc;
----------------------------
end if;
if Has_Invariants (Component_Type (Base)) then
- Build_Array_Invariant_Proc (Base, N);
+
+ -- Generate component invariant checking procedure.
+
+ Insert_Component_Invariant_Checks
+ (N, Base, Build_Array_Invariant_Proc (Base, N));
end if;
end Expand_Freeze_Array_Type;
end;
end if;
- if not Has_Invariants (Def_Id) then
- Build_Record_Invariant_Proc (Def_Id, N);
- end if;
+ -- Check whether individual components have a defined invariant,
+ -- and add the corresponding component invariant checks.
+
+ Insert_Component_Invariant_Checks
+ (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N));
end Expand_Freeze_Record_Type;
------------------------------
return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
end In_Runtime;
+ ---------------------------------------
+ -- Insert_Component_Invariant_Checks --
+ ---------------------------------------
+
+ procedure Insert_Component_Invariant_Checks
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Proc : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Proc_Id : Entity_Id;
+
+ begin
+ if Present (Proc) then
+ Proc_Id := Defining_Entity (Proc);
+
+ if not Has_Invariants (Typ) then
+ Set_Has_Invariants (Typ);
+ Set_Has_Invariants (Proc_Id);
+ Set_Invariant_Procedure (Typ, Proc_Id);
+ Insert_After (N, Proc);
+ Analyze (Proc);
+
+ else
+
+ -- Find already created invariant body, insert body of component
+ -- invariant proc in it, and add call after other checks.
+
+ declare
+ Bod : Node_Id;
+ Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
+ Call : constant Node_Id :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations =>
+ New_List
+ (New_Reference_To (First_Formal (Inv_Id), Loc)));
+
+ begin
+
+ -- The invariant body has not been analyzed yet, so we do a
+ -- sequential search forward, and retrieve it by name.
+
+ Bod := Next (N);
+ while Present (Bod) loop
+ exit when Nkind (Bod) = N_Subprogram_Body
+ and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id);
+ Next (Bod);
+ end loop;
+
+ Append_To (Declarations (Bod), Proc);
+ Append_To (Statements (Handled_Statement_Sequence (Bod)), Call);
+ end;
+ end if;
+ end if;
+ end Insert_Component_Invariant_Checks;
+
----------------------------
-- Initialization_Warning --
----------------------------
procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record
- procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id);
- -- If the component of type of array type has invariants, build procedure
- -- that checks invariant on all components of the array. Ada 2012 specifies
- -- that an invariant on some type T must be applied to in-out parameters
- -- and return values that include a part of type T.
-
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Builds function which checks whether the component name is consistent
-- with the current discriminants. N is the full type declaration node,
* *
* C Header File *
* *
- * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2012, 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- *
****************************************************************************/
/* This is the C file that corresponds to the Ada package specification
- Namet. It was created manually from files namet.ads and namet.adb. */
+ Namet. It was created manually from files namet.ads and namet.adb.
+ Some subprograms from Sinput are also made acessable here. */
#ifdef __cplusplus
extern "C" {
#define Is_Non_Ada_Error exp_ch11__is_non_ada_error
extern Boolean Is_Non_Ada_Error (Entity_Id);
-/* Here are some functions in sinput.adb we call from a-trans.c. */
+/* Here are some functions in sinput.adb we call from trans.c. */
+
typedef Nat Source_File_Index;
typedef Int Logical_Line_Number;
typedef Int Column_Number;
#define Target_Name TARGET
CST(Target_Name, "")
-#define sizeof_unsigned_int sizeof (unsigned int)
-CND(sizeof_unsigned_int, "Size of unsigned int")
+/**
+ ** Note: the name of the following constant is recognized specially by
+ ** xoscons (case sensitive).
+ **/
+#define SIZEOF_unsigned_int sizeof (unsigned int)
+CND(SIZEOF_unsigned_int, "Size of unsigned int")
/*
Set_Corresponding_Stub (Unit (Comp_Unit), N);
-- Collect SCO information for loaded subunit if we are
- -- in the main unit).
+ -- in the main unit.
if Generate_SCO
and then
Subtype_Indication (Component_Def));
end if;
- -- Ada 2012: if the element type has invariants we must create an
- -- invariant procedure for the array type as well.
-
- if Has_Invariants (Element_Type) then
- Set_Has_Invariants (T);
- end if;
+ -- There may be an invariant declared for the component type, but
+ -- the construction of the component invariant checking procedure
+ -- takes place during expansion.
end Array_Type_Declaration;
------------------------------------------------------
-- references to parameters of the inherited subprogram to point to the
-- corresponding parameters of the current subprogram.
+ procedure Insert_Before_First_Source_Declaration (Nod : Node_Id);
+ -- Insert node Nod before the first source declaration of the context
+
function Invariants_Or_Predicates_Present return Boolean;
-- Determines if any invariants or predicates are present for any OUT
-- or IN OUT parameters of the subprogram, or (for a function) if the
-- that an invariant check is required (for an IN OUT parameter, or
-- the returned value of a function.
- function Last_Implicit_Declaration return Node_Id;
- -- Return the last internally-generated declaration of N
-
-------------
-- Grab_CC --
-------------
return CP;
end Grab_PPC;
+ --------------------------------------------
+ -- Insert_Before_First_Source_Declaration --
+ --------------------------------------------
+
+ procedure Insert_Before_First_Source_Declaration (Nod : Node_Id) is
+ Decls : constant List_Id := Declarations (N);
+ Decl : Node_Id;
+
+ begin
+ if No (Decls) then
+ Set_Declarations (N, New_List (Nod));
+ else
+ Decl := First (Decls);
+
+ while Present (Decl) loop
+ if Comes_From_Source (Decl) then
+ exit;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ if No (Decl) then
+ Append_To (Decls, Nod);
+ else
+ Insert_Before (Decl, Nod);
+ end if;
+ end if;
+ end Insert_Before_First_Source_Declaration;
+
--------------------------------------
-- Invariants_Or_Predicates_Present --
--------------------------------------
end if;
end Is_Public_Subprogram_For;
- -------------------------------
- -- Last_Implicit_Declaration --
- -------------------------------
-
- function Last_Implicit_Declaration return Node_Id is
- Loc : constant Source_Ptr := Sloc (N);
- Decls : List_Id := Declarations (N);
- Decl : Node_Id;
- Succ : Node_Id;
-
- begin
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (N, Decls);
-
- elsif Is_Empty_List (Declarations (N)) then
- Append_To (Decls, Make_Null_Statement (Loc));
- end if;
-
- -- Implicit and source declarations may be interspersed. Search for
- -- the last implicit declaration which is either succeeded by a
- -- source construct or is the last node in the declarative list.
-
- Decl := First (Declarations (N));
- while Present (Decl) loop
- Succ := Next (Decl);
-
- -- The current declaration is the last one, do not return Empty
-
- if No (Succ) then
- exit;
-
- -- The successor is a source construct
-
- elsif Comes_From_Source (Succ) then
- exit;
- end if;
-
- Next (Decl);
- end loop;
-
- return Decl;
- end Last_Implicit_Declaration;
-
-- Start of processing for Process_PPCs
begin
-- The entity for the _Postconditions procedure
begin
- Insert_After (Last_Implicit_Declaration,
+ -- Insert the corresponding body of a post condition pragma before
+ -- the first source declaration of the context. This ensures that
+ -- any [sub]types generated in relation to the formals of the
+ -- subprogram are still visible in the _postcondition body.
+
+ Insert_Before_First_Source_Declaration (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Info.Value_Len := Info.Text_Value'Length;
end if;
- if Info.Constant_Name.all = "sizeof_unsigned_int" then
+ if Info.Constant_Name.all = "SIZEOF_unsigned_int" then
Size_Of_Unsigned_Int :=
8 * Integer (Info.Int_Value.Abs_Value);
end if;
Output_Header_Line (Prag);
end if;
else
- Oval := Lpad (V (Val), 3, '0');
if Match (Name0, "Last_") then
Oval := Lpad (V (Val - 1), 3, '0');
+ else
+ Oval := Lpad (V (Val), 3, '0');
end if;
Put_Line
projects / thirdparty / gcc.git / commitdiff
