+2015-10-20 Tristan Gingold <gingold@adacore.com>
+
+ * sem_util.adb (Is_Protected_Self_Reference): Remove reference to
+ UET_Address in comment.
+ * sem_attr.adb (Check_Unit_Name): Adjust comment.
+ (Analyze_Attribute): Remove handling of UET_Address.
+ * sem_attr.ads (Attribute_Impl_Def): Remove Attribute_UET_Address.
+ * snames.ads-tmpl Remove Name_UET_Address, Attribute_UET_Address.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Remove
+ Attribute_UET_Address.
+
+2015-10-20 Bob Duff <duff@adacore.com>
+
+ * a-cbdlli.adb, a-cdlili.adb, a-chtgop.adb, a-cidlli.adb,
+ * a-cobove.adb, a-coinve.adb, a-convec.adb, a-crbtgo.adb ("="): Avoid
+ modifying the tampering counts unnecessarily.
+ (Adjust): Zero tampering counts unconditionally.
+
+2015-10-20 Jerome Lambourg <lambourg@adacore.com>
+
+ * init.c: Fix build issue on arm-vx6 when building the RTP
+ run-time.
+
+2015-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): If the expression
+ is an aggregate and compilation is in -gnatI mode (ignore rep
+ clauses) do not delay resolution of aggregate, to prevent freeze
+ actions out of order in the backend.
+
+2015-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.ads, sem_prag.adb (Build_Generic_Class_Condition):
+ New procedure to construct a generic function for a class-wide
+ precondition, to implement AI12-0113 concerning the new semantics
+ of class-wide preconditions for overriding uperations.
+
2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_util.adb (Find_Actual): The routine is
---------
function "=" (Left, Right : List) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
-
- LN : Node_Array renames Left.Nodes;
- RN : Node_Array renames Right.Nodes;
-
- LI : Count_Type;
- RI : Count_Type;
begin
if Left.Length /= Right.Length then
return False;
end if;
- LI := Left.First;
- RI := Right.First;
- for J in 1 .. Left.Length loop
- if LN (LI).Element /= RN (RI).Element then
- return False;
- end if;
+ if Left.Length = 0 then
+ return True;
+ end if;
- LI := LN (LI).Next;
- RI := RN (RI).Next;
- end loop;
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+
+ LN : Node_Array renames Left.Nodes;
+ RN : Node_Array renames Right.Nodes;
+
+ LI : Count_Type := Left.First;
+ RI : Count_Type := Right.First;
+ begin
+ for J in 1 .. Left.Length loop
+ if LN (LI).Element /= RN (RI).Element then
+ return False;
+ end if;
+
+ LI := LN (LI).Next;
+ RI := RN (RI).Next;
+ end loop;
+ end;
return True;
end "=";
---------
function "=" (Left, Right : List) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
-
- L : Node_Access;
- R : Node_Access;
-
begin
if Left.Length /= Right.Length then
return False;
end if;
- L := Left.First;
- R := Right.First;
- for J in 1 .. Left.Length loop
- if L.Element /= R.Element then
- return False;
- end if;
+ if Left.Length = 0 then
+ return True;
+ end if;
- L := L.Next;
- R := R.Next;
- end loop;
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+
+ L : Node_Access := Left.First;
+ R : Node_Access := Right.First;
+ begin
+ for J in 1 .. Left.Length loop
+ if L.Element /= R.Element then
+ return False;
+ end if;
+
+ L := L.Next;
+ R := R.Next;
+ end loop;
+ end;
return True;
end "=";
Src : Node_Access := Container.First;
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (Container.TC);
+
if Src = null then
pragma Assert (Container.Last = null);
pragma Assert (Container.Length = 0);
- pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
function Generic_Equal
(L, R : Hash_Table_Type) return Boolean
is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_L : With_Lock (L.TC'Unrestricted_Access);
- Lock_R : With_Lock (R.TC'Unrestricted_Access);
-
- L_Index : Hash_Type;
- L_Node : Node_Access;
-
- N : Count_Type;
-
begin
- if L'Address = R'Address then
- return True;
- end if;
-
if L.Length /= R.Length then
return False;
end if;
return True;
end if;
- -- Find the first node of hash table L
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- L_Index := 0;
- loop
- L_Node := L.Buckets (L_Index);
- exit when L_Node /= null;
- L_Index := L_Index + 1;
- end loop;
+ Lock_L : With_Lock (L.TC'Unrestricted_Access);
+ Lock_R : With_Lock (R.TC'Unrestricted_Access);
- -- For each node of hash table L, search for an equivalent node in hash
- -- table R.
+ L_Index : Hash_Type;
+ L_Node : Node_Access;
- N := L.Length;
- loop
- if not Find (HT => R, Key => L_Node) then
- return False;
- end if;
-
- N := N - 1;
+ N : Count_Type;
+ begin
+ -- Find the first node of hash table L
- L_Node := Next (L_Node);
+ L_Index := 0;
+ loop
+ L_Node := L.Buckets (L_Index);
+ exit when L_Node /= null;
+ L_Index := L_Index + 1;
+ end loop;
- if L_Node = null then
- -- We have exhausted the nodes in this bucket
+ -- For each node of hash table L, search for an equivalent node in
+ -- hash table R.
- if N = 0 then
- return True;
+ N := L.Length;
+ loop
+ if not Find (HT => R, Key => L_Node) then
+ return False;
end if;
- -- Find the next bucket
+ N := N - 1;
- loop
- L_Index := L_Index + 1;
- L_Node := L.Buckets (L_Index);
- exit when L_Node /= null;
- end loop;
- end if;
- end loop;
+ L_Node := Next (L_Node);
+
+ if L_Node = null then
+ -- We have exhausted the nodes in this bucket
+
+ if N = 0 then
+ return True;
+ end if;
+
+ -- Find the next bucket
+
+ loop
+ L_Index := L_Index + 1;
+ L_Node := L.Buckets (L_Index);
+ exit when L_Node /= null;
+ end loop;
+ end if;
+ end loop;
+ end;
end Generic_Equal;
-----------------------
---------
function "=" (Left, Right : List) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
-
- L : Node_Access;
- R : Node_Access;
-
begin
if Left.Length /= Right.Length then
return False;
end if;
- L := Left.First;
- R := Right.First;
- for J in 1 .. Left.Length loop
- if L.Element.all /= R.Element.all then
- return False;
- end if;
+ if Left.Length = 0 then
+ return True;
+ end if;
- L := L.Next;
- R := R.Next;
- end loop;
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+
+ L : Node_Access := Left.First;
+ R : Node_Access := Right.First;
+ begin
+ for J in 1 .. Left.Length loop
+ if L.Element.all /= R.Element.all then
+ return False;
+ end if;
+
+ L := L.Next;
+ R := R.Next;
+ end loop;
+ end;
return True;
end "=";
Dst : Node_Access;
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (Container.TC);
+
if Src = null then
pragma Assert (Container.Last = null);
pragma Assert (Container.Length = 0);
- pragma Assert (Container.TC = (Busy => 0, Lock => 0));
return;
end if;
Container.First := null;
Container.Last := null;
Container.Length := 0;
- Zero_Counts (Container.TC);
declare
Element : Element_Access := new Element_Type'(Src.Element.all);
---------
overriding function "=" (Left, Right : Vector) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin
if Left.Last /= Right.Last then
return False;
end if;
- for J in Count_Type range 1 .. Left.Length loop
- if Left.Elements (J) /= Right.Elements (J) then
- return False;
- end if;
- end loop;
+ if Left.Length = 0 then
+ return True;
+ end if;
+
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+ begin
+ for J in Count_Type range 1 .. Left.Length loop
+ if Left.Elements (J) /= Right.Elements (J) then
+ return False;
+ end if;
+ end loop;
+ end;
return True;
end "=";
---------
overriding function "=" (Left, Right : Vector) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin
if Left.Last /= Right.Last then
return False;
end if;
- for J in Index_Type range Index_Type'First .. Left.Last loop
- if Left.Elements.EA (J) = null then
- if Right.Elements.EA (J) /= null then
- return False;
- end if;
+ if Left.Length = 0 then
+ return True;
+ end if;
- elsif Right.Elements.EA (J) = null then
- return False;
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
- elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
- return False;
- end if;
- end loop;
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+ begin
+ for J in Index_Type range Index_Type'First .. Left.Last loop
+ if Left.Elements.EA (J) = null then
+ if Right.Elements.EA (J) /= null then
+ return False;
+ end if;
+
+ elsif Right.Elements.EA (J) = null then
+ return False;
+
+ elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
+ return False;
+ end if;
+ end loop;
+ end;
return True;
end "=";
procedure Adjust (Container : in out Vector) is
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (Container.TC);
+
if Container.Last = No_Index then
Container.Elements := null;
return;
begin
Container.Elements := null;
Container.Last := No_Index;
- Zero_Counts (Container.TC);
Container.Elements := new Elements_Type (L);
---------
overriding function "=" (Left, Right : Vector) return Boolean is
- -- Per AI05-0022, the container implementation is required to detect
- -- element tampering by a generic actual subprogram.
-
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
begin
if Left.Last /= Right.Last then
return False;
end if;
- for J in Index_Type range Index_Type'First .. Left.Last loop
- if Left.Elements.EA (J) /= Right.Elements.EA (J) then
- return False;
- end if;
- end loop;
+ if Left.Length = 0 then
+ return True;
+ end if;
+
+ declare
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
+ begin
+ for J in Index_Type range Index_Type'First .. Left.Last loop
+ if Left.Elements.EA (J) /= Right.Elements.EA (J) then
+ return False;
+ end if;
+ end loop;
+ end;
return True;
end "=";
procedure Adjust (Container : in out Vector) is
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (Container.TC);
+
if Container.Last = No_Index then
Container.Elements := null;
return;
begin
Container.Elements := null;
- Zero_Counts (Container.TC);
-- Note: it may seem that the following assignment to Container.Last
-- is useless, since we assign it to L below. However this code is
Root : constant Node_Access := Tree.Root;
use type Helpers.Tamper_Counts;
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (Tree.TC);
+
if N = 0 then
pragma Assert (Root = null);
- pragma Assert (Tree.TC = (Busy => 0, Lock => 0));
return;
end if;
-------------------
function Generic_Equal (Left, Right : Tree_Type) return Boolean is
- Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
- Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
-
- L_Node : Node_Access;
- R_Node : Node_Access;
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
if Left.Length /= Right.Length then
return False;
end if;
return True;
end if;
- L_Node := Left.First;
- R_Node := Right.First;
- while L_Node /= null loop
- if not Is_Equal (L_Node, R_Node) then
- return False;
- end if;
+ declare
+ Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
+ Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
- L_Node := Next (L_Node);
- R_Node := Next (R_Node);
- end loop;
+ L_Node : Node_Access := Left.First;
+ R_Node : Node_Access := Right.First;
+ begin
+ while L_Node /= null loop
+ if not Is_Equal (L_Node, R_Node) then
+ return False;
+ end if;
+
+ L_Node := Next (L_Node);
+ R_Node := Next (R_Node);
+ end loop;
+ end;
return True;
end Generic_Equal;
Expand_Fpt_Attribute_R (N);
end if;
- -----------------
- -- UET_Address --
- -----------------
-
- when Attribute_UET_Address => UET_Address : declare
- Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
-
- begin
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Address), Loc)));
-
- -- Construct name __gnat_xxx__SDP, where xxx is the unit name
- -- in normal external form.
-
- Get_External_Unit_Name_String (Get_Unit_Name (Pref));
- Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
- Name_Len := Name_Len + 7;
- Name_Buffer (1 .. 7) := "__gnat_";
- Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
- Name_Len := Name_Len + 5;
-
- Set_Is_Imported (Ent);
- Set_Interface_Name (Ent,
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
-
- -- Set entity as internal to ensure proper Sprint output of its
- -- implicit importation.
-
- Set_Is_Internal (Ent);
-
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent, Loc),
- Attribute_Name => Name_Address));
-
- Analyze_And_Resolve (N, Typ);
- end UET_Address;
-
------------
-- Update --
------------
#include <iv.h>
#endif
-#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6)
+#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__)
#include <vmLib.h>
#endif
page if there's a match. Additionally we're are assured this is a
genuine stack overflow condition and and set the message and exception
to that effect. */
-#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6)
+#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__)
/* We re-arm the guard page by marking it invalid */
}
}
}
-#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) */
+#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) */
__gnat_clear_exception_count ();
Raise_From_Signal_Handler (exception, msg);
-- itself of the form of a library unit name. Note that this is
-- quite different from Check_Program_Unit, since it only checks
-- the syntactic form of the name, not the semantic identity. This
- -- is because it is used with attributes (Elab_Body, Elab_Spec,
- -- UET_Address and Elaborated) which can refer to non-visible unit.
+ -- is because it is used with attributes (Elab_Body, Elab_Spec and
+ -- Elaborated) which can refer to non-visible unit.
procedure Error_Attr (Msg : String; Error_Node : Node_Id);
pragma No_Return (Error_Attr);
if Aname /= Name_Elab_Body and then
Aname /= Name_Elab_Spec and then
Aname /= Name_Elab_Subp_Body and then
- Aname /= Name_UET_Address and then
Aname /= Name_Enabled and then
Aname /= Name_Old
then
Analyze_And_Resolve (N, Standard_String);
- -----------------
- -- UET_Address --
- -----------------
-
- when Attribute_UET_Address =>
- Check_E0;
- Check_Unit_Name (P);
- Set_Etype (N, RTE (RE_Address));
-
-----------------------
-- Unbiased_Rounding --
-----------------------
Attribute_Terminated |
Attribute_To_Address |
Attribute_Type_Key |
- Attribute_UET_Address |
Attribute_Unchecked_Access |
Attribute_Universal_Literal_String |
Attribute_Unrestricted_Access |
when Attribute_Result =>
null;
- -----------------
- -- UET_Address --
- -----------------
-
- -- Prefix must not be resolved in this case, since it is not a
- -- real entity reference. No action of any kind is require.
-
- when Attribute_UET_Address =>
- return;
-
----------------------
-- Unchecked_Access --
----------------------
-- Aux_DEC into System, then the type Type_Class can be referenced
-- as an entity within System, as can its enumeration literals.
- -----------------
- -- UET_Address --
- -----------------
-
- Attribute_UET_Address => True,
- -- Unit'UET_Address, where Unit is a program unit, yields the address
- -- of the unit exception table for the specified unit. This is only
- -- used in the internal implementation of exception handling. See the
- -- implementation of unit Ada.Exceptions for details on its use.
-
------------------------------
-- Universal_Literal_String --
------------------------------
-- the possible presence of an address clause, and defer resolution
-- and expansion of the aggregate to the freeze point of the entity.
+ -- This is not always legal because the aggregate may contain other
+ -- references that need freezing, e.g. references to other entities
+ -- with address clauses. In any case, when compiling with -gnatI the
+ -- presence of the address clause must be ignored.
+
if Comes_From_Source (N)
and then Expander_Active
and then Nkind (E) = N_Aggregate
- and then (Present (Following_Address_Clause (N))
- or else Delayed_Aspect_Present)
+ and then
+ ((Present (Following_Address_Clause (N))
+ and then not Ignore_Rep_Clauses)
+ or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
end if;
end if;
+ if Class_Present (N) then
+ Build_Generic_Class_Condition (Spec_Id, N);
+ end if;
+
Preanalyze_Assert_Expression (Expr, Standard_Boolean);
-- For a class-wide condition, a reference to a controlling formal must
return False;
end Appears_In;
+ -----------------------------------
+ -- Build_Generic_Class_Condition --
+ -----------------------------------
+
+ procedure Build_Generic_Class_Condition
+ (Subp : Entity_Id;
+ Prag : Node_Id)
+ is
+ Expr : constant Node_Id :=
+ Get_Pragma_Arg
+ (First (Pragma_Argument_Associations (Prag)));
+ Loc : constant Source_Ptr := Sloc (Prag);
+ Map : constant Elist_Id := New_Elmt_List;
+ New_Expr : constant Node_Id := New_Copy_Tree (Expr);
+ New_Pred : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Subp), "Pre", -1));
+ Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result;
+ -- Replace an occurence of a formal parameter of the original expression
+ -- in the precondition, with the formal of the generic function created
+ -- for it.
+
+ --------------------
+ -- Replace_Formal --
+ --------------------
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (N);
+ El : Elmt_Id;
+ F : Entity_Id;
+ New_F : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then (Nkind (Parent (N)) /= N_Parameter_Association
+ or else N /= Selector_Name (Parent (N)))
+ and then Present (Entity (N))
+ and then Is_Formal (Entity (N))
+ then
+ El := First_Elmt (Map);
+ while Present (El) loop
+ F := Node (El);
+ if Chars (F) = Chars (N) then
+ New_F := Node (Next_Elmt (El));
+
+ -- If this is a controlling formal, in the generic it
+ -- becomes a conversion to the controlling formal of the
+ -- operation with the classwide precondition. If the formal
+ -- is an access parameter, a reference to F becomes
+ -- Root (New_F.all)'access.
+
+ if Is_Controlling_Formal (F) then
+ if Is_Access_Type (Etype (F)) then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (
+ Designated_Type (Etype (F)),
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (New_F, Loc))),
+ Attribute_Name => Name_Access));
+
+ else
+ Rewrite (N,
+ Unchecked_Convert_To
+ (Etype (F), New_Occurrence_Of (New_F, Sloc (N))));
+ end if;
+
+ -- Non-controlling formals retain their original type
+
+ else
+ Rewrite (N, New_Occurrence_Of (New_F, Sloc (N)));
+ end if;
+
+ return OK;
+ end if;
+
+ Next_Elmt (El);
+ Next_Elmt (El);
+ end loop;
+
+ elsif Nkind (N) = N_Parameter_Association then
+ Set_Next_Named_Actual (N, Empty);
+
+ elsif Nkind (N) = N_Function_Call then
+ Set_First_Named_Actual (N, Empty);
+ end if;
+
+ return OK;
+ end Replace_Formal;
+
+ procedure Map_Formals is new Traverse_Proc (Replace_Formal);
+
+ -- Local variables
+
+ Bod : Node_Id;
+ Decl : Node_Id;
+ F : Entity_Id;
+ New_F : Entity_Id;
+ New_Form : List_Id;
+ New_Typ : Entity_Id;
+ Par_Typ : Entity_Id;
+ Spec : Node_Id;
+
+ -- Start of processing for Build_Generic_Class_Pre
+
+ begin
+ -- Nothing to do if previous error or expansion disabled.
+
+ if not Expander_Active then
+ return;
+ end if;
+
+ if Chars (Pragma_Identifier (Prag)) = Name_Postcondition then
+ return;
+ end if;
+
+ -- Build list of controlling formals and their renamings in the new
+ -- generic operation.
+
+ New_Form := New_List;
+ New_Typ := Empty;
+
+ F := First_Formal (Subp);
+ while Present (F) loop
+ New_F :=
+ Make_Defining_Identifier (Loc, New_External_Name (Chars (F), "GF"));
+ Set_Ekind (New_F, Ekind (F));
+ Append_Elmt (F, Map);
+ Append_Elmt (New_F, Map);
+
+ if Is_Controlling_Formal (F) then
+ if Is_Access_Type (Etype (F)) then
+ New_Typ :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name
+ (Chars (Designated_Type (Etype (F))), "GT"));
+ Par_Typ :=
+ Make_Access_Definition (Loc,
+ Subtype_Mark => New_Occurrence_Of (New_Typ, Loc));
+ else
+ New_Typ :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Etype (F)), "GT"));
+ Par_Typ := New_Occurrence_Of (New_Typ, Loc);
+ end if;
+
+ Append_To (New_Form,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_F,
+ Parameter_Type => Par_Typ));
+ else
+ -- If formal has a class-wide type, build same attribute for new
+ -- formal.
+
+ if Is_Class_Wide_Type (Etype (F)) then
+ Append_To (New_Form,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_F,
+ Parameter_Type =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etype (Etype (F)), Loc),
+ Attribute_Name => Name_Class)));
+ else
+ Append_To (New_Form,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_F,
+ Parameter_Type => New_Occurrence_Of (Etype (F), Loc)));
+ end if;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ -- If no controlling formal found, pre/postcondition is incorrect.
+
+ if No (New_Typ) then
+ return;
+ end if;
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => New_Pred,
+ Parameter_Specifications => New_Form,
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ Decl :=
+ Make_Generic_Subprogram_Declaration (Loc,
+ Specification => Spec,
+ Generic_Formal_Declarations => New_List (
+ Make_Formal_Type_Declaration (Loc,
+ Defining_Identifier => New_Typ,
+ Formal_Type_Definition =>
+ Make_Formal_Private_Type_Definition (Loc))));
+
+ Preanalyze (New_Expr);
+ Map_Formals (New_Expr);
+
+ Bod :=
+ Make_Subprogram_Body (Loc,
+ Specification => New_Copy_Tree (Spec),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Expr))));
+
+ -- Generic function must be analyzed after type is frozen, and will be
+ -- instantiated when subprogram contract for operation or any of its
+ -- overridings is expanded.
+
+ Append_Freeze_Actions (Typ, New_List (Decl, Bod));
+
+ -- We need to convey the existence of the generic to the point at which
+ -- we expand the contract. We replace the expression in the pragma with
+ -- name of the generic function, to be instantiated when expanding the
+ -- contract for the subprogram or some overriding of it. See
+ -- Exp_ch6.Expand_Subprogram_Contract.Build_Pragma_Check_Equivalent.
+ -- (TBD)
+
+ Set_Ekind (New_Pred, E_Generic_Function);
+ Set_Scope (New_Pred, Current_Scope);
+ end Build_Generic_Class_Condition;
+
-----------------------------
-- Check_Applicable_Policy --
-----------------------------
procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id);
-- Perform preanalysis of pragma Test_Case
+ procedure Build_Generic_Class_Condition
+ (Subp : Entity_Id;
+ Prag : Node_Id);
+ -- AI12-113 modifies the semantics of classwide pre- and postconditions,
+ -- as well as type invariants, so that the expression used in an inherited
+ -- operation uses the actual type and is statically bound, rather than
+ -- using T'Class and dispatching. This new semantics is implemented by
+ -- building a generic function for the corresponding condition and
+ -- instantiating it for each descendant type. Checking the condition is
+ -- implemented as a call to that instantiation.
+
procedure Check_Applicable_Policy (N : Node_Id);
-- N is either an N_Aspect or an N_Pragma node. There are two cases. If
-- the name of the aspect or pragma is not one of those recognized as
begin
-- Verify that prefix is analyzed and has the proper form. Note that
- -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
- -- which also produce the address of an entity, do not analyze their
- -- prefix because they denote entities that are not necessarily visible.
+ -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also
+ -- produce the address of an entity, do not analyze their prefix
+ -- because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
return Ada_Version >= Ada_2005
Name_To_Address : constant Name_Id := N + $; -- GNAT
Name_Type_Class : constant Name_Id := N + $; -- GNAT
Name_Type_Key : constant Name_Id := N + $; -- GNAT
- Name_UET_Address : constant Name_Id := N + $; -- GNAT
Name_Unbiased_Rounding : constant Name_Id := N + $;
Name_Unchecked_Access : constant Name_Id := N + $;
Name_Unconstrained_Array : constant Name_Id := N + $; -- GNAT
Attribute_To_Address,
Attribute_Type_Class,
Attribute_Type_Key,
- Attribute_UET_Address,
Attribute_Unbiased_Rounding,
Attribute_Unchecked_Access,
Attribute_Unconstrained_Array,
projects / gcc.git / commitdiff