+2013-10-10 Robert Dewar <dewar@adacore.com>
+
+ * lib-xref-spark_specific.adb, par-ch13.adb, sem_prag.adb, sem_prag.ads,
+ sem_ch12.adb, sem_attr.adb, sem_ch6.adb, sem_ch13.adb, a-sequio.adb,
+ s-atocou-builtin.adb: Minor reformatting.
+
+2013-10-10 Thomas Quinot <quinot@adacore.com>
+
+ * s-oscons-tmplt.c (NEED_PTHREAD_CONDATTR_SETCLOCK): This
+ constant needs to be output to s-oscons.h, as it is tested
+ by init.c.
+
+2013-10-10 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Variant_Part): Don't expand choices, too early
+ * exp_ch5.adb (Expand_N_Case_Statement): Use new Has_SP_Choice
+ flag to avoid expanding choices when not necessary.
+ * exp_util.adb: Minor reformatting
+ * freeze.adb (Freeze_Record_Type): Redo expansion of variants
+ * sem_aggr.adb: Minor reformatting
+ * sem_case.ads, sem_case.adb: Major rewrite, separating Analysis and
+ Checking of choices.
+ * sem_ch3.adb (Analyze_Variant_Part): Rewrite to call new
+ Analyze_Choices.
+ * sem_ch4.adb (Analyze_Case_Expression): Call Analyze_Choices
+ and Check_Choices
+ * sem_ch5.adb (Analyze_Case_Statement): Call Analyze_Choices
+ and Check_Choices
+ * sem_util.adb: Minor reformatting
+ * sinfo.ads, sinfo.adb (Has_SP_Choice): New flag.
+
+2013-10-10 Vincent Celier <celier@adacore.com>
+
+ * mlib-prj.adb (Build_Library): Do not issue link dynamic
+ libraries with an Rpath, if switch -R was used.
+
+2013-10-10 Tristan Gingold <gingold@adacore.com>
+
+ * s-stalib.ads (Image_Index_Table_8, Image_Index_Table_16,
+ Image_Index_Table_32): Remove as not used.
+ * s-imgint.adb (Image_Integer): Call Set_Image_Integer and
+ remove duplicated code.
+
2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Pragma): Provide a
-- (for specialized Sequential_IO functions)
with Ada.Unchecked_Conversion;
+
with System;
+with System.Byte_Swapping;
with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
with System.Storage_Elements;
+
with Interfaces.C_Streams; use Interfaces.C_Streams;
-with GNAT.Byte_Swapping;
package body Ada.Sequential_IO is
---------------
procedure Byte_Swap (Siz : in out size_t) is
- use GNAT.Byte_Swapping;
+ use System.Byte_Swapping;
begin
case Siz'Size is
- when 32 => Swap4 (Siz'Address);
- when 64 => Swap8 (Siz'Address);
+ when 32 => Siz := size_t (Bswap_32 (U32 (Siz)));
+ when 64 => Siz := size_t (Bswap_64 (U64 (Siz)));
when others => raise Program_Error;
end case;
end Byte_Swap;
FIO.Read_Buf
(AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit);
+ -- If item read has non-default scalar storage order, then the size
+ -- will have been written with that same order, so byte swap it.
+
if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
Byte_Swap (Rsiz);
end if;
if not Element_Type'Definite
or else Element_Type'Has_Discriminants
then
+ -- If item written has non-default scalar storage order, then the
+ -- size is written with that same order, so byte swap it.
+
if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
Byte_Swap (Swapped_Siz);
end if;
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
- Variant : Node_Id;
begin
-- If the last variant does not contain the Others choice, replace it
Set_Discrete_Choices (Last_Var, New_List (Others_Node));
end if;
- -- Deal with any static predicates in the variant choices. Note that we
- -- don't have to look at the last variant, since we know it is an others
- -- choice, because we just rewrote it that way if necessary.
+ -- We have one more expansion activity, which is to deal with static
+ -- predicates in the variant choices. But we have to defer that to
+ -- the freeze point, because the statically predicated subtype won't
+ -- be fully processed till then, so this expansion activity is carried
+ -- out in Freeze_Record_Type.
- Variant := First_Non_Pragma (Variants (N));
- while Variant /= Last_Var loop
- Expand_Static_Predicates_In_Choices (Variant);
- Next_Non_Pragma (Variant);
- end loop;
end Expand_N_Variant_Part;
---------------------------------
Alt := First_Non_Pragma (Alternatives (N));
while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
- Expand_Static_Predicates_In_Choices (Alt);
+
+ if Has_SP_Choice (Alt) then
+ Expand_Static_Predicates_In_Choices (Alt);
+ end if;
+
Next_Non_Pragma (Alt);
end loop;
end;
end if;
-- Change Sloc to referencing choice (rather than the Sloc of
- -- the predicate declarationo element itself).
+ -- the predicate declaration element itself).
Set_Sloc (C, Sloc (Choice));
Insert_Before (Choice, C);
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
and then Nkind (Type_Definition (Parent (T))) =
N_Record_Definition
and then not Null_Present (Type_Definition (Parent (T)))
- and then Present (Variant_Part
- (Component_List (Type_Definition (Parent (T)))))
+ and then
+ Present (Variant_Part
+ (Component_List (Type_Definition (Parent (T)))))
then
-- If variant part is present, and type is unconstrained,
-- then we must have defaulted discriminants, or a size
begin
if Present (Alloc) then
- -- If component is pointer to a classwide type, freeze
+ -- If component is pointer to a class-wide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
if Present (ADC) and then Base_Type (Rec) = Rec then
if not (Placed_Component or else Is_Packed (Rec)) then
- Error_Msg_N ("??bit order specification has no effect", ADC);
+ Error_Msg_N
+ ("??bit order specification has no effect", ADC);
Error_Msg_N
("\??since no component clauses were specified", ADC);
-- remote type here since that is what we are semantically freezing.
-- This prevents the freeze node for that type in an inner scope.
- -- Also, Check for controlled components and unchecked unions.
- -- Finally, enforce the restriction that access attributes with a
- -- current instance prefix can only apply to limited types.
-
if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
+ -- Check for controlled components and unchecked unions.
+
Comp := First_Component (Rec);
while Present (Comp) loop
-- equivalent type. See Make_CW_Equivalent_Type.
if not Is_Class_Wide_Equivalent_Type (Rec)
- and then (Has_Controlled_Component (Etype (Comp))
- or else (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else (Is_Protected_Type (Etype (Comp))
- and then
- Present
- (Corresponding_Record_Type
- (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type
- (Etype (Comp)))))
+ and then
+ (Has_Controlled_Component (Etype (Comp))
+ or else
+ (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else
+ (Is_Protected_Type (Etype (Comp))
+ and then
+ Present (Corresponding_Record_Type (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type (Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
end if;
end loop;
end if;
+ -- Enforce the restriction that access attributes with a current
+ -- instance prefix can only apply to limited types. This comment
+ -- is floating here, but does not seem to belong here???
+
+ -- Set component alignment if not otherwise already set
+
Set_Component_Alignment_If_Not_Set (Rec);
-- For first subtypes, check if there are any fixed-point fields with
-- component clauses, where we must check the size. This is not done
- -- till the freeze point, since for fixed-point types, we do not know
+ -- till the freeze point since for fixed-point types, we do not know
-- the size until the type is frozen. Similar processing applies to
-- bit packed arrays.
end;
end if;
end if;
+
+ -- All done if not a full record definition
+
+ if Ekind (Rec) /= E_Record_Type then
+ return;
+ end if;
+
+ -- Finallly we need to check the variant part to make sure that
+ -- the set of choices for each variant covers the corresponding
+ -- discriminant. This check has to be delayed to the freeze point
+ -- because we may have statically predicated subtypes, whose choice
+ -- list is not known till the subtype is frozen.
+
+ Check_Variant_Part : declare
+ D : constant Node_Id := Declaration_Node (Rec);
+ T : Node_Id;
+ C : Node_Id;
+ V : Node_Id;
+
+ Others_Present : Boolean;
+ pragma Warnings (Off, Others_Present);
+ -- Indicates others present, not used in this case
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id);
+ -- Error routine invoked by the generic instantiation below when
+ -- the variant part has a non static choice.
+
+ procedure Process_Declarations (Variant : Node_Id);
+ -- Processes declarations associated with a variant. We analyzed
+ -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
+ -- but we still need the recursive call to Check_Choices for any
+ -- nested variant to get its choices properly processed. This is
+ -- also where we expand out the choices if expansion is active.
+
+ package Variant_Choices_Processing is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
+ Process_Non_Static_Choice => Non_Static_Choice_Error,
+ Process_Associated_Node => Process_Declarations);
+ use Variant_Choices_Processing;
+
+ -----------------------------
+ -- Non_Static_Choice_Error --
+ -----------------------------
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ begin
+ Flag_Non_Static_Expr
+ ("choice given in variant part is not static!", Choice);
+ end Non_Static_Choice_Error;
+
+ --------------------------
+ -- Process_Declarations --
+ --------------------------
+
+ procedure Process_Declarations (Variant : Node_Id) is
+ CL : constant Node_Id := Component_List (Variant);
+ VP : Node_Id;
+
+ begin
+ -- Check for static predicate present in this variant
+
+ if Has_SP_Choice (Variant) then
+
+ -- Here we expand. You might expect to find this call in
+ -- Expand_N_Variant_Part, but that is called when we first
+ -- see the variant part, and we cannot do this expansion
+ -- earlier than the freeze point, since for statically
+ -- predicated subtypes, the predicate is not known till
+ -- the freeze point.
+
+ -- Furthermore, we do this expansion even if the expander
+ -- is not active, because other semantic processing, e.g.
+ -- for aggregates, requires the expanded list of choices.
+
+ -- If the expander is not active, then we can't just clobber
+ -- the list since it would invalidate the ASIS -gnatct tree.
+ -- So we have to rewrite the variant part with a Rewrite
+ -- call that replaces it with a copy and clobber the copy.
+
+ if not Expander_Active then
+ declare
+ NewV : constant Node_Id := New_Copy (Variant);
+ begin
+ Set_Discrete_Choices
+ (NewV, New_Copy_List (Discrete_Choices (Variant)));
+ Rewrite (Variant, NewV);
+ end;
+ end if;
+
+ Expand_Static_Predicates_In_Choices (Variant);
+ end if;
+
+ -- We don't need to worry about the declarations in the variant
+ -- (since they were analyzed by Analyze_Choices when we first
+ -- encountered the variant), but we do need to take care of
+ -- expansion of any nested variants.
+
+ if not Null_Present (CL) then
+ VP := Variant_Part (CL);
+
+ if Present (VP) then
+ Check_Choices
+ (VP, Variants (VP), Etype (Name (VP)), Others_Present);
+ end if;
+ end if;
+ end Process_Declarations;
+
+ -- Start of processing for Check_Variant_Part
+
+ begin
+ -- Find component list
+
+ C := Empty;
+
+ if Nkind (D) = N_Full_Type_Declaration then
+ T := Type_Definition (D);
+
+ if Nkind (T) = N_Record_Definition then
+ C := Component_List (T);
+
+ elsif Nkind (T) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (T))
+ then
+ C := Component_List (Record_Extension_Part (T));
+ end if;
+ end if;
+
+ -- If we have a variant part, check choices
+
+ if Present (C) and then Present (Variant_Part (C)) then
+ V := Variant_Part (C);
+ Check_Choices
+ (V, Variants (V), Etype (Name (V)), Others_Present);
+ end if;
+ end Check_Variant_Part;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity
when N_Pragma =>
- -- The enclosing subprogram for a precondition, a
- -- postcondition, or a contract case should be the subprogram
- -- to which the pragma is attached, which can be found by
- -- following previous elements in the list to which the
- -- pragma belongs.
+ -- The enclosing subprogram for a precondition, postcondition,
+ -- or contract case should be the subprogram to which the
+ -- pragma is attached, which can be found by following
+ -- previous elements in the list to which the pragma belongs.
if Get_Pragma_Id (Result) = Pragma_Precondition
or else
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2011, AdaCore --
+-- Copyright (C) 2001-2013, 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- --
-- content of Rpath. As Rpath contains at least libgnat directory
-- path name, it is guaranteed that it is not null.
- if Path_Option /= null then
+ if Opt.Run_Path_Option and then Path_Option /= null then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
Result := True;
else
Scan; -- past identifier
- Result := Token = Tok_Arrow
- or else Token = Tok_Comma
- or else Token = Tok_Semicolon;
+ Result := Token = Tok_Arrow or else
+ Token = Tok_Comma or else
+ Token = Tok_Semicolon;
end if;
-- If earlier than Ada 2012, check for valid aspect identifier (possibly
-- defaulted True value. Further checks when analyzing aspect
-- specification, which may include further aspects.
- elsif Token = Tok_Comma
- or else Token = Tok_Semicolon
- then
+ elsif Token = Tok_Comma or else Token = Tok_Semicolon then
Result := True;
elsif Token = Tok_Apostrophe then
procedure Increment (Item : in out Atomic_Counter) is
begin
- -- Note: the use of Unrestricted_Access here is required because we
- -- are obtaining an access-to-volatile pointer to a non-volatile object.
+ -- Note: the use of Unrestricted_Access here is required because we are
+ -- obtaining an access-to-volatile pointer to a non-volatile object.
-- This is not allowed for [Unchecked_]Access, but is safe in this case
-- because we know that no aliases are being created.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
is
pragma Assert (S'First = 1);
- procedure Set_Digits (T : Integer);
- -- Set digits of absolute value of T, which is zero or negative. We work
- -- with the negative of the value so that the largest negative number is
- -- not a special case.
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (T : Integer) is
- begin
- if T <= -10 then
- Set_Digits (T / 10);
- P := P + 1;
- S (P) := Character'Val (48 - (T rem 10));
- else
- P := P + 1;
- S (P) := Character'Val (48 - T);
- end if;
- end Set_Digits;
-
- -- Start of processing for Image_Integer
-
begin
- P := 1;
-
if V >= 0 then
- S (P) := ' ';
- Set_Digits (-V);
+ S (1) := ' ';
+ P := 1;
else
- S (P) := '-';
- Set_Digits (V);
+ P := 0;
end if;
+
+ Set_Image_Integer (V, S, P);
end Image_Integer;
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2013, 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- --
** appropriately (see thread.c).
**/
# define CLOCK_RT_Ada "CLOCK_MONOTONIC"
-# define NEED_PTHREAD_CONDATTR_SETCLOCK
+# define NEED_PTHREAD_CONDATTR_SETCLOCK 1
#elif defined(HAVE_CLOCK_REALTIME)
/* By default use CLOCK_REALTIME */
#ifdef CLOCK_RT_Ada
CNS(CLOCK_RT_Ada, "")
#endif
+#ifdef NEED_PTHREAD_CONDATTR_SETCLOCK
+CND(NEED_PTHREAD_CONDATTR_SETCLOCK, "")
+#endif
#if defined (__APPLE__) || defined (__linux__) || defined (DUMMY)
/*
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
function To_Ptr is
new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr);
- ---------------------------------------------
- -- Type For Enumeration Image Index Tables --
- ---------------------------------------------
-
- -- Note: these types are declared at the start of this unit, since
- -- they must appear before any enumeration types declared in this
- -- unit. Note that the spec of system is already elaborated at
- -- this point (since we are a child of system), which means that
- -- enumeration types in package System cannot use these types.
-
- type Image_Index_Table_8 is
- array (Integer range <>) of Short_Short_Integer;
- type Image_Index_Table_16 is
- array (Integer range <>) of Short_Integer;
- type Image_Index_Table_32 is
- array (Integer range <>) of Integer;
- -- These types are used to generate the index vector used for enumeration
- -- type image tables. See spec of Exp_Imgv in the main GNAT sources for a
- -- full description of the data structures that are used here.
-
-------------------------------------
-- Exception Declarations and Data --
-------------------------------------
begin
-- A record aggregate is restricted in SPARK:
+
-- Each named association can have only a single choice.
-- OTHERS cannot be used.
-- Positional and named associations cannot be mixed.
end loop;
end Find_Private_Ancestor;
+ -- Start of processing for Step_5
+
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
if Nkind (Dnode) = N_Full_Type_Declaration then
Record_Def := Type_Definition (Dnode);
- Gather_Components (Base_Type (Typ),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Gather_Components
+ (Base_Type (Typ),
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
end if;
end if;
null;
elsif not Has_Unknown_Discriminants (Typ) then
- Gather_Components (Base_Type (Typ),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Gather_Components
+ (Base_Type (Typ),
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
else
Gather_Components
(Base_Type (Underlying_Record_View (Typ)),
- Component_List (Record_Def),
- Governed_By => New_Assoc_List,
- Into => Components,
- Report_Errors => Errors_Found);
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
end if;
end if;
when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
declare
- Ent : Entity_Id := Empty;
+ Ent : Entity_Id := Empty;
+
begin
Check_E0;
Check_Type;
-- the default bit order for the target.
if not (GNAT_Mode and then Is_Generic_Type (P_Type))
- and then not In_Instance
+ and then not In_Instance
then
Error_Attr_P
("prefix of % attribute must be record or array type");
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
-- Local Subprograms --
-----------------------
- procedure Check_Choices
+ procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
- -- The case table is the table generated by a call to Analyze_Choices
+ -- The case table is the table generated by a call to Check_Choices
-- (with just 1 .. Last_Choice entries present). Others_Choice is a
-- pointer to the N_Others_Choice node (this routine is only called if
-- an others choice is present), and Choice_Type is the discrete type
-- determine the set of values covered by others. This choice list is
-- set in the Others_Discrete_Choices field of the N_Others_Choice node.
- -------------------
- -- Check_Choices --
- -------------------
+ ----------------------
+ -- Check_Choice_Set --
+ ----------------------
- procedure Check_Choices
+ procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
Prev_Lo : Uint;
Prev_Hi : Uint;
- -- Start of processing for Check_Choices
+ -- Start of processing for Check_Choice_Set
begin
-- Choice_Table must start at 0 which is an unused location used by the
end if;
end if;
end if;
- end Check_Choices;
+ end Check_Choice_Set;
------------------
-- Choice_Image --
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
- -- Builds a node representing the missing choices given by the
- -- Value1 and Value2. A N_Range node is built if there is more than
- -- one literal value missing. Otherwise a single N_Integer_Literal,
- -- N_Identifier or N_Character_Literal is built depending on what
- -- Choice_Type is.
+ -- Builds a node representing the missing choices given by Value1 and
+ -- Value2. A N_Range node is built if there is more than one literal
+ -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
+ -- or N_Character_Literal is built depending on what Choice_Type is.
function Lit_Of (Value : Uint) return Node_Id;
-- Returns the Node_Id for the enumeration literal corresponding to the
null;
end No_OP;
- --------------------------------
- -- Generic_Choices_Processing --
- --------------------------------
+ -----------------------------
+ -- Generic_Analyze_Choices --
+ -----------------------------
- package body Generic_Choices_Processing is
+ package body Generic_Analyze_Choices is
-- The following type is used to gather the entries for the choice
-- table, so that we can then allocate the right length.
Nxt : Link_Ptr;
end record;
- procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
-
---------------------
-- Analyze_Choices --
---------------------
procedure Analyze_Choices
- (N : Node_Id;
- Subtyp : Entity_Id;
- Raises_CE : out Boolean;
- Others_Present : out Boolean)
+ (Alternatives : List_Id;
+ Subtyp : Entity_Id)
+ is
+ Choice_Type : constant Entity_Id := Base_Type (Subtyp);
+ -- The actual type against which the discrete choices are resolved.
+ -- Note that this type is always the base type not the subtype of the
+ -- ruling expression, index or discriminant.
+
+ Expected_Type : Entity_Id;
+ -- The expected type of each choice. Equal to Choice_Type, except if
+ -- the expression is universal, in which case the choices can be of
+ -- any integer type.
+
+ Alt : Node_Id;
+ -- A case statement alternative or a variant in a record type
+ -- declaration.
+
+ Choice : Node_Id;
+ Kind : Node_Kind;
+ -- The node kind of the current Choice
+
+ begin
+ -- Set Expected type (= choice type except for universal integer,
+ -- where we accept any integer type as a choice).
+
+ if Choice_Type = Universal_Integer then
+ Expected_Type := Any_Integer;
+ else
+ Expected_Type := Choice_Type;
+ end if;
+
+ -- Now loop through the case alternatives or record variants
+
+ Alt := First (Alternatives);
+ while Present (Alt) loop
+
+ -- If pragma, just analyze it
+
+ if Nkind (Alt) = N_Pragma then
+ Analyze (Alt);
+
+ -- Otherwise we have an alternative. In most cases the semantic
+ -- processing leaves the list of choices unchanged
+
+ -- Check each choice against its base type
+
+ else
+ Choice := First (Discrete_Choices (Alt));
+ while Present (Choice) loop
+ Analyze (Choice);
+ Kind := Nkind (Choice);
+
+ -- Choice is a Range
+
+ if Kind = N_Range
+ or else (Kind = N_Attribute_Reference
+ and then Attribute_Name (Choice) = Name_Range)
+ then
+ Resolve (Choice, Expected_Type);
+
+ -- Choice is a subtype name, nothing further to do now
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ null;
+
+ -- Choice is a subtype indication
+
+ elsif Kind = N_Subtype_Indication then
+ Resolve_Discrete_Subtype_Indication
+ (Choice, Expected_Type);
+
+ -- Others choice, no analysis needed
+
+ elsif Kind = N_Others_Choice then
+ null;
+
+ -- Only other possibility is an expression
+
+ else
+ Resolve (Choice, Expected_Type);
+ end if;
+
+ -- Move to next choice
+
+ Next (Choice);
+ end loop;
+
+ Process_Associated_Node (Alt);
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Analyze_Choices;
+
+ end Generic_Analyze_Choices;
+
+ ---------------------------
+ -- Generic_Check_Choices --
+ ---------------------------
+
+ package body Generic_Check_Choices is
+
+ -- The following type is used to gather the entries for the choice
+ -- table, so that we can then allocate the right length.
+
+ type Link;
+ type Link_Ptr is access all Link;
+
+ type Link is record
+ Val : Choice_Bounds;
+ Nxt : Link_Ptr;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
+
+ -------------------
+ -- Check_Choices --
+ -------------------
+
+ procedure Check_Choices
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean)
is
E : Entity_Id;
+ Raises_CE : Boolean;
+ -- Set True if one of the bounds of a choice raises CE
+
Enode : Node_Id;
-- This is where we post error messages for bounds out of range
Kind : Node_Kind;
-- The node kind of the current Choice
- Delete_Choice : Boolean;
- -- Set to True to delete the current choice
-
Others_Choice : Node_Id := Empty;
-- Remember others choice if it is present (empty otherwise)
Num_Choices := Num_Choices + 1;
end Check;
- -- Start of processing for Analyze_Choices
+ -- Start of processing for Check_Choices
begin
Raises_CE := False;
Others_Present := False;
+ -- If Subtyp is not a discrete type or there was some other error,
+ -- then don't try any semantic checking on the choices since we have
+ -- a complete mess.
+
+ if not Is_Discrete_Type (Subtyp)
+ or else Subtyp = Any_Type
+ then
+ return;
+ end if;
+
-- If Subtyp is not a static subtype Ada 95 requires then we use the
-- bounds of its base type to determine the values covered by the
-- discrete choices.
-- Now loop through the case alternatives or record variants
- Alt := First (Get_Alternatives (N));
+ Alt := First (Alternatives);
while Present (Alt) loop
-- If pragma, just analyze it
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
- Delete_Choice := False;
Analyze (Choice);
Kind := Nkind (Choice);
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
+ -- We have to make sure the subtype is frozen, it must be
+ -- before we can do the following analyses on choices!
+
+ Insert_Actions
+ (N, Freeze_Entity (Entity (Choice), Choice));
+
+ -- Check for inappropriate type
+
if not Covers (Expected_Type, Etype (Choice)) then
Wrong_Type (Choice, Choice_Type);
+ -- Type is OK, so check further
+
else
E := Entity (Choice);
Next (P);
end loop;
end;
+
+ Set_Has_SP_Choice (Alt);
end if;
-- Not predicated subtype case
else
if Is_OK_Static_Expression (L)
- and then Is_OK_Static_Expression (H)
+ and then
+ Is_OK_Static_Expression (H)
then
if Expr_Value (L) > Expr_Value (H) then
Process_Empty_Choice (Choice);
elsif Kind = N_Others_Choice then
if not (Choice = First (Discrete_Choices (Alt))
and then Choice = Last (Discrete_Choices (Alt))
- and then Alt = Last (Get_Alternatives (N)))
+ and then Alt = Last (Alternatives))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
Check (Choice, Choice, Choice);
end if;
- -- Move to next choice, deleting the current one if the
- -- flag requesting this deletion is set True.
+ -- Move to next choice
- declare
- C : constant Node_Id := Choice;
- begin
- Next (Choice);
-
- if Delete_Choice then
- Remove (C);
- end if;
- end;
+ Next (Choice);
end loop;
Process_Associated_Node (Alt);
end loop;
end;
- Check_Choices
+ Check_Choice_Set
(Choice_Table,
Bounds_Type,
Subtyp,
Choice_Type => Bounds_Type);
end if;
end;
- end Analyze_Choices;
+ end Check_Choices;
- end Generic_Choices_Processing;
+ end Generic_Check_Choices;
end Sem_Case;
-- aggregate case, since issues with nested aggregates make that case
-- substantially different.
+-- The following processing is required for such cases:
+
+-- 1. Analysis of names of subtypes, constants, expressions appearing within
+-- the choices. This must be done when the construct is encountered to get
+-- proper visibility of names.
+
+-- 2. Checking for semantic correctness of the choices. A lot of this could
+-- be done at the time when the construct is encountered, but not all, since
+-- in the case of variants, statically predicated subtypes won't be frozen
+-- (and the choice sets known) till the enclosing record type is frozen. So
+-- at least the check for no overlaps and covering the range must be delayed
+-- till the freeze point in this case.
+
+-- 3. Set the Others_Discrete_Choices list for an others choice. This is
+-- used in various ways, e.g. to construct the disriminant checking function
+-- for the case of a variant with an others choice.
+
+-- 4. In the case of static predicates, we need to expand out choices that
+-- correspond to the predicate for the back end. This expansion destroys
+-- the list of choices, so it should be delayed to expansion time. We do
+-- not want to mess up the -gnatct ASIS tree, which needs to be able to
+
+-- Step 1 is performed by the generic procedure Analyze_Choices, which is
+-- called when the variant record or case statement/expression is first
+-- encountered.
+
+-- Step 2 is performed by the generic procedure Check_Choices. We decide to
+-- do all semantic checking in that step, since as noted above some of this
+-- has to be deferred to the freeze point in any case for variants. For case
+-- statements and expressions, this procedure can be called at the time the
+-- case construct is encountered (after calling Analyze_Choices).
+
+-- Step 3 is also performed by Check_Choices, since we need the static ranges
+-- for predicated subtypes to accurately construct this.
+
+-- Step 4 is performed by the procedure Expand_Static_Predicates_In_Choices.
+-- For case statements, this call only happens during expansion, so the tree
+-- generated for ASIS does not have this expansion. For the Variant case, the
+-- expansion is done in the ASIS -gnatct case, but with a proper Rewrite call
+-- on the N_Variant node, so ASIS can retrieve the original. The reason we do
+-- the expansion unconditionally for variants is that other processing, for
+-- example for aggregates, relies on having a complete list of choices.
+
+-- Historical note: We used to perform all four of these functions at once in
+-- a single procedure called Analyze_Choices. This routine was called at the
+-- time the construct was first encountered. That seemed to work OK up to Ada
+-- 2005, but the introduction of statically predicated subtypes with delayed
+-- evaluation of the static ranges made this completely wrong, both because
+-- the ASIS tree got destroyed by step 4, and steps 2 and 3 were too early
+-- in the variant record case.
+
with Types; use Types;
package Sem_Case is
procedure No_OP (C : Node_Id);
-- The no-operation routine. Does absolutely nothing. Can be used
- -- in the following generic for the parameter Process_Empty_Choice.
+ -- in the following generics for the parameters Process_Empty_Choice,
+ -- or Process_Associated_Node.
generic
- with function Get_Alternatives (N : Node_Id) return List_Id;
- -- Function used to get the list of case statement alternatives or
- -- record variants, from which we can then access the actual lists of
- -- discrete choices. N is the node for the original construct (case
- -- statement or a record variant).
+ with procedure Process_Associated_Node (A : Node_Id);
+ -- Associated with each case alternative or record variant A there is
+ -- a node or list of nodes that need additional processing. This routine
+ -- implements that processing.
+
+ package Generic_Analyze_Choices is
+
+ procedure Analyze_Choices
+ (Alternatives : List_Id;
+ Subtyp : Entity_Id);
+ -- From a case expression, case statement, or record variant, this
+ -- routine analyzes the corresponding list of discrete choices which
+ -- appear in each element of the list Alternatives (for the variant
+ -- part case, this is the variants, for a case expression or statement,
+ -- this is the Alternatives).
+ --
+ -- Subtyp is the subtype of the discrete choices. The type against which
+ -- the discrete choices must be resolved is its base type.
+ end Generic_Analyze_Choices;
+
+ generic
with procedure Process_Empty_Choice (Choice : Node_Id);
-- Processing to carry out for an empty Choice. Set to No_Op (declared
-- above) if no such processing is required.
with procedure Process_Non_Static_Choice (Choice : Node_Id);
- -- Processing to carry out for a non static Choice
+ -- Processing to carry out for a non static Choice (gives an error msg)
with procedure Process_Associated_Node (A : Node_Id);
-- Associated with each case alternative or record variant A there is
-- a node or list of nodes that need semantic processing. This routine
-- implements that processing.
- package Generic_Choices_Processing is
+ package Generic_Check_Choices is
- procedure Analyze_Choices
- (N : Node_Id;
- Subtyp : Entity_Id;
- Raises_CE : out Boolean;
- Others_Present : out Boolean);
+ procedure Check_Choices
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean);
-- From a case expression, case statement, or record variant N, this
- -- routine analyzes the corresponding list of discrete choices. Subtyp
- -- is the subtype of the discrete choices. The type against which the
- -- discrete choices must be resolved is its base type.
+ -- routine analyzes the corresponding list of discrete choices which
+ -- appear in each element of the list Alternatives (for the variant
+ -- part case, this is the variants, for a case expression or statement,
+ -- this is the Alternatives).
--
- -- If one of the bounds of a discrete choice raises a constraint
- -- error the flag Raise_CE is set.
+ -- Subtyp is the subtype of the discrete choices. The type against which
+ -- the discrete choices must be resolved is its base type.
--
- -- Finally Others_Present is set to True if an Others choice is present
- -- in the list of choices, and in this case the call also sets
- -- Others_Discrete_Choices in the N_Others_Choice node.
-
- end Generic_Choices_Processing;
+ -- Others_Present is set to True if an Others choice is present in the
+ -- list of choices, and in this case Others_Discrete_Choices is set in
+ -- the N_Others_Choice node.
+ --
+ -- If a Discrete_Choice list contains at least one instance of a subtype
+ -- with a static predicate, then the Has_SP_Choice flag is set true in
+ -- the parent node (N_Variant, N_Case_Expression/Statement_Alternative).
+ end Generic_Check_Choices;
end Sem_Case;
(Unit_Requires_Body (Gen_Unit)
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
- and then (Is_In_Main_Unit (N)
- or else Might_Inline_Subp)
+ and then (Is_In_Main_Unit (N) or else Might_Inline_Subp)
and then not Is_Actual_Pack
and then not Inline_Now
and then (Operating_Mode = Generate_Code
-- If front_end_inlining is enabled, do not instantiate body if
-- within a generic context.
- if (Front_End_Inlining
- and then not Expander_Active)
+ if (Front_End_Inlining and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;
Aspect_Precondition |
Aspect_Refined_Pre |
Aspect_SPARK_Mode |
- Aspect_Test_Case =>
+ Aspect_Test_Case =>
raise Program_Error;
end case;
--------------------------
procedure Analyze_Variant_Part (N : Node_Id) is
+ Discr_Name : Node_Id;
+ Discr_Type : Entity_Id;
- procedure Non_Static_Choice_Error (Choice : Node_Id);
- -- Error routine invoked by the generic instantiation below when the
- -- variant part has a non static choice.
-
- procedure Process_Declarations (Variant : Node_Id);
- -- Analyzes all the declarations associated with a Variant. Needed by
- -- the generic instantiation below.
-
- package Variant_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Variants,
- Process_Empty_Choice => No_OP,
- Process_Non_Static_Choice => Non_Static_Choice_Error,
- Process_Associated_Node => Process_Declarations);
- use Variant_Choices_Processing;
- -- Instantiation of the generic choice processing package
+ procedure Process_Variant (A : Node_Id);
+ -- Analyze declarations for a single variant
- -----------------------------
- -- Non_Static_Choice_Error --
- -----------------------------
+ package Analyze_Variant_Choices is
+ new Generic_Analyze_Choices (Process_Variant);
+ use Analyze_Variant_Choices;
- procedure Non_Static_Choice_Error (Choice : Node_Id) is
- begin
- Flag_Non_Static_Expr
- ("choice given in variant part is not static!", Choice);
- end Non_Static_Choice_Error;
-
- --------------------------
- -- Process_Declarations --
- --------------------------
+ ---------------------
+ -- Process_Variant --
+ ---------------------
- procedure Process_Declarations (Variant : Node_Id) is
+ procedure Process_Variant (A : Node_Id) is
+ CL : constant Node_Id := Component_List (A);
begin
- if not Null_Present (Component_List (Variant)) then
- Analyze_Declarations (Component_Items (Component_List (Variant)));
+ if not Null_Present (CL) then
+ Analyze_Declarations (Component_Items (CL));
- if Present (Variant_Part (Component_List (Variant))) then
- Analyze (Variant_Part (Component_List (Variant)));
+ if Present (Variant_Part (CL)) then
+ Analyze (Variant_Part (CL));
end if;
end if;
- end Process_Declarations;
-
- -- Local Variables
-
- Discr_Name : Node_Id;
- Discr_Type : Entity_Id;
-
- Dont_Care : Boolean;
- Others_Present : Boolean := False;
-
- pragma Warnings (Off, Dont_Care);
- pragma Warnings (Off, Others_Present);
- -- We don't care about the assigned values of any of these
+ end Process_Variant;
-- Start of processing for Analyze_Variant_Part
return;
end if;
- -- Call the instantiated Analyze_Choices which does the rest of the work
+ -- Now analyze the choices, which also analyzes the declarations that
+ -- are associated with each choice.
+
+ Analyze_Choices (Variants (N), Discr_Type);
+
+ -- Note: we used to instantiate and call Check_Choices here to check
+ -- that the choices covered the discriminant, but it's too early to do
+ -- that because of statically predicated subtypes, whose analysis may
+ -- be deferred to their freeze point which may be as late as the freeze
+ -- point of the containing record. So this call is now to be found in
+ -- Freeze_Record_Declaration.
- Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
end Analyze_Variant_Part;
----------------------------
-- Error routine invoked by the generic instantiation below when
-- the case expression has a non static choice.
- package Case_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Alternatives,
- Process_Empty_Choice => No_OP,
+ package Case_Choices_Analysis is new
+ Generic_Analyze_Choices
+ (Process_Associated_Node => No_OP);
+ use Case_Choices_Analysis;
+
+ package Case_Choices_Checking is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
- use Case_Choices_Processing;
+ use Case_Choices_Checking;
--------------------------
-- Has_Static_Predicate --
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
- Dont_Care : Boolean;
Others_Present : Boolean;
+ -- Indicates if Others was present
-- Start of processing for Analyze_Case_Expression
-- If error already reported by Resolve, nothing more to do
- if Exp_Btype = Any_Discrete
- or else Exp_Btype = Any_Type
- then
+ if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
then
null;
- -- Call instantiated Analyze_Choices which does the rest of the work
+ -- Call Analyze_Choices and Check_Choices to do the rest of the work
else
- Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ Analyze_Choices (Alternatives (N), Exp_Type);
+ Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
end if;
if Exp_Type = Universal_Integer and then not Others_Present then
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
- Dont_Care : Boolean;
+
Others_Present : Boolean;
+ -- Indicates if Others was present
pragma Warnings (Off, Last_Choice);
- pragma Warnings (Off, Dont_Care);
- -- Don't care about assigned values
+ -- Don't care about assigned value
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed. If False
-- case statement has a non static choice.
procedure Process_Statements (Alternative : Node_Id);
- -- Analyzes all the statements associated with a case alternative.
- -- Needed by the generic instantiation below.
-
- package Case_Choices_Processing is new
- Generic_Choices_Processing
- (Get_Alternatives => Alternatives,
- Process_Empty_Choice => No_OP,
+ -- Analyzes the statements associated with a case alternative. Needed
+ -- by instantiation below.
+
+ package Analyze_Case_Choices is new
+ Generic_Analyze_Choices
+ (Process_Associated_Node => Process_Statements);
+ use Analyze_Case_Choices;
+ -- Instantiation of the generic choice analysis package
+
+ package Check_Case_Choices is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
- Process_Associated_Node => Process_Statements);
- use Case_Choices_Processing;
+ Process_Associated_Node => No_Op);
+ use Check_Case_Choices;
-- Instantiation of the generic choice processing package
-----------------------------
-- If error already reported by Resolve, nothing more to do
- if Exp_Btype = Any_Discrete
- or else Exp_Btype = Any_Type
- then
+ if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
Exp_Type := Exp_Btype;
end if;
- -- Call instantiated Analyze_Choices which does the rest of the work
+ -- Call instantiated procedures to analyzwe and check discrete choices
- Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ Analyze_Choices (Alternatives (N), Exp_Type);
+ Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
- -- A case statement with a single OTHERS alternative is not allowed
- -- in SPARK.
+ -- Case statement with single OTHERS alternative not allowed in SPARK
if Others_Present and then List_Length (Alternatives (N)) = 1 then
Check_SPARK_Restriction
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
+ -- If the expander is active it will detect the case of a statically
+ -- determined single alternative and remove warnings for the case, but
+ -- if we are not doing expansion, that circuit won't be active. Here we
+ -- duplicate the effect of removing warnings in the same way, so that
+ -- we will get the same set of warnings in -gnatc mode.
+
if not Expander_Active
and then Compile_Time_Known_Value (Expression (N))
and then Serious_Errors_Detected = 0
and then Present (First_Entity (Spec_Id))
and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
- and then
- Present (Interfaces (Etype (First_Entity (Spec_Id))))
- and then
- Present
- (Corresponding_Concurrent_Type
- (Etype (First_Entity (Spec_Id))))
+ and then Present (Interfaces (Etype (First_Entity (Spec_Id))))
+ and then Present (Corresponding_Concurrent_Type
+ (Etype (First_Entity (Spec_Id))))
then
declare
Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
------------------------
function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
- E : Entity_Id := First_Entity (Prim);
+ E : Entity_Id;
begin
+ E := First_Entity (Prim);
while Present (E) loop
if Is_Formal (E) and then Is_Controlling_Formal (E) then
return E;
-- The mode of the controlling formals must match
elsif Present (Iface_Ctrl_F)
- and then Present (Prim_Ctrl_F)
- and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
+ and then Present (Prim_Ctrl_F)
+ and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
then
return False;
-- Precondition |
-- Predicate |
-- Statement_Assertions
- --
+
+ -- Shouldn't Refined_Pre be in this list???
+
-- Note: The RM_ASSERTION_KIND list is language-defined, and the
-- ID_ASSERTION_KIND list contains implementation-defined additions
-- recognized by GNAT. The effect is to control the behavior of
package Sem_Prag is
- -- The following table lists all the user-defined pragmas that may apply to
- -- a body stub.
+ -- The following table lists all the implementation-defined pragmas that
+ -- may apply to a body stub (no language defined pragmas apply).
Pragma_On_Stub_OK : constant array (Pragma_Id) of Boolean :=
(Pragma_Refined_Pre => True,
Discrim := First (Choices (Assoc));
exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
or else (Present (Corresponding_Discriminant (Entity (Discrim)))
- and then
- Chars (Corresponding_Discriminant (Entity (Discrim)))
- = Chars (Discrim_Name))
+ and then
+ Chars (Corresponding_Discriminant (Entity (Discrim))) =
+ Chars (Discrim_Name))
or else Chars (Original_Record_Component (Entity (Discrim)))
= Chars (Discrim_Name);
Find_Discrete_Value : while Present (Variant) loop
Discrete_Choice := First (Discrete_Choices (Variant));
while Present (Discrete_Choice) loop
-
exit Find_Discrete_Value when
Nkind (Discrete_Choice) = N_Others_Choice;
-- If we have found the corresponding choice, recursively add its
-- components to the Into list.
- Gather_Components (Empty,
- Component_List (Variant), Governed_By, Into, Report_Errors);
+ Gather_Components
+ (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
end Gather_Components;
------------------------
return Is_Fully_Initialized_Variant (U);
end if;
end;
+
else
return False;
end if;
return Flag13 (N);
end Has_Self_Reference;
+ function Has_SP_Choice
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Expression_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ return Flag15 (N);
+ end Has_SP_Choice;
+
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean is
begin
Set_Flag13 (N, Val);
end Set_Has_Self_Reference;
+ procedure Set_Has_SP_Choice
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Case_Expression_Alternative
+ or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Variant);
+ Set_Flag15 (N, Val);
+ end Set_Has_SP_Choice;
+
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True) is
begin
-- enclosing type. Such a self-reference can only appear in default-
-- initialized aggregate for a record type.
+ -- Has_SP_Choice (Flag15-Sem)
+ -- Present in all nodes containing a Discrete_Choices field (N_Variant,
+ -- N_Case_Expression_Alternative, N_Case_Statement_Alternative). Set to
+ -- True if the Discrete_Choices list has at least one occurrence of a
+ -- statically predicated subtype.
+
-- Has_Storage_Size_Pragma (Flag5-Sem)
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
-- VARIANT_PART ::=
-- case discriminant_DIRECT_NAME is
- -- VARIANT
- -- {VARIANT}
+ -- VARIANT {VARIANT}
-- end case;
-- Note: the variants list can contain pragmas as well as variants.
-- Enclosing_Variant (Node2-Sem)
-- Present_Expr (Uint3-Sem)
-- Dcheck_Function (Node5-Sem)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
-- predicated subtypes. Such entries are always expanded out to the list
-- of equivalent values or ranges. The ASIS tree generated in -gnatct
- -- mode does not have this expansion, and has the original choices.
+ -- mode also has this expansion, but done with a proper Rewrite call on
+ -- the N_Variant node so that ASIS can properly retrieve the original.
---------------------------------
-- 3.8.1 Discrete Choice List --
-- Actions (List1)
-- Discrete_Choices (List4)
-- Expression (Node3)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: The Actions field temporarily holds any actions associated with
-- evaluation of the Expression. During expansion of the case expression
-- these actions are wrapped into an N_Expressions_With_Actions node
-- replacing the original expression.
+ -- Note: this node never appears in the tree passed to the back end,
+ -- since the expander converts case expressions into case statements.
+
---------------------------------
-- 4.5.9 Quantified Expression --
---------------------------------
-- Sloc points to WHEN
-- Discrete_Choices (List4)
-- Statements (List3)
+ -- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
function Has_Self_Reference
(N : Node_Id) return Boolean; -- Flag13
+ function Has_SP_Choice
+ (N : Node_Id) return Boolean; -- Flag15
+
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
procedure Set_Has_Self_Reference
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Has_SP_Choice
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
pragma Inline (Has_Init_Expression);
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
+ pragma Inline (Has_SP_Choice);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
pragma Inline (Set_Has_Private_View);
pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Self_Reference);
+ pragma Inline (Set_Has_SP_Choice);
pragma Inline (Set_Has_Storage_Size_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
projects / thirdparty / gcc.git / commitdiff
