+2011-09-02 Robert Dewar <dewar@adacore.com>
+
+ * exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb,
+ g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor
+ reformatting.
+
+2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an
+ inherited component with the enclosing derived type. Code reformatting.
+
+2011-09-02 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb: (Determine_Range): Add test of OK1 to prevent the early
+ return done when overflow checks are enabled, since comparisons against
+ Lor and Hir should not be done when OK1 is False.
+
+2011-09-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
+ Add new formal Master_Exp. When present, add that expression to the
+ call as an extra actual.
+ (Make_Build_In_Place_Call_In_Object_Declaration): Add variable
+ Fmaster_Actual and in the case of a BIP call initializing a return
+ object of an enclosing BIP function set it to a
+ new reference to the implicit finalization master
+ formal of the enclosing function. Fmaster_Actual is
+ then passed to the new formal Master_Exp on the call to
+ Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move
+ initializations of Enclosing_Func to its declaration.
+
+2011-09-02 Thomas Quinot <quinot@adacore.com>
+
+ * csets.ads: Minor reformatting
+
+2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve
+ the full view of a private type coming from an instantiation.
+ * exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search
+ loop to iterate over the declarations rather than use the
+ First_Entity / Next_Entity scheme.
+
2011-09-02 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb: (Analyze_Attribute, case 'Range): when expanding
-- to restrict the possible range of results.
-- If one of the computed bounds is outside the range of the base type,
- -- the expression may raise an exception and we better indicate that
+ -- the expression may raise an exception and we had better indicate that
-- the evaluation has failed, at least if checks are enabled.
- if Enable_Overflow_Checks
+ if OK1
+ and then Enable_Overflow_Checks
and then not Is_Entity_Name (N)
and then (Lor < Lo or else Hir > Hi)
then
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 table has True entries for all characters that can legally appear
-- in identifiers, including digits, the underline character, all letters
-- including upper and lower case and extended letters (as controlled by
- -- the setting of Opt.Identifier_Character_Set, left bracket for brackets
+ -- the setting of Opt.Identifier_Character_Set), left bracket for brackets
-- notation wide characters and also ESC if wide characters are permitted
-- in identifiers using escape sequences starting with ESC.
--------------------------------
function Get_Constraint_Association (T : Entity_Id) return Node_Id is
- Typ_Def : constant Node_Id := Type_Definition (Parent (T));
- Indic : constant Node_Id := Subtype_Indication (Typ_Def);
+ Indic : Node_Id;
+ Typ : Entity_Id;
begin
+ Typ := T;
+
+ -- Handle private types in instances
+
+ if In_Instance
+ and then Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ Indic := Subtype_Indication (Type_Definition (Parent (Typ)));
+
-- ??? Also need to cover case of a type mark denoting a subtype
-- with constraint.
------------------------------
function Current_Anonymous_Master return Entity_Id is
- Decls : List_Id;
- Fin_Mas_Id : Entity_Id;
- Loc : Source_Ptr;
- Subp_Body : Node_Id;
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
+ Decls : List_Id;
+ Loc : Source_Ptr;
+ Subp_Body : Node_Id;
+ Unit_Decl : Node_Id;
+ Unit_Id : Entity_Id;
begin
Unit_Id := Cunit_Entity (Current_Sem_Unit);
-- declarations and locate the entity.
if Has_Anonymous_Master (Unit_Id) then
- Fin_Mas_Id := First_Entity (Unit_Id);
- while Present (Fin_Mas_Id) loop
+ declare
+ Decl : Node_Id;
+ Fin_Mas_Id : Entity_Id;
- -- Look for the first variable whose type is Finalization_Master
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
- if Ekind (Fin_Mas_Id) = E_Variable
- and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
- then
- return Fin_Mas_Id;
- end if;
+ -- Look for the first variable in the declarations whole type
+ -- is Finalization_Master.
- Next_Entity (Fin_Mas_Id);
- end loop;
+ if Nkind (Decl) = N_Object_Declaration then
+ Fin_Mas_Id := Defining_Identifier (Decl);
- raise Program_Error;
+ if Ekind (Fin_Mas_Id) = E_Variable
+ and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
+ then
+ return Fin_Mas_Id;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- The master was not found even though the unit was labeled as
+ -- having one.
+
+ raise Program_Error;
+ end;
-- Create a new anonymous master
declare
First_Decl : constant Node_Id := First (Decls);
Action : Node_Id;
+ Fin_Mas_Id : Entity_Id;
begin
-- Since the master and its associated initialization is inserted
-- Extra_Formal in Subprogram_Call.
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
- (Func_Call : Node_Id;
- Func_Id : Entity_Id;
- Ptr_Typ : Entity_Id := Empty);
+ (Func_Call : Node_Id;
+ Func_Id : Entity_Id;
+ Ptr_Typ : Entity_Id := Empty;
+ Master_Exp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
-- finalization actions, add an actual parameter which is a pointer to the
- -- finalization master of the caller. If Ptr_Typ is left Empty, this will
- -- result in an automatic "null" value for the actual.
+ -- finalization master of the caller. If Master_Exp is not Empty, then that
+ -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this
+ -- will result in an automatic "null" value for the actual.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
-----------------------------------------------------------
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
- (Func_Call : Node_Id;
- Func_Id : Entity_Id;
- Ptr_Typ : Entity_Id := Empty)
+ (Func_Call : Node_Id;
+ Func_Id : Entity_Id;
+ Ptr_Typ : Entity_Id := Empty;
+ Master_Exp : Node_Id := Empty)
is
begin
if not Needs_BIP_Finalization_Master (Func_Id) then
Desig_Typ : Entity_Id;
begin
+ -- If there is a finalization master actual, such as the implicit
+ -- finalization master of an enclosing build-in-place function,
+ -- then this must be added as an extra actual of the call.
+
+ if Present (Master_Exp) then
+ Actual := Master_Exp;
+
-- Case where the context does not require an actual master
- if No (Ptr_Typ) then
+ elsif No (Ptr_Typ) then
Actual := Make_Null (Loc);
else
Ptr_Typ_Decl : Node_Id;
Def_Id : Entity_Id;
New_Expr : Node_Id;
- Enclosing_Func : Entity_Id;
+ Enclosing_Func : constant Entity_Id :=
+ Enclosing_Subprogram (Obj_Def_Id);
+ Fmaster_Actual : Node_Id := Empty;
Pass_Caller_Acc : Boolean := False;
begin
if Is_Return_Object (Defining_Identifier (Object_Decl)) then
Pass_Caller_Acc := True;
- Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
-
-- When the enclosing function has a BIP_Alloc_Form formal then we
-- pass it along to the callee (such as when the enclosing function
-- has an unconstrained or tagged result type).
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if;
+ if Needs_BIP_Finalization_Master (Enclosing_Func) then
+ Fmaster_Actual :=
+ New_Reference_To
+ (Build_In_Place_Formal
+ (Enclosing_Func, BIP_Finalization_Master), Loc);
+ end if;
+
-- Retrieve the BIPacc formal from the enclosing function and convert
-- it to the access type of the callee's BIP_Object_Access formal.
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
+ -- Pass along any finalization master actual, which is needed in the
+ -- case where the called function initializes a return object of an
+ -- enclosing build-in-place function.
+
Add_Finalization_Master_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id);
+ (Func_Call => Func_Call,
+ Func_Id => Function_Id,
+ Master_Exp => Fmaster_Actual);
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
and then Has_Task (Result_Subt)
then
- Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
-
-- Here we're passing along the master that was passed in to this
-- function.
begin
Change := True;
Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
-
while Change loop
Change := False;
function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
begin
return
Is_Access_Type (Etype (Trans_Id))
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
- -- Do not consider renamed or 'reference-d transient objects because
- -- the act of renaming extends the object's lifetime.
+ -- Do not consider renamed or 'reference-d transient objects because
+ -- the act of renaming extends the object's lifetime.
and then not Is_Aliased (Obj_Id, Decl)
- -- Do not consider transient objects allocated on the heap since they
- -- are attached to a finalization master.
+ -- Do not consider transient objects allocated on the heap since
+ -- they are attached to a finalization master.
and then not Is_Allocated (Obj_Id)
- -- If the transient object is a pointer, check that it is not
- -- initialized by a function which returns a pointer or acts as a
- -- renaming of another pointer.
+ -- If the transient object is a pointer, check that it is not
+ -- initialized by a function which returns a pointer or acts as a
+ -- renaming of another pointer.
and then
(not Is_Access_Type (Obj_Typ)
or else not Initialized_By_Access (Obj_Id))
- -- Do not consider transient objects which act as indirect aliases of
- -- build-in-place function results.
+ -- Do not consider transient objects which act as indirect aliases
+ -- of build-in-place function results.
and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
- -- Do not consider conversions of tags to class-wide types
+ -- Do not consider conversions of tags to class-wide types
and then not Is_Tag_To_CW_Conversion (Obj_Id);
end Is_Finalizable_Transient;
begin
-- If component reference is for an array with non-static bounds,
-- then it is always aligned: we can only process unaligned arrays
- -- with static bounds (more accurately bounds known at compile
- -- time).
+ -- with static bounds (more precisely compile time known bounds).
if Is_Array_Type (T)
and then not Compile_Time_Known_Bounds (T)
-- alignment, and we either know it is too small, or cannot tell,
-- then the component may be unaligned.
+ -- What is the following commented out code ???
+
-- if Known_Alignment (Etype (P))
-- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
-- and then M > Alignment (Etype (P))
with "Expected integer parameter for '"
& Switch & "'";
end;
+
return;
when Switch_String =>
Callback : Switch_Handler := null;
Parser : Opt_Parser := Command_Line_Parser;
Concatenate : Boolean := True);
- -- Similar to the standard Getopt function.
- -- For each switch found on the command line, this calls Callback, if the
- -- switch is not handled automatically.
+ -- Similar to the standard Getopt function. For each switch found on the
+ -- command line, this calls Callback, if the switch is not handled
+ -- automatically.
--
-- The list of valid switches are the ones from the configuration. The
-- switches that were declared through Define_Switch with an Output
-- will display an error message and raises Invalid_Switch again.
--
-- This function automatically expands switches:
- -- * If Define_Prefix was called (for instance "-gnaty") and the user
- -- specifies "-gnatycb" on the command line, then Getopt returns
- -- "-gnatyc" and "-gnatyb" separately.
- -- * If Define_Alias was called (for instance "-gnatya = -gnatycb") then
- -- the latter is returned (in this case it also expands -gnaty as per
- -- the above.
+ --
+ -- If Define_Prefix was called (for instance "-gnaty") and the user
+ -- specifies "-gnatycb" on the command line, then Getopt returns
+ -- "-gnatyc" and "-gnatyb" separately.
+ --
+ -- If Define_Alias was called (for instance "-gnatya = -gnatycb") then
+ -- the latter is returned (in this case it also expands -gnaty as per
+ -- the above.
+ --
-- The goal is to make handling as easy as possible by leaving as much
-- work as possible to this package.
--
-- way to remove a switch from an existing command line.
-- For instance:
+
-- declare
-- Config : Command_Line_Configuration;
-- Line : Command_Line;
-- Args : Argument_List_Access;
+
-- begin
-- Define_Switch (Config, "-gnatyc");
-- Define_Switch (Config, ...); -- for all valid switches
-- Define_Prefix (Config, "-gnaty");
- --
+
-- Set_Configuration (Line, Config);
-- Add_Switch (Line, "-O2");
-- Add_Switch (Line, "-gnatyc");
-- the entity definition.
elsif Get_Scope_Num (T1.Key.Ent_Scope) /=
- Get_Scope_Num (T2.Key.Ent_Scope)
+ Get_Scope_Num (T2.Key.Ent_Scope)
then
return Get_Scope_Num (T1.Key.Ent_Scope) <
Get_Scope_Num (T2.Key.Ent_Scope);
-- Seventh test: for same entity, sort by reference location scope
elsif Get_Scope_Num (T1.Key.Ref_Scope) /=
- Get_Scope_Num (T2.Key.Ref_Scope)
+ Get_Scope_Num (T2.Key.Ref_Scope)
then
return Get_Scope_Num (T1.Key.Ref_Scope) <
Get_Scope_Num (T2.Key.Ref_Scope);
function Equal (F1, F2 : Xref_Entry_Number) return Boolean is
Result : constant Boolean :=
- Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
+ Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
begin
return Result;
end Equal;
Set_Ref : Boolean := True;
Force : Boolean := False)
is
- Nod : Node_Id;
- Ref : Source_Ptr;
- Def : Source_Ptr;
- Ent : Entity_Id;
+ Nod : Node_Id;
+ Ref : Source_Ptr;
+ Def : Source_Ptr;
+ Ent : Entity_Id;
- Actual_Typ : Character := Typ;
+ Actual_Typ : Character := Typ;
Ref_Scope : Entity_Id;
Ent_Scope : Entity_Id;
if XE.Key.Typ = 'e'
and then Ent /= Curent
- and then (Refno = Nrefs or else
- Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
- and then
- not In_Extended_Main_Source_Unit (Ent)
+ and then (Refno = Nrefs
+ or else
+ Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
+ and then not In_Extended_Main_Source_Unit (Ent)
then
goto Continue;
end if;
------------------------
function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
- K : constant Key := Get_Key (E);
+ K : constant Key := Get_Key (E);
Index : constant Header_Num := Hash (K);
- Elmt : Elmt_Ptr := Table (Index);
+ Elmt : Elmt_Ptr;
begin
+ Elmt := Table (Index);
loop
if Elmt = Null_Ptr then
Set_Next (E, Table (Index));
Table (Index) := E;
-
return True;
elsif Equal (Get_Key (Elmt), K) then
LB :=
Make_Attribute_Reference (Loc,
Prefix => P,
- Attribute_Name => Name_First,
- Expressions => (Dims));
+ Attribute_Name => Name_First,
+ Expressions => (Dims));
-- Do not share the dimension indicator, if present. Even
-- though it is a static constant, its source location
Change_Selected_Component_To_Expanded_Name (Name (N));
- -- If this is a child unit without a spec, and it has benn analyzed
+ -- If this is a child unit without a spec, and it has been analyzed
-- already, a declaration has been created for it. The with_clause
-- must reflect the actual body, and not the generated declaration,
-- to prevent spurious binding errors involving an out-of-date spec.
------------------------
procedure Set_Anonymous_Type (Id : Entity_Id) is
- Typ : constant Entity_Id := Etype (Old_C);
+ Old_Typ : constant Entity_Id := Etype (Old_C);
begin
if Scope (Parent_Base) = Scope (Derived_Base) then
- Set_Etype (Id, Typ);
+ Set_Etype (Id, Old_Typ);
-- The parent and the derived type are in two different scopes.
-- Reuse the type of the original discriminant / component by
- -- copying it in order to preserve all attributes and update the
- -- scope.
+ -- copying it in order to preserve all attributes.
else
- Set_Etype (Id, New_Copy (Typ));
- Set_Scope (Etype (Id), Current_Scope);
+ declare
+ Typ : constant Entity_Id := New_Copy (Old_Typ);
+
+ begin
+ Set_Etype (Id, Typ);
+
+ -- Since we do not generate component declarations for
+ -- inherited components, associate the itype with the
+ -- derived type.
+
+ Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
+ Set_Scope (Typ, Derived_Base);
+ end;
end if;
end Set_Anonymous_Type;
projects / gcc.git / commitdiff