+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sinfo.ads: Minor reformatting.
+ * sem_aux.ads: Clarify use of First_Discriminant.
+ * sem_ch4.adb (Analyze_Explicit_Dereference): The use of a limited
+ view is replaced with the non-limited view in an instance body,
+ where the enclosing unit must have a regular with_clause on the
+ relevant unit.
+ * sem_ch12.adb (Install_Body): Freeze instantation after its
+ body. Remove useless freeze nodes for incomplete actuals to
+ prevent multiple generation of internal operations.
+ (Instantiate_Package_Body): Set sloc of body appropriately when
+ there are incomplete actuals and the instance body is placed in
+ the body of the enclosing unit.
+ * errout.ads: Consistent punctuation, better alignment and trivial
+ typos in comments.
+ * err_vars.ads: Fix typo.
+
+2015-05-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Lift restriction on
+ components of Volatile_Full_Access objects.
+
+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Is_Non_Overriding_Operation,
+ Get_Generic_Parent_Type): Handle properly the case of a derived
+ scalar type by using the first subtype rather than its generated
+ anonymous base type.
+
+2015-05-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.adb (Write_Field17_Name): Move E_Incomplete_Subtype
+ case to...
+ (Write_Field19_Name): ...here.
+
2015-05-26 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb: sem_ch13.adb (Add_Predicates): Undo analysis
when Modular_Integer_Kind =>
Write_Str ("Modulus");
- when E_Incomplete_Subtype =>
- if From_Limited_With (Id) then
- Write_Str ("Non_Limited_View");
- end if;
-
when E_Component =>
Write_Str ("Prival");
E_Incomplete_Type =>
Write_Str ("Non_Limited_View");
+ when E_Incomplete_Subtype =>
+ if From_Limited_With (Id) then
+ Write_Str ("Non_Limited_View");
+ end if;
+
when E_Array_Type =>
Write_Str ("Default_Component_Value");
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
Error_Msg_Qual_Level : Int := 0;
-- Number of levels of qualification required for type name (see the
-- description of the } insertion character. Note that this value does
- -- note get reset by any Error_Msg call, so the caller is responsible
+ -- not get reset by any Error_Msg call, so the caller is responsible
-- for resetting it.
Warn_On_Instance : Boolean := False;
------------------------------------------------------------------------------
-- This package contains the routines to output error messages. They are
--- basically system independent, however in some environments, e.g. when the
+-- basically system independent, however, in some environments, e.g. when the
-- parser is embedded into an editor, it may be appropriate to replace the
-- implementation of this package.
-- obtained from the Unit_Name_Type value in Error_Msg_Unit_1 and
-- Error_Msg_Unit_2, as provided by Get_Unit_Name_String in package
-- Uname. Note that this name includes the postfix (spec) or (body)
- -- strings. If this postfix is not required, use the normal %
- -- insertion for the unit name.
+ -- strings. If this postfix is not required, use the normal % insertion
+ -- for the unit name.
-- Insertion character { (Left brace: insert file name from names table)
-- The character { is treated similarly to %, except that the input
-- insertion is the exact string stored in the names table without
-- adjusting the casing.
- -- Insertion character * (Asterisk, insert reserved word name)
+ -- Insertion character * (Asterisk: insert reserved word name)
-- The insertion character * is treated exactly like % except that the
-- resulting name is cased according to the default conventions for
-- reserved words (see package Scans).
-- where appropriate the location of its declaration. Special cases
-- like "some integer type" are handled appropriately. Only one } is
-- allowed in a message, since there is not enough room for two (the
- -- insertion can be quite long, including a file name) In addition, if
+ -- insertion can be quite long, including a file name). In addition, if
-- the special global variable Error_Msg_Qual_Level is non-zero, then
-- the reference will include up to the given number of levels of
-- qualification, using the scope chain.
-- A second ^ may occur in the message, in which case it is replaced
-- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
- -- Insertion character > (Greater Than, run time name)
+ -- Insertion character > (Greater Than: run time name)
-- The character > is replaced by a string of the form (name) if
-- Targparm scanned out a Run_Time_Name (see package Targparm for
-- details). The name is enclosed in parentheses and output in mixed
-- messages are treated as a unit. The \ character must be the first
-- character of the message text.
- -- Insertion character \\ (Two backslashes, continuation with new line)
+ -- Insertion character \\ (Two backslashes: continuation with new line)
-- This differs from \ only in -gnatjnn mode (Error_Message_Line_Length
-- set non-zero). This sequence forces a new line to start even when
-- continuations are being gathered into a single message.
Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level;
-- Number of levels of qualification required for type name (see the
-- description of the } insertion character). Note that this value does
- -- note get reset by any Error_Msg call, so the caller is responsible
+ -- not get reset by any Error_Msg call, so the caller is responsible
-- for resetting it.
Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn;
-- First_Entity. The exception arises for tagged types, where the tag
-- itself is prepended to the front of the entity chain, so the
-- First_Discriminant function steps past the tag if it is present.
+ -- The caller is responsible for checking that the type has discriminants,
+ -- so for example it is improper to call this function on a private
+ -- type with unknown discriminants.
function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id;
-- Typ is a type with discriminants. Gives the first discriminant stored
-- in the instance body requires the presence of a regular with_clause
-- in the enclosing unit, and will fail if this with_clause is missing.
-- We place the instance body at the beginning of the enclosing body,
- -- which is the unit being compiled, and ensure that freeze nodes for
- -- the full views of the incomplete types appear before the instance.
+ -- which is the unit being compiled. The freeze node for the instance
+ -- is then placed after the instance body.
if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id))
and then Expander_Active
Ensure_Freeze_Node (Act_Id);
F_Node := Freeze_Node (Act_Id);
if Present (Body_Id) then
- Set_Is_Frozen (Act_Id);
+ Set_Is_Frozen (Act_Id, False);
Prepend (Act_Body, Declarations (Parent (Body_Id)));
- end if;
-
- -- Add freeze nodes of formerly incomplete types ahead of
- -- the instance body.
-
- declare
- Elmt : Elmt_Id;
- F_T : Node_Id;
- Typ : Entity_Id;
-
- begin
- Elmt := First_Elmt (Incomplete_Actuals (Act_Id));
- while Present (Elmt) loop
- Typ := Node (Elmt);
-
- if From_Limited_With (Typ) then
- Typ := Non_Limited_View (Typ);
- end if;
-
- Ensure_Freeze_Node (Typ);
- F_T := Freeze_Node (Typ);
-
- -- If freeze node is already in the tree, remove it
- -- and place ahead of instance body.
-
- if Is_List_Member (F_T) then
- Remove (F_T);
- end if;
+ if Is_List_Member (F_Node) then
+ Remove (F_Node);
+ end if;
- Prepend (F_T, Declarations (Parent (Body_Id)));
- Next_Elmt (Elmt);
- end loop;
- end;
+ Insert_After (Act_Body, F_Node);
+ end if;
end;
-
return;
end if;
end if;
-- Establish global variable for sloc adjustment and for error recovery
+ -- In the case of an instance body for an instantiation with actuals
+ -- from a limited view, the instance body is placed at the beginning
+ -- of the enclosing package body: use the body entity as the source
+ -- location for nodes of the instance body.
- Instantiation_Node := Inst_Node;
+ if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then
+ declare
+ Scop : constant Entity_Id := Scope (Act_Decl_Id);
+ Body_Id : constant Node_Id :=
+ Corresponding_Body (Unit_Declaration_Node (Scop));
+
+ begin
+ Instantiation_Node := Body_Id;
+ end;
+ else
+ Instantiation_Node := Inst_Node;
+ end if;
if Present (Gen_Body_Id) then
Save_Env (Gen_Unit, Act_Decl_Id);
-- An explicit dereference is a legal occurrence of an
-- incomplete type imported through a limited_with clause,
- -- if the full view is visible.
+ -- if the full view is visible, or if we are within an
+ -- instance body, where the enclosing body has a regular
+ -- with_clause on the unit.
if From_Limited_With (DT)
and then not From_Limited_With (Scope (DT))
(Is_Immediately_Visible (Scope (DT))
or else
(Is_Child_Unit (Scope (DT))
- and then Is_Visible_Lib_Unit (Scope (DT))))
+ and then Is_Visible_Lib_Unit (Scope (DT)))
+ or else In_Instance_Body)
then
Set_Etype (N, Available_View (DT));
-- is needed for cases where a full derived type has been
-- rewritten.)
- Defn := Type_Definition (Original_Node (Parent (F_Typ)));
+ -- If the parent type is a scalar type, the derivation creates
+ -- an anonymous base type for it, and the source type is its
+ -- first subtype.
+
+ if Is_Scalar_Type (F_Typ)
+ and then not Comes_From_Source (F_Typ)
+ then
+ Defn :=
+ Type_Definition
+ (Original_Node (Parent (First_Subtype (F_Typ))));
+ else
+ Defn := Type_Definition (Original_Node (Parent (F_Typ)));
+ end if;
if Nkind (Defn) = N_Derived_Type_Definition then
Indic := Subtype_Indication (Defn);
("renaming of conversion only allowed for tagged types", Nam);
end if;
- -- Reject renaming of component of Volatile_Full_Access object
-
- if Nkind_In (Nam, N_Selected_Component, N_Indexed_Component) then
- declare
- P : constant Node_Id := Prefix (Nam);
- begin
- if Is_Entity_Name (P) then
- if Is_Volatile_Full_Access (Entity (P))
- or else
- Is_Volatile_Full_Access (Etype (P))
- then
- Error_Msg_N
- ("cannot rename component of Volatile_Full_Access "
- & "object", Nam);
- end if;
- end if;
- end;
- end if;
-
Resolve (Nam, T);
-- If the renamed object is a function call of a limited type,
-- Acts_As_Spec (Flag4-Sem)
-- A flag set in the N_Subprogram_Body node for a subprogram body which
- -- is acting as its own spec, except in the case of a library level
- -- subprogram, in which case the flag is set on the parent compilation
- -- unit node instead.
+ -- is acting as its own spec. In the case of a library-level subprogram
+ -- the flag is set as well on the parent compilation unit node.
-- Actual_Designated_Subtype (Node4-Sem)
-- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi
projects / gcc.git / commitdiff