+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * sem_ch4.adb (Complete_Object_Operation): Do not insert 'Access for
+ reference types in the access-to-access case.
+
+2017-09-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_attr.adb (Analyze_Access_Attribute): Move check for the presence
+ of the "aliased" keyword on the prefix from here to...
+ (Resolve_Attribute) <Attribute_Access>: ...here. Remove useless call
+ to Check_No_Implicit_Aliasing.
+ * sinfo.ads (Non_Aliased_Prefix): Delete.
+ (Set_Non_Aliased_Prefix): Likewise.
+ * sinfo.adb (Non_Aliased_Prefix): Delete.
+ (Set_Non_Aliased_Prefix): Likewise.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * exp_ch5.adb (Build_Formal_Container_Iteration,
+ Expand_Formal_Container_Element_Loop): Convert the container to the
+ root type before passing it to the iteration operations, so it will be
+ of the right type.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * einfo.ads, validsw.ads, treepr.ads, sem_util.ads: Comment fixes.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Build_Array_Init_Proc): If validity checking is enabled,
+ and it's a bit-packed array, pass False to the Consider_IS parameter of
+ Needs_Simple_Initialization.
+
+2017-09-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Check_Inline_Pragma): Link the newly generated spec to
+ the preexisting body.
+ * sem_prag.adb (Check_Inline_Always_Placement): New routine.
+ (Process_Inline): Verify the placement of pragma Inline_Always. The
+ pragma must now appear on the initial declaration of the related
+ subprogram.
+
+2017-09-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): In ASIS mode, At the end of the
+ declarative list in a subprogram body, analyze aspext specifications to
+ provide basic semantic information, because otherwise the aspect
+ specifications might only be snalyzed during expansion, when related
+ subprograms are generated.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * exp_ch9.adb (Is_Simple_Barrier_Name): Follow Original_Node, in case
+ validity checks have rewritten the tree.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * sem_util.adb: Comment fixes, and remove redundant Is_Itype check.
+
+2017-09-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Save_References_In_Aggregate): When constructing a
+ qualified exxpression for an aggregate in a generic unit, verify that
+ the scope of the type is itself visible and not hidden, so that the
+ qualified expression is correctly resolved in any instance.
+
2017-09-18 Bob Duff <duff@adacore.com>
* sem_ch4.adb (Analyze_Qualified_Expression): Give an error if the type
-- only]. These are representation attributes which must always apply to a
-- full non-private type, and where the attributes are always on the full
-- type. The attribute can be referenced on a subtype (and automatically
--- retries the value from the implementation base type). However, it is an
+-- retrieves the value from the implementation base type). However, it is an
-- error to try to set the attribute on other than the implementation base
-- type, and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
Comp_Type : constant Entity_Id := Component_Type (A_Type);
+ Comp_Type_Simple : constant Boolean :=
+ Needs_Simple_Initialization
+ (Comp_Type, Consider_IS =>
+ not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type)));
Body_Stmts : List_Id;
Has_Default_Init : Boolean;
Index_List : List_Id;
Convert_To (Comp_Type,
Default_Aspect_Component_Value (First_Subtype (A_Type)))));
- elsif Needs_Simple_Initialization (Comp_Type) then
+ elsif Comp_Type_Simple then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
-- the dummy Init_Proc needed for Initialize_Scalars processing.
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
- and then not Needs_Simple_Initialization (Comp_Type)
+ and then not Comp_Type_Simple
and then not Has_Task (Comp_Type)
and then not Has_Default_Aspect (A_Type)
then
-- init_proc.
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
- or else Needs_Simple_Initialization (Comp_Type)
+ or else Comp_Type_Simple
or else Has_Task (Comp_Type)
or else Has_Default_Aspect (A_Type);
-- Utility to create declarations and loop statement for both forms
-- of formal container iterators.
+ function Convert_To_Iterable_Type
+ (Container : Entity_Id; Loc : Source_Ptr) return Node_Id;
+ -- Returns New_Occurrence_Of (Container), possibly converted to an
+ -- ancestor type, if the type of Container inherited the Iterable
+ -- aspect_specification from that ancestor.
+
function Change_Of_Representation (N : Node_Id) return Boolean;
-- Determine if the right-hand side of assignment N is a type conversion
-- which requires a change of representation. Called only for the array
Make_Function_Call (Loc,
Name => New_Occurrence_Of (First_Op, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Container, Loc))));
+ Convert_To_Iterable_Type (Container, Loc))));
-- Statement that advances cursor in loop
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Next_Op, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Container, Loc),
+ Convert_To_Iterable_Type (Container, Loc),
New_Occurrence_Of (Cursor, Loc))));
-- Iterator is rewritten as a while_loop
Make_Iteration_Scheme (Loc,
Condition =>
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Has_Element_Op, Loc),
+ Name => New_Occurrence_Of (Has_Element_Op, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Container, Loc),
+ Convert_To_Iterable_Type (Container, Loc),
New_Occurrence_Of (Cursor, Loc)))),
- Statements => Stats,
- End_Label => Empty);
+ Statements => Stats,
+ End_Label => Empty);
end Build_Formal_Container_Iteration;
------------------------------
not Same_Representation (Etype (Rhs), Etype (Expression (Rhs)));
end Change_Of_Representation;
+ ------------------------------
+ -- Convert_To_Iterable_Type --
+ ------------------------------
+
+ function Convert_To_Iterable_Type
+ (Container : Entity_Id; Loc : Source_Ptr) return Node_Id
+ is
+ Typ : constant Entity_Id := Base_Type (Etype (Container));
+ Aspect : constant Node_Id := Find_Aspect (Typ, Aspect_Iterable);
+ Result : Node_Id := New_Occurrence_Of (Container, Loc);
+ begin
+ if Entity (Aspect) /= Typ then
+ Result := Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Entity (Aspect), Loc),
+ Expression => Result);
+ end if;
+
+ return Result;
+ end Convert_To_Iterable_Type;
+
-------------------------
-- Expand_Assign_Array --
-------------------------
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Element_Op, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Container, Loc),
+ Convert_To_Iterable_Type (Container, Loc),
New_Occurrence_Of (Cursor, Loc))));
Set_Statements (New_Loop,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Element_Op, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Container, Loc),
+ Convert_To_Iterable_Type (Container, Loc),
New_Occurrence_Of (Cursor, Loc))));
Prepend (Elmt_Ref, Stats);
begin
-- Check if the name is a component of the protected object. If
- -- the expander is active, the component has been transformed into
- -- a renaming of _object.all.component.
+ -- the expander is active, the component has been transformed into a
+ -- renaming of _object.all.component. Original_Node is needed in case
+ -- validity checking is enabled, in which case the simple object
+ -- reference will have been rewritten.
if Expander_Active then
- Renamed := Renamed_Object (Entity (N));
+ Renamed := Renamed_Object (Entity (Original_Node (N)));
return
Present (Renamed)
end if;
end loop;
end;
-
- -- Check for aliased view. We allow a nonaliased prefix when within
- -- an instance because the prefix may have been a tagged formal
- -- object, which is defined to be aliased even when the actual
- -- might not be (other instance cases will have been caught in the
- -- generic). Similarly, within an inlined body we know that the
- -- attribute is legal in the original subprogram, and therefore
- -- legal in the expansion.
-
- if not Is_Aliased_View (P)
- and then not In_Instance
- and then not In_Inlined_Body
- and then Comes_From_Source (N)
- then
- -- Here we have a non-aliased view. This is illegal unless we
- -- have the case of Unrestricted_Access, where for now we allow
- -- this (we will reject later if expected type is access to an
- -- unconstrained array with a thin pointer).
-
- -- No need for an error message on a generated access reference
- -- for the controlling argument in a dispatching call: error will
- -- be reported when resolving the call.
-
- if Aname /= Name_Unrestricted_Access then
- Error_Attr_P ("prefix of % attribute must be aliased");
- Check_No_Implicit_Aliasing (P);
-
- -- For Unrestricted_Access, record that prefix is not aliased
- -- to simplify legality check later on.
-
- else
- Set_Non_Aliased_Prefix (N);
- end if;
-
- -- If we have an aliased view, and we have Unrestricted_Access, then
- -- output a warning that Unchecked_Access would have been fine, and
- -- change the node to be Unchecked_Access.
-
- else
- -- For now, hold off on this change ???
-
- null;
- end if;
end Analyze_Access_Attribute;
----------------------------------
end if;
end if;
- -- Check for unrestricted access where expected type is a thin
- -- pointer to an unconstrained array.
-
- if Non_Aliased_Prefix (N)
- and then Has_Size_Clause (Typ)
- and then RM_Size (Typ) = System_Address_Size
+ -- Check for aliased view. We allow a nonaliased prefix when in
+ -- an instance because the prefix may have been a tagged formal
+ -- object, which is defined to be aliased even when the actual
+ -- might not be (other instance cases will have been caught in
+ -- the generic). Similarly, within an inlined body we know that
+ -- the attribute is legal in the original subprogram, therefore
+ -- legal in the expansion.
+
+ if not (Is_Entity_Name (P)
+ and then Is_Overloadable (Entity (P)))
+ and then not (Nkind (P) = N_Selected_Component
+ and then
+ Is_Overloadable (Entity (Selector_Name (P))))
+ and then not Is_Aliased_View (P)
+ and then not In_Instance
+ and then not In_Inlined_Body
+ and then Comes_From_Source (N)
then
- declare
- DT : constant Entity_Id := Designated_Type (Typ);
- begin
- if Is_Array_Type (DT) and then not Is_Constrained (DT) then
- Error_Msg_N
- ("illegal use of Unrestricted_Access attribute", P);
- Error_Msg_N
- ("\attempt to generate thin pointer to unaliased "
- & "object", P);
- end if;
- end;
+ -- Here we have a non-aliased view. This is illegal unless we
+ -- have the case of Unrestricted_Access, where for now we allow
+ -- this (we will reject later if expected type is access to an
+ -- unconstrained array with a thin pointer).
+
+ -- No need for an error message on a generated access reference
+ -- for the controlling argument in a dispatching call: error
+ -- will be reported when resolving the call.
+
+ if Attr_Id /= Attribute_Unrestricted_Access then
+ Error_Msg_N ("prefix of % attribute must be aliased", P);
+
+ -- Check for unrestricted access where expected type is a thin
+ -- pointer to an unconstrained array.
+
+ elsif Has_Size_Clause (Typ)
+ and then RM_Size (Typ) = System_Address_Size
+ then
+ declare
+ DT : constant Entity_Id := Designated_Type (Typ);
+ begin
+ if Is_Array_Type (DT)
+ and then not Is_Constrained (DT)
+ then
+ Error_Msg_N
+ ("illegal use of Unrestricted_Access attribute", P);
+ Error_Msg_N
+ ("\attempt to generate thin pointer to unaliased "
+ & "object", P);
+ end if;
+ end;
+ end if;
end if;
-- Mark that address of entity is taken in case of
-- preserved. In order to preserve some of this information,
-- wrap the aggregate in a qualified expression, using the id
-- of its type. For further disambiguation we qualify the type
- -- name with its scope (if visible) because both id's will have
- -- corresponding entities in an instance. This resolves most of
- -- the problems with missing type information on aggregates in
- -- instances.
+ -- name with its scope (if visible and not hidden by a local
+ -- homograph) because both id's will have corresponding
+ -- entities in an instance. This resolves most of the problems
+ -- with missing type information on aggregates in instances.
if Present (N2)
and then Nkind (N2) = Nkind (N)
then
Nam := Make_Identifier (Loc, Chars (Typ));
- if Is_Immediately_Visible (Scope (Typ)) then
+ if Is_Immediately_Visible (Scope (Typ))
+ and then Current_Entity (Scope (Typ)) = Scope (Typ)
+ then
Nam :=
Make_Selected_Component (Loc,
Prefix =>
Freeze_From := Last_Entity (Current_Scope);
else
+ -- For declarations in a subprogram body there is no issue
+ -- with name resolution in aspect specifications, but in
+ -- ASIS mode we need to preanalyze aspect specifications
+ -- that may otherwise only be analyzed during expansion
+ -- (e.g. during generation of a related subprogram).
+
+ if ASIS_Mode then
+ Resolve_Aspects;
+ end if;
+
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
end if;
end if;
Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent));
Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
Set_Corresponding_Record_Type (Def_Id,
("expect variable in call to&", Prefix (N), Entity (Subprog));
end if;
- -- Conversely, if the formal is an access parameter and the object
- -- is not, replace the actual with a 'Access reference. Its analysis
- -- will check that the object is aliased.
+ -- Conversely, if the formal is an access parameter and the object is
+ -- not an access type or a reference type (i.e. a type with the
+ -- Implicit_Dereference aspect specified), replace the actual with a
+ -- 'Access reference. Its analysis will check that the object is
+ -- aliased.
elsif Is_Access_Type (Formal_Type)
and then not Is_Access_Type (Etype (Obj))
+ and then (not Has_Implicit_Dereference (Etype (Obj))
+ or else
+ not Is_Access_Type
+ (Designated_Type
+ (Etype (Get_Reference_Discriminant (Etype (Obj))))))
then
- -- A special case: A.all'access is illegal if A is an access to a
+ -- A special case: A.all'Access is illegal if A is an access to a
-- constant and the context requires an access to a variable.
if not Is_Access_Constant (Formal_Type) then
New_Copy_Tree (Specification (N)));
begin
+ -- Link the body and the generated spec
+
+ Set_Corresponding_Body (Decl, Body_Id);
+ Set_Corresponding_Spec (N, Subp);
+
Set_Defining_Unit_Name (Specification (Decl), Subp);
-- To ensure proper coverage when body is inlined, indicate
-- The entity of the first Ghost subprogram encountered while
-- processing the arguments of the pragma.
- procedure Make_Inline (Subp : Entity_Id);
- -- Subp is the defining unit name of the subprogram declaration. If
- -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
- -- the corresponding body, if there is one present.
-
- procedure Set_Inline_Flags (Subp : Entity_Id);
- -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
- -- Also set or clear Is_Inlined flag on Subp depending on Status.
+ procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
+ -- Verify the placement of pragma Inline_Always with respect to the
+ -- initial declaration of subprogram Spec_Id.
function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
-- Returns True if it can be determined at this stage that inlining
-- ??? is business with link symbols still valid, or does it relate
-- to front end ZCX which is being phased out ???
+ procedure Make_Inline (Subp : Entity_Id);
+ -- Subp is the defining unit name of the subprogram declaration. If
+ -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
+ -- the corresponding body, if there is one present.
+
+ procedure Set_Inline_Flags (Subp : Entity_Id);
+ -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
+ -- Also set or clear Is_Inlined flag on Subp depending on Status.
+
+ -----------------------------------
+ -- Check_Inline_Always_Placement --
+ -----------------------------------
+
+ procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
+ Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
+
+ function Compilation_Unit_OK return Boolean;
+ pragma Inline (Compilation_Unit_OK);
+ -- Determine whether pragma Inline_Always applies to a compatible
+ -- compilation unit denoted by Spec_Id.
+
+ function Declarative_List_OK return Boolean;
+ pragma Inline (Declarative_List_OK);
+ -- Determine whether the initial declaration of subprogram Spec_Id
+ -- and the pragma appear in compatible declarative lists.
+
+ function Subprogram_Body_OK return Boolean;
+ pragma Inline (Subprogram_Body_OK);
+ -- Determine whether pragma Inline_Always applies to a compatible
+ -- subprogram body denoted by Spec_Id.
+
+ -------------------------
+ -- Compilation_Unit_OK --
+ -------------------------
+
+ function Compilation_Unit_OK return Boolean is
+ Comp_Unit : constant Node_Id := Parent (Spec_Decl);
+
+ begin
+ -- The pragma appears after the initial declaration of a
+ -- compilation unit.
+
+ -- procedure Comp_Unit;
+ -- pragma Inline_Always (Comp_Unit);
+
+ -- Note that for compatibility reasons, the following case is
+ -- also accepted.
+
+ -- procedure Stand_Alone_Body_Comp_Unit is
+ -- ...
+ -- end Stand_Alone_Body_Comp_Unit;
+ -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
+
+ return
+ Nkind (Comp_Unit) = N_Compilation_Unit
+ and then Present (Aux_Decls_Node (Comp_Unit))
+ and then Is_List_Member (N)
+ and then List_Containing (N) =
+ Pragmas_After (Aux_Decls_Node (Comp_Unit));
+ end Compilation_Unit_OK;
+
+ -------------------------
+ -- Declarative_List_OK --
+ -------------------------
+
+ function Declarative_List_OK return Boolean is
+ Context : constant Node_Id := Parent (Spec_Decl);
+
+ Init_Decl : Node_Id;
+ Init_List : List_Id;
+ Prag_List : List_Id;
+
+ begin
+ -- Determine the proper initial declaration. In general this is
+ -- the declaration node of the subprogram except when the input
+ -- denotes a generic instantiation.
+
+ -- procedure Inst is new Gen;
+ -- pragma Inline_Always (Inst);
+
+ -- In this case the original subprogram is moved inside an
+ -- anonymous package while pragma Inline_Always remains at the
+ -- level of the anonymous package. Use the declaration of the
+ -- package because it reflects the placement of the original
+ -- instantiation.
+
+ -- package Anon_Pack is
+ -- procedure Inst is ... end Inst; -- original
+ -- end Anon_Pack;
+
+ -- procedure Inst renames Anon_Pack.Inst;
+ -- pragma Inline_Always (Inst);
+
+ if Is_Generic_Instance (Spec_Id) then
+ Init_Decl := Parent (Parent (Spec_Decl));
+ pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
+ else
+ Init_Decl := Spec_Decl;
+ end if;
+
+ if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
+ Init_List := List_Containing (Init_Decl);
+ Prag_List := List_Containing (N);
+
+ -- The pragma and then initial declaration appear within the
+ -- same declarative list.
+
+ if Init_List = Prag_List then
+ return True;
+
+ -- A special case of the above is when both the pragma and
+ -- the initial declaration appear in different lists of a
+ -- package spec, protected definition, or a task definition.
+
+ -- package Pack is
+ -- procedure Proc;
+ -- private
+ -- pragma Inline_Always (Proc);
+ -- end Pack;
+
+ elsif Nkind_In (Context, N_Package_Specification,
+ N_Protected_Definition,
+ N_Task_Definition)
+ and then Init_List = Visible_Declarations (Context)
+ and then Prag_List = Private_Declarations (Context)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Declarative_List_OK;
+
+ ------------------------
+ -- Subprogram_Body_OK --
+ ------------------------
+
+ function Subprogram_Body_OK return Boolean is
+ Body_Decl : Node_Id;
+
+ begin
+ -- The pragma appears within the declarative list of a stand-
+ -- alone subprogram body.
+
+ -- procedure Stand_Alone_Body is
+ -- pragma Inline_Always (Stand_Alone_Body);
+ -- begin
+ -- ...
+ -- end Stand_Alone_Body;
+
+ -- The compiler creates a dummy spec in this case, however the
+ -- pragma remains within the declarative list of the body.
+
+ if Nkind (Spec_Decl) = N_Subprogram_Declaration
+ and then not Comes_From_Source (Spec_Decl)
+ and then Present (Corresponding_Body (Spec_Decl))
+ then
+ Body_Decl :=
+ Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
+
+ if Present (Declarations (Body_Decl))
+ and then Is_List_Member (N)
+ and then List_Containing (N) = Declarations (Body_Decl)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Subprogram_Body_OK;
+
+ -- Start of processing for Check_Inline_Always_Placement
+
+ begin
+ -- This check is relevant only for pragma Inline_Always
+
+ if Pname /= Name_Inline_Always then
+ return;
+
+ -- Nothing to do when the pragma is internally generated on the
+ -- assumption that it is properly placed.
+
+ elsif not Comes_From_Source (N) then
+ return;
+
+ -- Nothing to do for internally generated subprograms that act
+ -- as accidental homonyms of a source subprogram being inlined.
+
+ elsif not Comes_From_Source (Spec_Id) then
+ return;
+
+ -- Nothing to do for generic formal subprograms that act as
+ -- homonyms of another source subprogram being inlined.
+
+ elsif Is_Formal_Subprogram (Spec_Id) then
+ return;
+
+ elsif Compilation_Unit_OK
+ or else Declarative_List_OK
+ or else Subprogram_Body_OK
+ then
+ return;
+ end if;
+
+ -- At this point it is known that the pragma applies to or appears
+ -- within a completing body, a completing stub, or a subunit.
+
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_Name_2 := Chars (Spec_Id);
+ Error_Msg_Sloc := Sloc (Spec_Id);
+
+ Error_Msg_N
+ ("pragma % must appear on initial declaration of subprogram "
+ & "% defined #", N);
+ end Check_Inline_Always_Placement;
+
---------------------------
-- Inlining_Not_Possible --
---------------------------
-- retrieve it as the alias of the visible subprogram instance.
if Is_Subprogram (Subp) then
+
+ -- Ensure that pragma Inline_Always is associated with the
+ -- initial declaration of the subprogram.
+
+ Check_Inline_Always_Placement (Subp);
+
if Is_Wrapper_Package (Scope (Subp)) then
Inner_Subp := Subp;
else
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
then
Id := Defining_Entity (Context);
- -- Pragma Ghost applies to a stand alone subprogram body
+ -- Pragma Ghost applies to a stand-alone subprogram body
elsif Nkind (Context) = N_Subprogram_Body
and then No (Corresponding_Spec (Context))
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
-- related subprogram [body] when it is:
-- aspect on subprogram declaration
- -- aspect on stand alone subprogram body
- -- pragma on stand alone subprogram body
+ -- aspect on stand-alone subprogram body
+ -- pragma on stand-alone subprogram body
-- The annotation must prepare its own template when it is:
if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
- -- A stand alone subprogram body
+ -- A stand-alone subprogram body
if Body_Id = Spec_Id then
Check_Pragma_Conformance
Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
- -- Subprogram declaration or stand alone body case, look for pragmas
+ -- Subprogram declaration or stand-alone body case, look for pragmas
-- Depends and Global
else
end if;
end if;
- -- If E is an object or component, and the type of E is an anonymous
- -- access type with no convention set, then also set the convention of
- -- the anonymous access type. We do not do this for anonymous protected
- -- types, since protected types always have the default convention.
+ -- If E is an object, including a component, and the type of E is an
+ -- anonymous access type with no convention set, then also set the
+ -- convention of the anonymous access type. We do not do this for
+ -- anonymous protected types, since protected types always have the
+ -- default convention.
if Present (Etype (E))
and then (Is_Object (E)
- or else Ekind (E) = E_Component
-- Allow E_Void (happens for pragma Convention appearing
-- in the middle of a record applying to a component)
Set_Has_Convention_Pragma (Typ);
-- And for the access subprogram type, deal similarly with the
- -- designated E_Subprogram_Type if it is also internal (which
- -- it always is?)
+ -- designated E_Subprogram_Type, which is always internal.
if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
declare
Dtype : constant Entity_Id := Designated_Type (Typ);
begin
if Ekind (Dtype) = E_Subprogram_Type
- and then Is_Itype (Dtype)
and then not Has_Convention_Pragma (Dtype)
then
Basic_Set_Convention (Dtype, Val);
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
-- Retrieve one of the primitives First, Next, Has_Element, Element from
- -- the value of the Iterable aspect of a formal type.
+ -- the value of the Iterable aspect of a type.
procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id);
-- Retrieve the fully expanded name of the library unit declared by
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
return Flag17 (N);
end No_Truncation;
- function Non_Aliased_Prefix
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Flag18 (N);
- end Non_Aliased_Prefix;
-
function Null_Excluding_Subtype
(N : Node_Id) return Boolean is
begin
Set_Flag17 (N, Val);
end Set_No_Truncation;
- procedure Set_Non_Aliased_Prefix
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Flag18 (N, Val);
- end Set_Non_Aliased_Prefix;
-
procedure Set_Null_Excluding_Subtype
(N : Node_Id; Val : Boolean := True) is
begin
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
- -- Non_Aliased_Prefix (Flag18-Sem)
- -- Present in N_Attribute_Reference nodes. Set only for the case of an
- -- Unrestricted_Access reference whose prefix is non-aliased, which is
- -- the case that is permitted for Unrestricted_Access except when the
- -- expected type is a thin pointer to unconstrained array. This flag is
- -- to assist in detecting this illegal use of Unrestricted_Access.
-
-- Null_Excluding_Subtype (Flag16)
-- Present in N_Access_To_Object_Definition. Indicates that the subtype
-- indication carries a null-exclusion indicator, which is distinct from
-- Do_Overflow_Check (Flag17-Sem)
-- Header_Size_Added (Flag11-Sem)
-- Must_Be_Byte_Aligned (Flag14-Sem)
- -- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-- plus fields for expression
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
- function Non_Aliased_Prefix
- (N : Node_Id) return Boolean; -- Flag18
-
function Null_Excluding_Subtype
(N : Node_Id) return Boolean; -- Flag16
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
- procedure Set_Non_Aliased_Prefix
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
procedure Set_Null_Excluding_Subtype
(N : Node_Id; Val : Boolean := True); -- Flag16
pragma Inline (No_Minimize_Eliminate);
pragma Inline (No_Side_Effect_Removal);
pragma Inline (No_Truncation);
- pragma Inline (Non_Aliased_Prefix);
pragma Inline (Null_Excluding_Subtype);
pragma Inline (Null_Exclusion_Present);
pragma Inline (Null_Exclusion_In_Return_Present);
pragma Inline (Set_No_Minimize_Eliminate);
pragma Inline (Set_No_Side_Effect_Removal);
pragma Inline (Set_No_Truncation);
- pragma Inline (Set_Non_Aliased_Prefix);
pragma Inline (Set_Null_Excluding_Subtype);
pragma Inline (Set_Null_Exclusion_Present);
pragma Inline (Set_Null_Exclusion_In_Return_Present);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- of the nodes in the list
procedure Print_Node_Subtree (N : Node_Id);
- -- Prints the subtree routed at a specified tree node, including all
+ -- Prints the subtree rooted at a specified tree node, including all
-- referenced descendants.
procedure Print_List_Subtree (L : List_Id);
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2017, 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- --
Validity_Check_Default : Boolean := True;
-- Controls default (reference manual) validity checking. If this switch is
- -- set to True using -gnatVd or a 'd' in the argument of a Validity_ Checks
+ -- set to True using -gnatVd or a 'd' in the argument of a Validity_Checks
-- pragma (or the initial default value is used, set True), then left side
-- subscripts and case statement arguments are checked for validity. This
-- switch is also set by default if no -gnatV switch is used and no
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * gnat.dg/validity_check.adb: New testcase.
+
+2017-09-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat.dg/overload.ads, gnat.dg/overload.adb: New testcase.
+
+2017-09-18 Bob Duff <duff@adacore.com>
+
+ * gnat.dg/tagged_prefix_call.adb: New testcase.
+
2017-09-18 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/default_variants.adb: New testcase.
--- /dev/null
+-- { dg-do compile }
+
+package body Overload is
+
+ function Get (I : Integer) return Ptr1 is
+ P : Ptr1 := null;
+ begin
+ return P;
+ end;
+
+ function Get (I : Integer) return Ptr2 is
+ P : Ptr2 := null;
+ begin
+ return P;
+ end;
+
+ function F (I : Integer) return Ptr1 is
+ P : Ptr1 := Get (I).Data'Access;
+ begin
+ return P;
+ end;
+
+end Overload;
--- /dev/null
+package Overload is
+
+ type Rec1 is record
+ Data : Integer;
+ end record;
+ type Ptr1 is access all Rec1;
+
+ type Rec2 is record
+ Data : aliased Rec1;
+ end record;
+
+ type Ptr2 is access Rec2;
+
+ function Get (I : Integer) return Ptr1;
+
+ function Get (I : Integer) return Ptr2;
+
+ function F (I : Integer) return Ptr1;
+
+end Overload;
--- /dev/null
+-- { dg-do compile }
+
+procedure Tagged_Prefix_Call is
+
+ package Defs is
+ type Database_Connection_Record is abstract tagged null record;
+ type Database_Connection is access all Database_Connection_Record'Class;
+
+ procedure Start_Transaction
+ (Self : not null access Database_Connection_Record'Class)
+ is null;
+
+ type DB_Connection (Elem : access Database_Connection)
+ is null record
+ with Implicit_Dereference => Elem;
+ end Defs;
+
+ use Defs;
+
+ DB : DB_Connection(null);
+
+begin
+ DB.Start_Transaction;
+end Tagged_Prefix_Call;
--- /dev/null
+-- { dg-do run }
+-- { dg-options "-cargs -O -gnatn -gnatVa -gnatws -margs" }
+
+pragma Initialize_Scalars;
+
+procedure Validity_Check is
+
+ type Small_Int is mod 2**6;
+
+ type Arr is array (1 .. 16) of Small_Int;
+ pragma Pack (Arr);
+
+ S : Small_Int;
+ A : Arr;
+
+begin
+ null;
+end;
projects / gcc.git / commitdiff