+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem.adb (Analyze): Diagnose an illegal iterated component
+ association.
+ * sem_util.ads, sem_util.adb
+ (Diagnose_Iterated_Component_Association): New routine.
+
+2017-04-27 Bob Duff <duff@adacore.com>
+
+ * adaint.c (__gnat_get_current_dir): Return 0 in length if
+ getcwd fails.
+ * a-direct.adb, g-dirope.adb, osint.adb, s-os_lib.adb: Raise
+ exception if getcwd failed.
+
+2017-04-27 Yannick Moy <moy@adacore.com>
+
+ * exp_dbug.adb, exp_dbug.ads (Get_External_Name): Prefix ghost
+ entities with special prefix.
+
+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * debug.adb Change the documentation of switch -gnatd.s.
+ * exp_ch7.adb (Make_Transient_Block): Transient blocks do not need
+ to manage the secondary stack when an enclosing scope already
+ performs this functionality (aka relaxed management). Switch
+ -gnatd.s may be used to force strict management in which case
+ the block will manage the secondary stack unconditionally. Add
+ a guard to stop the traversal when encountering a package or a
+ subprogram scope.
+
+2017-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Call): Refine further the handling of
+ limited views of return types in function calls. If the function
+ that returns a limited view appears in the current unit,
+ we do not replace its type by the non-limited view because
+ this transformation is performed int the back-end. However,
+ the type of the call itself must be the non-limited view, to
+ prevent spurious resolution errors.
+
+2017-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo,ads, einfo.adb (Class_Wide_Preconds, Class_Wide_Postconds):
+ Removed, proposed implementation using generics for class-wide
+ preconditions proved impractical.
+ (Class_Wide_Clone): New attribute of subprogram. Designates
+ subprogram created for primitive operations with class-wide
+ pre/postconditions that contain calls to other primitives. The
+ clone holds the body of the original primitive, but the
+ pre/postonditions do not apply to it. The original body is
+ rewritten as a wrapper for a call to the clone.
+ (Is_Class_Wide_Clone): New flag to identify a Class_Wide_Clone. If
+ the flag is set, no code for the corresponding pre/postconditions
+ is inserted into its body.
+
+2017-04-27 Bob Duff <duff@adacore.com>
+
+ * exp_prag.adb, par-prag.adb, sem_ch13.adb: Ignore
+ Scalar_Storage_Order if -gnatI is given.
+ * sem_prag.adb (Analyze_Pragma): Ignore
+ Default_Scalar_Storage_Order if -gnatI is given.
+
2017-04-27 Claire Dross <dross@adacore.com>
* a-cofuba.ads (Add): Take as an additional input parameter
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
+ if Path_Len = 0 then
+ raise Use_Error with "current directory does not exist";
+ end if;
+
-- We need to resolve links because of RM A.16(47), which requires
-- that we not return alternative names for files.
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2015, 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- *
WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
#else
- getcwd (dir, *length);
+ char* result = getcwd (dir, *length);
+ /* If the current directory does not exist, set length = 0
+ to indicate error. That can't happen on windows, where
+ you can't delete a directory if it is the current
+ directory of some process. */
+ if (!result)
+ {
+ *length = 0;
+ return;
+ }
#endif
*length = strlen (dir);
-- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133)
-- d.q Suppress optimizations on imported 'in'
-- d.r Enable OK_To_Reorder_Components in non-variant records
- -- d.s Minimize secondary stack Mark and Release calls
+ -- d.s Strict secondary stack management
-- d.t Disable static allocation of library level dispatch tables
-- d.u Enable Modify_Tree_For_C (update tree for c)
-- d.v Enable OK_To_Reorder_Components in variant records
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
+ -- d.s The compiler no longer attempts to optimize the calls to secondary
+ -- stack management routines SS_Mark and SS_Release. As a result, each
+ -- transient block tasked with secondary stack management will fulfill
+ -- its role unconditionally.
+
-- d.s The compiler does not generate calls to secondary stack management
-- routines SS_Mark and SS_Release for a transient block when there is
-- an enclosing scoping construct which already manages the secondary
-- --
-- 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- --
-- Validated_Object Node36
- -- Class_Wide_Preconds List38
-
- -- Class_Wide_Postconds List39
-
+ -- Class_Wide_Clone Node38
-- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
-- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
- -- (unused) Flag302
+ -- Is_Class_Wide_Clone Flag302
-- (unused) Flag303
-- (unused) Flag304
-- (unused) Flag305
return Flag31 (Id);
end Checks_May_Be_Suppressed;
- function Class_Wide_Postconds (Id : E) return S is
- begin
- pragma Assert (Is_Subprogram (Id));
- return List39 (Id);
- end Class_Wide_Postconds;
-
- function Class_Wide_Preconds (Id : E) return S is
+ function Class_Wide_Clone (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id));
- return List38 (Id);
- end Class_Wide_Preconds;
+ return Node38 (Id);
+ end Class_Wide_Clone;
function Class_Wide_Type (Id : E) return E is
begin
return Flag73 (Id);
end Is_Child_Unit;
+ function Is_Class_Wide_Clone (Id : E) return B is
+ begin
+ return Flag302 (Id);
+ end Is_Class_Wide_Clone;
+
function Is_Class_Wide_Equivalent_Type (Id : E) return B is
begin
return Flag35 (Id);
Set_Flag31 (Id, V);
end Set_Checks_May_Be_Suppressed;
- procedure Set_Class_Wide_Preconds (Id : E; V : S) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_List38 (Id, V);
- end Set_Class_Wide_Preconds;
-
- procedure Set_Class_Wide_Postconds (Id : E; V : S) is
+ procedure Set_Class_Wide_Clone (Id : E; V : E) is
begin
pragma Assert (Is_Subprogram (Id));
- Set_List39 (Id, V);
- end Set_Class_Wide_Postconds;
+ Set_Node38 (Id, V);
+ end Set_Class_Wide_Clone;
procedure Set_Class_Wide_Type (Id : E; V : E) is
begin
Set_Flag73 (Id, V);
end Set_Is_Child_Unit;
+ procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is
+ begin
+ Set_Flag302 (Id, V);
+ end Set_Is_Class_Wide_Clone;
+
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
begin
Set_Flag35 (Id, V);
procedure Write_Field38_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Class_Wide_Preconditions");
-
+ when E_Function | E_Procedure =>
+ Write_Str ("class-wide clone");
when others =>
Write_Str ("Field38??");
end case;
procedure Write_Field39_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Class_Wide_Postcondition");
-
when others =>
Write_Str ("Field39??");
end case;
-- tables must be consulted to determine if there actually is an active
-- Suppress or Unsuppress pragma that applies to the entity.
--- Class_Wide_Preconds (List38)
--- Defined on subprograms. Holds the list of class-wide precondition
--- functions inherited from ancestors. Each such function is an
--- instantiation of the generic function generated from an explicit
--- aspect specification for a class-wide precondition. A type is an
--- ancestor of itself, and therefore a root type has such an instance
--- on its own list.
-
--- Class_Wide_Postconds (List39)
--- Ditto for class-wide postconditions.
+-- Class_Wide_Clone (Node38)
+-- Defined on subprogram entities. Set if the subprogram has a class-wide
+-- ore- or postcondition, and the expression contains calls to other
+-- primitive funtions of the type. Used to implement properly the
+-- semantics of inherited operations whose class-wide condition may
+-- be different from that of the ancestor (See AI012-0195).
-- Class_Wide_Type (Node9)
-- Defined in all type entities. For a tagged type or subtype, returns
-- Defined in all entities. Set only for defining entities of program
-- units that are child units (but False for subunits).
+-- Is_Class_Wide_Clone (Flag302)
+-- Defined on subprogram entities. Set for subprograms built in order
+-- to implement properly the inheritance of class-wide pre- or post-
+-- conditions when the condition contains calls to other primitives
+-- of the ancestor type. Used to implement AI12-0195.
+
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Defined in record types and subtypes. Set to True, if the type acts
-- as a class-wide equivalent type, i.e. the Equivalent_Type field of
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Class_Wide_Preconds (List38)
- -- Class_Wide_Postconds (List39)
+ -- Class_Wide_Clone (Node38)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Class_Wide_Preconds (List38)
- -- Class_Wide_Postconds (List39)
+ -- Class_Wide_Clone (Node38)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
function Can_Never_Be_Null (Id : E) return B;
function Can_Use_Internal_Rep (Id : E) return B;
function Checks_May_Be_Suppressed (Id : E) return B;
- function Class_Wide_Postconds (Id : E) return S;
- function Class_Wide_Preconds (Id : E) return S;
+ function Class_Wide_Clone (Id : E) return E;
function Class_Wide_Type (Id : E) return E;
function Cloned_Subtype (Id : E) return E;
function Component_Alignment (Id : E) return C;
function Is_Character_Type (Id : E) return B;
function Is_Checked_Ghost_Entity (Id : E) return B;
function Is_Child_Unit (Id : E) return B;
+ function Is_Class_Wide_Clone (Id : E) return B;
function Is_Class_Wide_Equivalent_Type (Id : E) return B;
function Is_Compilation_Unit (Id : E) return B;
function Is_Completely_Hidden (Id : E) return B;
procedure Set_Can_Never_Be_Null (Id : E; V : B := True);
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True);
- procedure Set_Class_Wide_Postconds (Id : E; V : S);
- procedure Set_Class_Wide_Preconds (Id : E; V : S);
+ procedure Set_Class_Wide_Clone (Id : E; V : E);
procedure Set_Class_Wide_Type (Id : E; V : E);
procedure Set_Cloned_Subtype (Id : E; V : E);
procedure Set_Component_Alignment (Id : E; V : C);
procedure Set_Is_Character_Type (Id : E; V : B := True);
procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True);
procedure Set_Is_Child_Unit (Id : E; V : B := True);
+ procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True);
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True);
procedure Set_Is_Compilation_Unit (Id : E; V : B := True);
procedure Set_Is_Completely_Hidden (Id : E; V : B := True);
pragma Inline (Can_Never_Be_Null);
pragma Inline (Can_Use_Internal_Rep);
pragma Inline (Checks_May_Be_Suppressed);
- pragma Inline (Class_Wide_Preconds);
- pragma Inline (Class_Wide_Postconds);
+ pragma Inline (Class_Wide_Clone);
pragma Inline (Class_Wide_Type);
pragma Inline (Cloned_Subtype);
pragma Inline (Component_Bit_Offset);
pragma Inline (Is_Character_Type);
pragma Inline (Is_Checked_Ghost_Entity);
pragma Inline (Is_Child_Unit);
+ pragma Inline (Is_Class_Wide_Clone);
pragma Inline (Is_Class_Wide_Equivalent_Type);
pragma Inline (Is_Class_Wide_Type);
pragma Inline (Is_Compilation_Unit);
pragma Inline (Set_Can_Never_Be_Null);
pragma Inline (Set_Can_Use_Internal_Rep);
pragma Inline (Set_Checks_May_Be_Suppressed);
- pragma Inline (Set_Class_Wide_Postconds);
- pragma Inline (Set_Class_Wide_Preconds);
+ pragma Inline (Set_Class_Wide_Clone);
pragma Inline (Set_Class_Wide_Type);
pragma Inline (Set_Cloned_Subtype);
pragma Inline (Set_Component_Bit_Offset);
pragma Inline (Set_Is_Character_Type);
pragma Inline (Set_Is_Checked_Ghost_Entity);
pragma Inline (Set_Is_Child_Unit);
+ pragma Inline (Set_Is_Class_Wide_Clone);
pragma Inline (Set_Is_Class_Wide_Equivalent_Type);
pragma Inline (Set_Is_Compilation_Unit);
pragma Inline (Set_Is_Completely_Hidden);
function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
begin
- -- An exception handler with a choice parameter utilizes a dummy
- -- block to provide a declarative region. Such a block should not be
- -- considered because it never manifests in the tree and can never
- -- release the secondary stack.
-
- if Ekind (Id) = E_Block
- and then Uses_Sec_Stack (Id)
- and then not Is_Exception_Handler (Id)
- then
- return True;
+ case Ekind (Id) is
- -- Loops are intentionally excluded because they undergo special
- -- treatment, see Establish_Transient_Scope.
+ -- An exception handler with a choice parameter utilizes a dummy
+ -- block to provide a declarative region. Such a block should not
+ -- be considered because it never manifests in the tree and can
+ -- never release the secondary stack.
- elsif Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure)
- and then Uses_Sec_Stack (Id)
- then
- return True;
+ when E_Block =>
+ return
+ Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
- else
- return False;
- end if;
+ when E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
+ =>
+ return Uses_Sec_Stack (Id);
+
+ when others =>
+ return False;
+ end case;
end Manages_Sec_Stack;
-- Local variables
Scop := Scope (Trans_Id);
while Present (Scop) loop
- if Scop = Standard_Standard then
- exit;
- -- The transient block must manage the secondary stack when the
- -- block appears within a loop in order to reclaim the memory at
- -- each iteration.
+ -- It should not be possible to reach Standard without hitting one
+ -- of the other cases first unless Standard was manually pushed.
- elsif Ekind (Scop) = E_Loop then
+ if Scop = Standard_Standard then
exit;
-- The transient block is within a function which returns on the
Set_Uses_Sec_Stack (Trans_Id, False);
exit;
- -- When requested, the transient block does not need to manage the
- -- secondary stack when there exists an enclosing block, entry,
- -- entry family, function, or a procedure which already does that.
+ -- The transient block must manage the secondary stack when the
+ -- block appears within a loop in order to reclaim the memory at
+ -- each iteration.
+
+ elsif Ekind (Scop) = E_Loop then
+ exit;
+
+ -- The transient block does not need to manage the secondary stack
+ -- when there is an enclosing construct which already does that.
-- This optimization saves on SS_Mark and SS_Release calls but may
-- allow objects to live a little longer than required.
- elsif Debug_Flag_Dot_S and then Manages_Sec_Stack (Scop) then
+ -- The transient block must manage the secondary stack when switch
+ -- -gnatd.s (strict management) is in effect.
+
+ elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
Set_Uses_Sec_Stack (Trans_Id, False);
exit;
+
+ -- Prevent the search from going too far because transient blocks
+ -- are bounded by packages and subprogram scopes.
+
+ elsif Ekind_In (Scop, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Package,
+ E_Procedure,
+ E_Subprogram_Body)
+ then
+ exit;
end if;
Scop := Scope (Scop);
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
Add_Str_To_Name_Buffer (Suffix);
end if;
+ -- Add a special prefix to distinguish Ghost entities. In Ignored Ghost
+ -- mode, these entities should not leak in the "living" space and they
+ -- should be removed by the compiler in a post-processing pass. Thus,
+ -- the prefix allows anyone to check that the final executable indeed
+ -- does not contain such entities, in such a case. Do not insert this
+ -- prefix for compilation units, whose name is used as a basis for the
+ -- name of the generated elaboration procedure and (when appropriate)
+ -- the executable produced. Only insert this prefix once, for Ghost
+ -- entities declared inside other Ghost entities. Three leading
+ -- underscores are used so that "___ghost_" is a unique substring of
+ -- names produced for Ghost entities, while "__ghost_" can appear in
+ -- names of entities inside a child/local package called "Ghost".
+
+ if Is_Ghost_Entity (E)
+ and then not Is_Compilation_Unit (E)
+ and then (Name_Len < 9
+ or else Name_Buffer (1 .. 9) /= "___ghost_")
+ then
+ Insert_Str_In_Name_Buffer ("___ghost_", 1);
+ end if;
+
Name_Buffer (Name_Len + 1) := ASCII.NUL;
end Get_External_Name;
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
-- qualification for such entities. In particular this means that direct
-- local variables of a procedure are not qualified.
+ -- For Ghost entities, the encoding adds a prefix "___ghost_" to aid the
+ -- detection of leaks of Ignored Ghost entities in the "living" space.
+ -- Ignored Ghost entities and any code associated with them should be
+ -- removed by the compiler in a post-processing pass. As a result,
+ -- object files should not contain any occurrences of this prefix.
+
-- As an example of the local name convention, consider a procedure V.W
-- with a local variable X, and a nested block Y containing an entity Z.
-- The fully qualified names of the entities X and Z are:
-- --
-- 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- --
---------------------
procedure Expand_N_Pragma (N : Node_Id) is
- Pname : constant Name_Id := Pragma_Name (N);
+ Pname : constant Name_Id := Pragma_Name (N);
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
begin
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
- -- the back end or the expander here does not get overenthusiastic and
- -- start processing such a pragma!
+ -- the back end doesn't see it. The same goes for pragma
+ -- Default_Scalar_Storage_Order if the -gnatI switch was given.
- if Should_Ignore_Pragma_Sem (N) then
+ if Should_Ignore_Pragma_Sem (N)
+ or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
+ and then Ignore_Rep_Clauses)
+ then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
end if;
- case Get_Pragma_Id (Pname) is
+ case Prag_Id is
-- Pragmas requiring special expander action
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, AdaCore --
+-- Copyright (C) 1998-2017, AdaCore --
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Ada.IO_Exceptions;
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
+ if Path_Len = 0 then
+ raise Ada.IO_Exceptions.Use_Error
+ with "current directory does not exist";
+ end if;
+
Last :=
(if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
begin
Get_Current_Dir (Buffer'Address, Path_Len'Address);
+ if Path_Len = 0 then
+ raise Program_Error;
+ end if;
+
if Buffer (Path_Len) /= Directory_Separator then
Path_Len := Path_Len + 1;
Buffer (Path_Len) := Directory_Separator;
return Pragma_Node;
end if;
- -- Ignore pragma previously flagged by Ignore_Pragma
+ -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
+ -- Default_Scalar_Storage_Order if the -gnatI switch was given.
- if Should_Ignore_Pragma_Par (Prag_Name) then
+ if Should_Ignore_Pragma_Par (Prag_Name)
+ or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
+ and then Ignore_Rep_Clauses)
+ then
return Pragma_Node;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2016, AdaCore --
+-- Copyright (C) 1995-2017, AdaCore --
-- --
-- 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- --
begin
Get_Current_Dir (Buffer'Address, Path_Len'Address);
+ if Path_Len = 0 then
+ raise Program_Error;
+ end if;
+
if Buffer (Path_Len) /= Directory_Separator then
Path_Len := Path_Len + 1;
Buffer (Path_Len) := Directory_Separator;
=>
null;
+ -- A quantified expression with a missing "all" or "some" qualifier
+ -- looks identical to an iterated component association. By language
+ -- definition, the latter must be present within array aggregates. If
+ -- this is not the case, then the iterated component association is
+ -- really an illegal quantified expression. Diagnose this scenario.
+
+ when N_Iterated_Component_Association =>
+ Diagnose_Iterated_Component_Association (N);
+
-- For the remaining node types, we generate compiler abort, because
-- these nodes are always analyzed within the Sem_Chn routines and
-- there should never be a case of making a call to the main Analyze
| N_Function_Specification
| N_Generic_Association
| N_Index_Or_Discriminant_Constraint
- | N_Iterated_Component_Association
| N_Iteration_Scheme
| N_Mod_Clause
| N_Modular_Type_Definition
when Attribute_Alignment
| Attribute_Bit_Order
| Attribute_Component_Size
+ | Attribute_Default_Scalar_Storage_Order
| Attribute_Machine_Radix
| Attribute_Object_Size
+ | Attribute_Scalar_Storage_Order
| Attribute_Size
| Attribute_Small
| Attribute_Stream_Size
procedure Analyze_Pragma (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Prag_Id : Pragma_Id;
Pname : Name_Id := Pragma_Name (N);
-- Name of the source pragma, or name of the corresponding aspect for
-- pragmas which originate in a source aspect. In the latter case, the
-- name may be different from the pragma name.
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
+
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It
-- is used when an error is detected, and no further processing is
Check_Restriction_No_Use_Of_Pragma (N);
- -- Ignore pragma if Ignore_Pragma applies
+ -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
+ -- Default_Scalar_Storage_Order if the -gnatI switch was given.
- if Should_Ignore_Pragma_Sem (N) then
+ if Should_Ignore_Pragma_Sem (N)
+ or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
+ and then Ignore_Rep_Clauses)
+ then
return;
end if;
-- Here to start processing for recognized pragma
- Prag_Id := Get_Pragma_Id (Pname);
Pname := Original_Aspect_Pragma_Name (N);
-- Capture setting of Opt.Uneval_Old
-- --
-- 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- --
-- If the called function is not declared in the main unit and it
-- returns the limited view of type then use the available view (as
-- is done in Try_Object_Operation) to prevent back-end confusion;
- -- the call must appear in a context where the nonlimited view is
- -- available. If the called function is in the extended main unit
- -- then no action is needed, because the back end handles this case.
-
- if not In_Extended_Main_Code_Unit (Nam)
- and then From_Limited_With (Etype (Nam))
+ -- for the function entity itself. The call must appear in a context
+ -- where the nonlimited view is available. If the function entity is
+ -- in the extended main unit then no action is needed, because the
+ -- back end handles this case. In either case the type of the call
+ -- is the nonlimited view.
+
+ if From_Limited_With (Etype (Nam))
+ and then Present (Available_View (Etype (Nam)))
then
- Set_Etype (Nam, Available_View (Etype (Nam)));
- end if;
+ Set_Etype (N, Available_View (Etype (Nam)));
- Set_Etype (N, Etype (Nam));
+ if not In_Extended_Main_Code_Unit (Nam) then
+ Set_Etype (Nam, Available_View (Etype (Nam)));
+ end if;
+
+ else
+ Set_Etype (N, Etype (Nam));
+ end if;
end if;
-- In the case where the call is to an overloaded subprogram, Analyze
end if;
end Designate_Same_Unit;
- ------------------------------------------
- -- function Dynamic_Accessibility_Level --
- ------------------------------------------
+ ---------------------------------------------
+ -- Diagnose_Iterated_Component_Association --
+ ---------------------------------------------
+
+ procedure Diagnose_Iterated_Component_Association (N : Node_Id) is
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Aggr : Node_Id;
+
+ begin
+ -- Determine whether the iterated component association appears within
+ -- an aggregate. If this is the case, raise Program_Error because the
+ -- iterated component association cannot be left in the tree as is and
+ -- must always be processed by the related aggregate.
+
+ Aggr := N;
+ while Present (Aggr) loop
+ if Nkind (Aggr) = N_Aggregate then
+ raise Program_Error;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Aggr) then
+ exit;
+ end if;
+
+ Aggr := Parent (Aggr);
+ end loop;
+
+ -- At this point it is known that the iterated component association is
+ -- not within an aggregate. This is really a quantified expression with
+ -- a missing "all" or "some" quantifier.
+
+ Error_Msg_N ("missing quantifier", Def_Id);
+
+ -- Rewrite the iterated component association as True to prevent any
+ -- cascaded errors.
+
+ Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N)));
+ Analyze (N);
+ end Diagnose_Iterated_Component_Association;
+
+ ---------------------------------
+ -- Dynamic_Accessibility_Level --
+ ---------------------------------
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
- E : Entity_Id;
Loc : constant Source_Ptr := Sloc (Expr);
function Make_Level_Literal (Level : Uint) return Node_Id;
function Make_Level_Literal (Level : Uint) return Node_Id is
Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
+
begin
Set_Etype (Result, Standard_Natural);
return Result;
end Make_Level_Literal;
+ -- Local variables
+
+ E : Entity_Id;
+
-- Start of processing for Dynamic_Accessibility_Level
begin
-- these names is supposed to be a selected component name, an expanded
-- name, a defining program unit name or an identifier.
+ procedure Diagnose_Iterated_Component_Association (N : Node_Id);
+ -- Emit an error if iterated component association N is actually an illegal
+ -- quantified expression lacking a quantifier.
+
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id;
-- Expr should be an expression of an access type. Builds an integer
-- literal except in cases involving anonymous access types where
projects / gcc.git / commitdiff