+2012-07-16 Robert Dewar <dewar@adacore.com>
+
+ * a-direct.adb, g-dirope.adb: Minor reformatting.
+
+2012-07-16 Tristan Gingold <gingold@adacore.com>
+
+ * a-except.ads, a-except-2005.ads: Remove outdated comment.
+
+2012-07-16 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch6.adb (Subprogram_Name_Greater): Fix algorithm to
+ conform to documentation.
+
+2012-07-16 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat1drv.adb (Check_Library_Items): Removed, no longer used.
+
+2012-07-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Array_Type_Declaration): if component type has
+ invariants, the array type itself requires an invariant procedure.
+ * exp_ch3.ads, exp_ch3.adb (Build_Array_Invariant_Proc): new
+ procedure, to build a checking procedure that applies the
+ invariant check on some type T to each component of an array
+ of T's. Code is similar to the construction of the init_proc
+ for an array, and handles multidimensional arrays by recursing
+ over successive dimensions.
+
+2012-07-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * g-debpoo.adb: Revert previous change.
+
+2012-07-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_Entity): Insert the itype reference to a
+ library-level class-wide subtype after the freeze node of the
+ equivalent record type.
+
2012-07-16 Pascal Obry <obry@adacore.com>
* s-crtl.ads (mkdir): New routine, support encoding.
-- Acquire setting of encoding parameter
declare
- Formstr : constant String := To_Lower (Form);
+ Formstr : constant String := To_Lower (Form);
Encoding : CRTL.Filename_Encoding;
-- Filename encoding specified into the form parameter
- V1, V2 : Natural;
+ V1, V2 : Natural;
begin
Form_Parameter (Formstr, "encoding", V1, V2);
if V1 = 0 then
Encoding := CRTL.Unspecified;
-
elsif Formstr (V1 .. V2) = "utf8" then
Encoding := CRTL.UTF8;
-
elsif Formstr (V1 .. V2) = "8bits" then
Encoding := CRTL.ASCII_8bits;
-
else
raise Use_Error with "invalid Form";
end if;
type Exception_Occurrence is record
Id : Exception_Id;
-- Exception_Identity for this exception occurrence
- --
- -- WARNING System.System.Finalization_Implementation.Finalize_List
- -- relies on the fact that this field is always first in the exception
- -- occurrence
Msg_Length : Natural := 0;
-- Length of message (zero = no message)
type Exception_Occurrence is record
Id : Exception_Id;
-- Exception_Identity for this exception occurrence
- -- WARNING System.System.Finalization_Implementation.Finalize_List
- -- relies on the fact that this field is always first in the exception
- -- occurrence
Msg_Length : Natural := 0;
-- Length of message (zero = no message)
end if;
end Build_Array_Init_Proc;
+ --------------------------------
+ -- Build_Array_Invariant_Proc --
+ --------------------------------
+
+ procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Nod);
+ Object_Name : constant Name_Id := New_Internal_Name ('I');
+ -- Name for argument of invariant procedure
+
+ Object_Entity : constant Node_Id :=
+ Make_Defining_Identifier (Loc, Object_Name);
+ -- The procedure declaration entity for the argument
+
+ Body_Stmts : List_Id;
+ Index_List : List_Id;
+ Proc_Id : Entity_Id;
+ Proc_Body : Node_Id;
+
+ function Build_Component_Invariant_Call return Node_Id;
+ -- Create one statement to verify invariant on one array component,
+ -- designated by a full set of indexes.
+
+ function Check_One_Dimension (N : Int) return List_Id;
+ -- Create loop to check on one dimension of the array. The single
+ -- statement in the loop body checks the inner dimensions if any, or
+ -- else a single component. This procedure is called recursively, with
+ -- N being the dimension to be initialized. A call with N greater than
+ -- the number of dimensions generates the component initialization
+ -- and terminates the recursion.
+
+ ------------------------------------
+ -- Build_Component_Invariant_Call --
+ ------------------------------------
+
+ function Build_Component_Invariant_Call return Node_Id is
+ Comp : Node_Id;
+
+ begin
+ Comp :=
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Object_Entity, Loc),
+ Expressions => Index_List);
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Invariant_Procedure (Component_Type (A_Type)), Loc),
+ Parameter_Associations => New_List (Comp));
+
+ end Build_Component_Invariant_Call;
+
+ -------------------------
+ -- Check_One_Dimension --
+ -------------------------
+
+ function Check_One_Dimension (N : Int) return List_Id is
+ Index : Entity_Id;
+
+ begin
+ -- If all dimensions dealt with, we simply check invariant of
+ -- the component
+
+ if N > Number_Dimensions (A_Type) then
+ return New_List (Build_Component_Invariant_Call);
+
+ -- Else generate one loop and recurse
+
+ else
+ Index :=
+ Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+
+ Append (New_Reference_To (Index, Loc), Index_List);
+
+ return New_List (
+ Make_Implicit_Loop_Statement (Nod,
+ Identifier => Empty,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Index,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Object_Entity, Loc),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, N))))),
+ Statements => Check_One_Dimension (N + 1)));
+ end if;
+ end Check_One_Dimension;
+
+ -- Start of processing for Build_Array_Invariant_Proc
+
+ begin
+ Index_List := New_List;
+
+ 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);
+
+ Body_Stmts := Check_One_Dimension (1);
+
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
+
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts));
+
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Is_Public (Proc_Id, Is_Public (A_Type));
+ Set_Is_Internal (Proc_Id);
+ Set_Has_Completion (Proc_Id);
+
+ if not Debug_Generated_Code then
+ 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);
+ end Build_Array_Invariant_Proc;
+
--------------------------------
-- Build_Discr_Checking_Funcs --
--------------------------------
then
Build_Array_Init_Proc (Base, N);
end if;
+
+ if Has_Invariants (Component_Type (Base)) then
+ Build_Array_Invariant_Proc (Base, N);
+ end if;
end Expand_Freeze_Array_Type;
-----------------------------------
-- --
-- S p e c --
-- --
--- 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- --
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,
return Result;
end if;
- -- If the Class_Wide_Type is an Itype (when type is the anonymous
- -- parent of a derived type) and it is a library-level entity,
- -- generate an itype reference for it. Otherwise, its first
- -- explicit reference may be in an inner scope, which will be
- -- rejected by the back-end.
+ -- The equivalent type associated with a class-wide subtype needs
+ -- to be frozen to ensure that its layout is done.
+
+ if Ekind (E) = E_Class_Wide_Subtype
+ and then Present (Equivalent_Type (E))
+ then
+ Freeze_And_Append (Equivalent_Type (E), N, Result);
+ end if;
+
+ -- Generate an itype reference for a library-level class-wide type
+ -- at the freeze point. Otherwise the first explicit reference to
+ -- the type may appear in an inner scope which will be rejected by
+ -- the back-end.
if Is_Itype (E)
and then Is_Compilation_Unit (Scope (E))
begin
Set_Itype (Ref, E);
- Add_To_Result (Ref);
- end;
- end if;
- -- The equivalent type associated with a class-wide subtype needs
- -- to be frozen to ensure that its layout is done.
+ -- From a gigi point of view, a class-wide subtype derives
+ -- from its record equivalent type. As a result, the itype
+ -- reference must appear after the freeze node of the
+ -- equivalent type or gigi will reject the reference.
- if Ekind (E) = E_Class_Wide_Subtype
- and then Present (Equivalent_Type (E))
- then
- Freeze_And_Append (Equivalent_Type (E), N, Result);
+ if Ekind (E) = E_Class_Wide_Subtype
+ and then Present (Equivalent_Type (E))
+ then
+ Insert_After (Freeze_Node (Equivalent_Type (E)), Ref);
+ else
+ Add_To_Result (Ref);
+ end if;
+ end;
end if;
-- For a record (sub)type, freeze all the component types (RM
-- terms of wasted memory). To do that, all we should have to do it to
-- set the size of this array to the page size. See mprotect().
- No_Element : constant Storage_Element := 0;
-
Current : Byte_Count;
P : Ptr;
Trace : Traceback_Htable_Elem_Ptr;
-- Use standard (i.e. through malloc) allocations. This automatically
-- raises Storage_Error if needed. We also try once more to physically
-- release memory, so that even marked blocks, in the advanced scanning,
- -- are freed. Initialize the storage array to avoid bogus warnings by
- -- valgrind.
+ -- are freed.
begin
- P := new Local_Storage_Array'(others => No_Element);
+ P := new Local_Storage_Array;
exception
when Storage_Error =>
Free_Physically (Pool);
- P := new Local_Storage_Array'(others => No_Element);
+ P := new Local_Storage_Array;
end;
Storage_Address :=
procedure Make_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
-
begin
if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then
raise Directory_Error;
-- Called when we are not generating code, to check if -gnatR was requested
-- and if so, explain that we will not be honoring the request.
- procedure Check_Library_Items;
- -- For debugging -- checks the behavior of Walk_Library_Items
- pragma Warnings (Off, Check_Library_Items);
- -- In case the call below is commented out
-
----------------------------
-- Adjust_Global_Switches --
----------------------------
end if;
end Check_Bad_Body;
- -------------------------
- -- Check_Library_Items --
- -------------------------
-
- -- Walk_Library_Items has plenty of assertions, so all we need to do is
- -- call it, just for these assertions, not actually doing anything else.
-
- procedure Check_Library_Items is
-
- procedure Action (Item : Node_Id);
- -- Action passed to Walk_Library_Items to do nothing
-
- ------------
- -- Action --
- ------------
-
- procedure Action (Item : Node_Id) is
- begin
- null;
- end Action;
-
- procedure Walk is new Sem.Walk_Library_Items (Action);
-
- -- Start of processing for Check_Library_Items
-
- begin
- Walk;
- end Check_Library_Items;
-
--------------------
-- Check_Rep_Info --
--------------------
Namet.Lock;
Stringt.Lock;
- -- ???Check_Library_Items under control of a debug flag, because it
- -- currently does not work if the -gnatn switch (back end inlining) is
- -- used.
-
- if Debug_Flag_Dot_WW then
- Check_Library_Items;
- end if;
-
-- Here we call the back end to generate the output code
Generating_Code := True;
("the type of a component cannot be abstract",
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;
end Array_Type_Declaration;
------------------------------------------------------
N1, N2 : Natural;
begin
- -- Remove trailing numeric parts
+ -- Deal with special case where names are identical except for a
+ -- numerical suffix. These are handled specially, taking the numeric
+ -- ordering from the suffix into account.
L1 := S1'Last;
while S1 (L1) in '0' .. '9' loop
L2 := L2 - 1;
end loop;
- -- If non-numeric parts non-equal, that's decisive
+ -- If non-numeric parts non-equal, do straight compare
- if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
- return False;
-
- elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
- return True;
+ if S1 (S1'First .. L1) /= S2 (S2'First .. L2) then
+ return S1 > S2;
-- If non-numeric parts equal, compare suffixed numeric parts. Note
-- that a missing suffix is treated as numeric zero in this test.
projects / gcc.git / commitdiff