-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
-with Hostparm; use Hostparm;
with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
Expr := Make_Function_Call (Loc,
Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
- if not In_Init_Proc then
+ if not In_Init_Proc and then VM_Target = No_VM then
Set_Uses_Sec_Stack (Defining_Entity (Fun));
end if;
end if;
then
null;
- -- Nothing to be done if the type of the expression is limited, because
- -- in this case the expression cannot be copied, and its use can only
- -- be by reference and there is no need for the actual subtype.
+ -- In Ada95, Nothing to be done if the type of the expression is
+ -- limited, because in this case the expression cannot be copied,
+ -- and its use can only be by reference.
- elsif Is_Limited_Type (Exp_Typ) then
+ -- In Ada2005, the context can be an object declaration whose expression
+ -- is a function that returns in place. If the nominal subtype has
+ -- unknown discriminants, the call still provides constraints on the
+ -- object, and we have to create an actual subtype from it.
+
+ -- If the type is class-wide, the expression is dynamically tagged and
+ -- we do not create an actual subtype either. Ditto for an interface.
+
+ elsif Is_Limited_Type (Exp_Typ)
+ and then
+ (Is_Class_Wide_Type (Exp_Typ)
+ or else Is_Interface (Exp_Typ)
+ or else not Has_Unknown_Discriminants (Exp_Typ)
+ or else not Is_Composite_Type (Unc_Type))
+ then
+ null;
+
+ -- For limited interfaces, nothing to be done
+
+ -- This branch may be redundant once the limited interface issue is
+ -- sorted out???
+
+ elsif Is_Interface (Exp_Typ)
+ and then Is_Limited_Interface (Exp_Typ)
+ then
null;
else
end;
end Get_Current_Value_Condition;
+ ---------------------------------
+ -- Has_Controlled_Coextensions --
+ ---------------------------------
+
+ function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
+ D_Typ : Entity_Id;
+ Discr : Entity_Id;
+
+ begin
+ -- Only consider record types
+
+ if Ekind (Typ) /= E_Record_Type
+ and then Ekind (Typ) /= E_Record_Subtype
+ then
+ return False;
+ end if;
+
+ if Has_Discriminants (Typ) then
+ Discr := First_Discriminant (Typ);
+ while Present (Discr) loop
+ D_Typ := Etype (Discr);
+
+ if Ekind (D_Typ) = E_Anonymous_Access_Type
+ and then
+ (Is_Controlled (Directly_Designated_Type (D_Typ))
+ or else
+ Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
+ then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Controlled_Coextensions;
+
--------------------
-- Homonym_Number --
--------------------
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
- N_With_Clause |
- N_With_Type_Clause
+ N_With_Clause
=>
null;
P := Parent (N);
end if;
end loop;
-
end Insert_Actions;
-- Version with check(s) suppressed
procedure Insert_Actions
- (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
begin
- New_Scope (Cunit_Entity (Main_Unit));
+ Push_Scope (Cunit_Entity (Main_Unit));
+ -- ??? should this be Current_Sem_Unit instead of Main_Unit?
if No (Actions (Aux)) then
Set_Actions (Aux, New_List (N));
begin
if Is_Non_Empty_List (L) then
- New_Scope (Cunit_Entity (Main_Unit));
+ Push_Scope (Cunit_Entity (Main_Unit));
+ -- ??? should this be Current_Sem_Unit instead of Main_Unit?
if No (Actions (Aux)) then
Set_Actions (Aux, L);
function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
begin
- -- ??? GCC3 will eventually handle strings with arbitrary alignments,
- -- but for now the following check must be disabled.
-
- -- if get_gcc_version >= 3 then
- -- return False;
- -- end if;
-
- -- For renaming case, go to renamed object
+ -- Go to renamed object
if Is_Entity_Name (N)
and then Is_Object (Entity (N))
Loc : constant Source_Ptr := Sloc (E);
Root_Typ : constant Entity_Id := Root_Type (T);
List_Def : constant List_Id := Empty_List;
+ Comp_List : constant List_Id := New_List;
Equiv_Type : Entity_Id;
Range_Type : Entity_Id;
Str_Type : Entity_Id;
Make_Subtype_From_Expr (E, Root_Typ)));
end if;
- -- subtype rg__xx is Storage_Offset range
- -- (Expr'size - typ'size) / Storage_Unit
+ -- Generate the range subtype declaration
Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
- Sizexpr :=
- Make_Op_Subtract (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Constr_Root, Loc),
- Attribute_Name => Name_Object_Size));
+ if not Is_Interface (Root_Typ) then
+ -- subtype rg__xx is
+ -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
+
+ Sizexpr :=
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+ Attribute_Name => Name_Size),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Constr_Root, Loc),
+ Attribute_Name => Name_Object_Size));
+ else
+ -- subtype rg__xx is
+ -- Storage_Offset range 1 .. Expr'size / Storage_Unit
+
+ Sizexpr :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+ Attribute_Name => Name_Size);
+ end if;
Set_Paren_Count (Sizexpr, 1);
New_List (New_Reference_To (Range_Type, Loc))))));
-- type Equiv_T is record
- -- _parent : Tnn;
+ -- [ _parent : Tnn; ]
-- E : Str_Type;
-- end Equiv_T;
Set_Ekind (Equiv_Type, E_Record_Type);
Set_Parent_Subtype (Equiv_Type, Constr_Root);
+ if not Is_Interface (Root_Typ) then
+ Append_To (Comp_List,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uParent),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
+ end if;
+
+ Append_To (Comp_List,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('C')),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Str_Type, Loc))));
+
Append_To (List_Def,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Equiv_Type,
-
Type_Definition =>
Make_Record_Definition (Loc,
- Component_List => Make_Component_List (Loc,
- Component_Items => New_List (
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uParent),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Constr_Root, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('C')),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Str_Type, Loc)))),
-
- Variant_Part => Empty))));
-
- Insert_Actions (E, List_Def);
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => Comp_List,
+ Variant_Part => Empty))));
+
+ -- Suppress all checks during the analysis of the expanded code
+ -- to avoid the generation of spurious warnings under ZFP run-time.
+
+ Insert_Actions (E, List_Def, Suppress => All_Checks);
return Equiv_Type;
end Make_CW_Equivalent_Type;
EQ_Typ : Entity_Id := Empty;
begin
- -- A class-wide equivalent type is not needed when Java_VM
- -- because the JVM back end handles the class-wide object
+ -- A class-wide equivalent type is not needed when VM_Target
+ -- because the VM back-ends handle the class-wide object
-- initialization itself (and doesn't need or want the
-- additional intermediate type to handle the assignment).
- if Expander_Active and then not Java_VM then
+ if Expander_Active and then VM_Target = No_VM then
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
end if;
return (Res);
end New_Class_Wide_Subtype;
+ --------------------------------
+ -- Non_Limited_Designated_Type --
+ ---------------------------------
+
+ function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id := Designated_Type (T);
+ begin
+ if Ekind (Desig) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Desig))
+ then
+ return Non_Limited_View (Desig);
+ else
+ return Desig;
+ end if;
+ end Non_Limited_Designated_Type;
+
-----------------------------------
-- OK_To_Do_Constant_Replacement --
-----------------------------------
end if;
end OK_To_Do_Constant_Replacement;
+ ------------------------------------
+ -- Possible_Bit_Aligned_Component --
+ ------------------------------------
+
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+
+ -- Case of indexed component
+
+ when N_Indexed_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (P);
+
+ begin
+ -- If we know the component size and it is less than 64, then
+ -- we are definitely OK. The back end always does assignment
+ -- of misaligned small objects correctly.
+
+ if Known_Static_Component_Size (Ptyp)
+ and then Component_Size (Ptyp) <= 64
+ then
+ return False;
+
+ -- Otherwise, we need to test the prefix, to see if we are
+ -- indexing from a possibly unaligned component.
+
+ else
+ return Possible_Bit_Aligned_Component (P);
+ end if;
+ end;
+
+ -- Case of selected component
+
+ when N_Selected_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Comp : constant Entity_Id := Entity (Selector_Name (N));
+
+ begin
+ -- If there is no component clause, then we are in the clear
+ -- since the back end will never misalign a large component
+ -- unless it is forced to do so. In the clear means we need
+ -- only the recursive test on the prefix.
+
+ if Component_May_Be_Bit_Aligned (Comp) then
+ return True;
+ else
+ return Possible_Bit_Aligned_Component (P);
+ end if;
+ end;
+
+ -- If we have neither a record nor array component, it means that we
+ -- have fallen off the top testing prefixes recursively, and we now
+ -- have a stand alone object, where we don't have a problem.
+
+ when others =>
+ return False;
+
+ end case;
+ end Possible_Bit_Aligned_Component;
+
-------------------------
-- Remove_Side_Effects --
-------------------------
elsif Compile_Time_Known_Value (N) then
return True;
+
+ -- A variable renaming is not side-effet free, because the
+ -- renaming will function like a macro in the front-end in
+ -- some cases, and an assignment can modify the the component
+ -- designated by N, so we need to create a temporary for it.
+
+ elsif Is_Entity_Name (Original_Node (N))
+ and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
+ and then Ekind (Entity (Original_Node (N))) /= E_Constant
+ then
+ return False;
end if;
-- For other than entity names and compile time known values,
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Package containing utility procedures used throughout the expander
with Exp_Tss; use Exp_Tss;
+with Namet; use Namet;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Types; use Types;
-- or not known at all. In the first two cases, Get_Current_Condition will
-- return with Op set to the appropriate conditional operator (inverted if
-- the condition is known false), and Val set to the constant value. If the
- -- condition is not known, then Cond and Val are set for the empty case
+ -- condition is not known, then Op and Val are set for the empty case
-- (N_Empty and Empty).
--
-- The check for whether the condition is true/false unknown depends
-- N_Op_Eq), or to determine the result of some other test in other cases
-- (e.g. no access check required if N_Op_Ne Null).
+ function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean;
+ -- Determine whether a record type has anonymous access discriminants with
+ -- a controlled designated type.
+
function Homonym_Number (Subp : Entity_Id) return Nat;
-- Here subp is the entity for a subprogram. This routine returns the
-- homonym number used to disambiguate overloaded subprograms in the same
-- caller has to check whether stack checking is actually enabled in order
-- to guide the expansion (typically of a function call).
+ function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
+ -- An anonymous access type may designate a limited view. Check whether
+ -- non-limited view is available during expansion, to examine components
+ -- or other characteristics of the full type.
+
function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean;
-- This function is used when testing whether or not to replace a reference
-- to entity E by a known constant value. Such replacement must be done
-- address might be captured in a way we do not detect. A value of True is
-- returned only if the replacement is safe.
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
+ -- This function is used in processing the assignment of a record or
+ -- indexed component. The argument N is either the left hand or right
+ -- hand side of an assignment, and this function determines if there
+ -- is a record component reference where the record may be bit aligned
+ -- in a manner that causes trouble for the back end (see description
+ -- of Exp_Util.Component_May_Be_Bit_Aligned for further details).
+
procedure Remove_Side_Effects
(Exp : Node_Id;
Name_Req : Boolean := False;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-- This procedure is used to generate error message info lines that
-- trace the current dependency chain when a load error occurs.
+ ------------------------------
+ -- Change_Main_Unit_To_Spec --
+ ------------------------------
+
+ procedure Change_Main_Unit_To_Spec is
+ U : Unit_Record renames Units.Table (Main_Unit);
+ N : File_Name_Type;
+ X : Source_File_Index;
+
+ begin
+ -- Get name of unit body
+
+ Get_Name_String (U.Unit_File_Name);
+
+ -- Note: for the following we should really generalize and consult the
+ -- file name pattern data, but for now we just deal with the common
+ -- naming cases, which is probably good enough in practice ???
+
+ -- Change .adb to .ads
+
+ if Name_Len >= 5
+ and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
+ then
+ Name_Buffer (Name_Len) := 's';
+
+ -- Change .2.ada to .1.ada (Rational convention)
+
+ elsif Name_Len >= 7
+ and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada"
+ then
+ Name_Buffer (Name_Len - 4) := '1';
+
+ -- Change .ada to _.ada (DEC convention)
+
+ elsif Name_Len >= 5
+ and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada"
+ then
+ Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada";
+ Name_Len := Name_Len + 1;
+
+ -- No match, don't make the change
+
+ else
+ return;
+ end if;
+
+ -- Try loading the spec
+
+ N := Name_Find;
+ X := Load_Source_File (N);
+
+ -- No change if we did not find the spec
+
+ if X = No_Source_File then
+ return;
+ end if;
+
+ -- Otherwise modify Main_Unit entry to point to spec
+
+ U.Unit_File_Name := N;
+ U.Source_Index := X;
+ end Change_Main_Unit_To_Spec;
+
-------------------------------
-- Create_Dummy_Package_Unit --
-------------------------------
----------------------
procedure Load_Main_Source is
- Fname : File_Name_Type;
+ Fname : File_Name_Type;
+ Version : Word := 0;
begin
Load_Stack.Increment_Last;
Main_Source_File := Load_Source_File (Fname);
Current_Error_Source_File := Main_Source_File;
+ if Main_Source_File /= No_Source_File then
+ Version := Source_Checksum (Main_Source_File);
+ end if;
+
Units.Table (Main_Unit) := (
Cunit => Empty,
Cunit_Entity => Empty,
Dependency_Num => 0,
Dynamic_Elab => False,
Error_Location => No_Location,
- Expected_Unit => No_Name,
+ Expected_Unit => No_Unit_Name,
Fatal_Error => False,
Generate_Code => False,
Has_RACW => False,
Serial_Number => 0,
Source_Index => Main_Source_File,
Unit_File_Name => Fname,
- Unit_Name => No_Name,
- Version => Source_Checksum (Main_Source_File));
+ Unit_Name => No_Unit_Name,
+ Version => Version);
end if;
end Load_Main_Source;
-- If parent is a renaming, then we use the renamed package as
-- the actual parent for the subsequent load operation.
- if Nkind (Parent (Cunit_Entity (Unump))) =
- N_Package_Renaming_Declaration
- then
+ if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then
Uname_Actual :=
New_Child
- (Load_Name,
- Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
+ (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
-- Save the renaming entity, to establish its visibility when
-- installing the context. The implicit with is on this entity,
-- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
if Present (Error_Node)
- and then Unit_Name (Main_Unit) /= No_Name
+ and then Unit_Name (Main_Unit) /= No_Unit_Name
then
-- It seems like In_Extended_Main_Source_Unit (Error_Node) would
-- do the trick here, but that's wrong, it is much too early to
-- If the load is called from a with_type clause, the error
-- node is correct.
- elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
- Load_Msg_Sloc := Sloc (Error_Node);
-
-- Otherwise, check for the subunit case, and if so, consider
-- we have a match if one name is a prefix of the other name.
if Present (Error_Node) then
if Is_Predefined_File_Name (Fname) then
- Error_Msg_Name_1 := Uname_Actual;
+ Error_Msg_Unit_1 := Uname_Actual;
Error_Msg
- ("% is not a language defined unit", Load_Msg_Sloc);
+ ("$$ is not a language defined unit", Load_Msg_Sloc);
else
- Error_Msg_Name_1 := Fname;
+ Error_Msg_File_1 := Fname;
Error_Msg_Unit_1 := Uname_Actual;
- Error_Msg
- ("File{ does not contain unit$", Load_Msg_Sloc);
+ Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc);
end if;
Write_Dependency_Chain;
if Corr_Body /= No_Unit
and then Spec_Is_Irrelevant (Unum, Corr_Body)
then
- Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
+ Error_Msg_File_1 := Unit_File_Name (Corr_Body);
Error_Msg
- ("cannot compile subprogram in file {!",
- Load_Msg_Sloc);
- Error_Msg_Name_1 := Unit_File_Name (Unum);
+ ("cannot compile subprogram in file {!", Load_Msg_Sloc);
+ Error_Msg_File_1 := Unit_File_Name (Unum);
Error_Msg
("\incorrect spec in file { must be removed first!",
Load_Msg_Sloc);
Check_Restricted_Unit (Load_Name, Error_Node);
- Error_Msg_Name_1 := Uname_Actual;
+ Error_Msg_Unit_1 := Uname_Actual;
Error_Msg
- ("% is not a predefined library unit", Load_Msg_Sloc);
+ ("$$ is not a predefined library unit", Load_Msg_Sloc);
else
- Error_Msg_Name_1 := Fname;
+ Error_Msg_File_1 := Fname;
Error_Msg ("file{ not found", Load_Msg_Sloc);
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- limited-with clause, or some unit in the context of X. It is used to
-- avoid the check on circular dependency (Ada 2005, AI-50217)
+ procedure Change_Main_Unit_To_Spec;
+ -- This procedure is called if the main unit file contains a No_Body pragma
+ -- and no other tokens. The effect is, if possible, to change the main unit
+ -- from the body it references now, to the corresponding spec. This has the
+ -- effect of ignoring the body, which is what we want. If it is impossible
+ -- to successfully make the change, then the call has no effect, and the
+ -- file is unchanged (this will lead to an error complaining about the
+ -- inappropriate No_Body spec).
+
function Create_Dummy_Package_Unit
(With_Node : Node_Id;
Spec_Name : Unit_Name_Type) return Unit_Number_Type;
if Token = Tok_Type then
- -- WITH TYPE is an GNAT specific extension
+ -- WITH TYPE is an obsolete GNAT specific extension
- if not Extensions_Allowed then
- Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP
+ ("`WITH TYPE` is an obsolete 'G'N'A'T extension");
+ Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead");
Scan; -- past TYPE
- With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
- Append (With_Node, Item_List);
- Set_Name (With_Node, P_Qualified_Simple_Name);
T_Is;
if Token = Tok_Tagged then
- Set_Tagged_Present (With_Node);
Scan;
elsif Token = Tok_Access then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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 Node4 (N);
end Delay_Alternative;
- function Delay_Finalize_Attach
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag14 (N);
- end Delay_Finalize_Attach;
-
function Delay_Statement
(N : Node_Id) return Node_Id is
begin
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Goto_Statement
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
- return Flag7 (N);
+ return Flag8 (N);
end Exception_Junk;
function Exception_Label
return Flag12 (N);
end Has_Dynamic_Range_Check;
+ function Has_Init_Expression
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag14 (N);
+ end Has_Init_Expression;
+
+ function Has_Local_Raise
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ return Flag8 (N);
+ end Has_Local_Raise;
+
function Has_No_Elaboration_Code
(N : Node_Id) return Boolean is
begin
return Flag7 (N);
end Is_Protected_Subprogram_Body;
+ function Is_Static_Coextension
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator);
+ return Flag14 (N);
+ end Is_Static_Coextension;
+
function Is_Static_Expression
(N : Node_Id) return Boolean is
begin
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
or else NT (N).Nkind = N_Subunit
or else NT (N).Nkind = N_Variant_Part
- or else NT (N).Nkind = N_With_Clause
- or else NT (N).Nkind = N_With_Type_Clause);
+ or else NT (N).Nkind = N_With_Clause);
return Node2 (N);
end Name;
return Flag13 (N);
end Redundant_Use;
+ function Renaming_Exception
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Declaration);
+ return Node2 (N);
+ end Renaming_Exception;
+
function Result_Definition
(N : Node_Id) return Node_Id is
begin
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Incomplete_Type_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_With_Type_Clause);
+ or else NT (N).Nkind = N_Record_Definition);
return Flag15 (N);
end Tagged_Present;
Set_Node4_With_Parent (N, Val);
end Set_Delay_Alternative;
- procedure Set_Delay_Finalize_Attach
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag14 (N, Val);
- end Set_Delay_Finalize_Attach;
-
procedure Set_Delay_Statement
(N : Node_Id; Val : Node_Id) is
begin
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Goto_Statement
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Flag7 (N, Val);
+ Set_Flag8 (N, Val);
end Set_Exception_Junk;
procedure Set_Exception_Label
Set_Flag12 (N, Val);
end Set_Has_Dynamic_Range_Check;
+ procedure Set_Has_Init_Expression
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag14 (N, Val);
+ end Set_Has_Init_Expression;
+
+ procedure Set_Has_Local_Raise
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Handler);
+ Set_Flag8 (N, Val);
+ end Set_Has_Local_Raise;
+
procedure Set_Has_No_Elaboration_Code
(N : Node_Id; Val : Boolean := True) is
begin
Set_Flag7 (N, Val);
end Set_Is_Protected_Subprogram_Body;
+ procedure Set_Is_Static_Coextension
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator);
+ Set_Flag14 (N, Val);
+ end Set_Is_Static_Coextension;
+
procedure Set_Is_Static_Expression
(N : Node_Id; Val : Boolean := True) is
begin
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
or else NT (N).Nkind = N_Subunit
or else NT (N).Nkind = N_Variant_Part
- or else NT (N).Nkind = N_With_Clause
- or else NT (N).Nkind = N_With_Type_Clause);
+ or else NT (N).Nkind = N_With_Clause);
Set_Node2_With_Parent (N, Val);
end Set_Name;
Set_Flag13 (N, Val);
end Set_Redundant_Use;
+ procedure Set_Renaming_Exception
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exception_Declaration);
+ Set_Node2 (N, Val);
+ end Set_Renaming_Exception;
+
procedure Set_Result_Definition
(N : Node_Id; Val : Node_Id) is
begin
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Incomplete_Type_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_With_Type_Clause);
+ or else NT (N).Nkind = N_Record_Definition);
Set_Flag15 (N, Val);
end Set_Tagged_Present;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- WARNING: Several files are automatically generated from this package.
-- See below for details.
+with Namet; use Namet;
with Types; use Types;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- already been analyzed, both for efficiency and functional correctness
-- reasons.
- -- Coextensions (Elist4-Sem)
- -- Present in allocators nodes. Points to list of allocators for the
- -- access discriminants of the allocated object,
-
-- Comes_From_Source (Flag2)
-- This flag is on for any nodes built by the scanner or parser from the
-- source program, and off for any nodes built by the analyzer or
-- points to a list of raise nodes, which are calls to a routine to raise
-- an exception. These are raise nodes which can be optimized into gotos
-- if the handler turns out to meet the conditions which permit this
- -- transformation.
+ -- transformation. Note that this does NOT include instances of the
+ -- N_Raise_xxx_Error nodes since the transformation of these nodes is
+ -- handled by the back end (using the N_Push/N_Pop mechanism).
-- Has_Dynamic_Length_Check (Flag10-Sem)
-- This flag is present on all nodes. It is set to indicate that one of
-- has been inserted at the flagged node. This is used to avoid the
-- generation of duplicate checks.
+ -- Has_Local_Raise (Flag8-Sem)
+ -- Present in exception handler nodes. Set if the handler can be entered
+ -- via a local raise that gets transformed to a goto statement. This will
+ -- always be set if Local_Raise_Statements is non-empty, but can also be
+ -- set as a result of generation of N_Raise_xxx nodes, or flags set in
+ -- nodes requiring generation of back end checks.
+
------------------------------------
-- Description of Semantic Fields --
------------------------------------
-- attribute definition clause is given, rather than testing this at the
-- freeze point.
+ -- Coextensions (Elist4-Sem)
+ -- Present in allocators nodes. Points to list of allocators for the
+ -- access discriminants of the allocated object.
+
-- Comes_From_Extended_Return_Statement (Flag18-Sem)
-- Present in N_Return_Statement nodes. True if this node was
-- constructed as part of the expansion of an
-- for the default expression). Default_Expression is used for
-- conformance checking.
- -- Delay_Finalize_Attach (Flag14-Sem)
- -- This flag is present in an N_Object_Declaration node. If it is set,
- -- then in the case of a controlled type being declared and initialized,
- -- the normal code for attaching the result to the appropriate local
- -- finalization list is suppressed. This is used for functions that
- -- return controlled types without using the secondary stack, where it is
- -- the caller who must do the attachment.
-
-- Discr_Check_Funcs_Built (Flag11-Sem)
-- This flag is present in N_Full_Type_Declaration nodes. It is set when
-- discriminant checking functions are constructed. The purpose is to
-- points to an essentially arbitrary choice from the possible set of
-- types.
- -- Exception_Junk (Flag7-Sem)
+ -- Exception_Junk (Flag8-Sem)
-- This flag is set in a various nodes appearing in a statement sequence
-- to indicate that the corresponding node is an artifact of the
-- generated code for exception handling, and should be ignored when
-- handler to make sure that the associated protected object is unlocked
-- when the subprogram completes.
+ -- Is_Static_Coextension (Flag14-Sem)
+ -- Present in N_Allocator nodes. Set if the allocator is a coextension
+ -- of an object allocated on the stack rather than the heap.
+
-- Is_Static_Expression (Flag6-Sem)
-- Indicates that an expression is a static expression (RM 4.9). See spec
-- of package Sem_Eval for full details on the use of this flag.
-- to indicate that a use is redundant (and therefore need not be undone
-- on scope exit).
+ -- Renaming_Exception (Node2-Sem)
+ -- Present in N_Exception_Declaration node. Used to point back to the
+ -- exception renaming for an exception declared within a subprogram.
+ -- What happens is that an exception declared in a subprogram is moved
+ -- to the library level with a unique name, and the original exception
+ -- becomes a renaming. This link from the library level exception to the
+ -- renaming declaration allows registering of the proper exception name.
+
-- Return_Statement_Entity (Node5-Sem)
-- Present in N_Return_Statement and N_Extended_Return_Statement.
-- Points to an E_Return_Statement representing the return statement.
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
- -- Exception_Junk (Flag7-Sem)
+ -- Exception_Junk (Flag8-Sem)
-------------------------------
-- 3.2.2 Subtype Indication --
-- Prev_Ids flags to preserve the original source form as described
-- in the section on "Handling of Defining Identifier Lists".
+ -- The flag Has_Init_Expression is set if an initializing expression
+ -- is present. Normally it is set if and only if Expression contains
+ -- a non-empty value, but there is an exception to this. When the
+ -- initializing expression is an aggregate which requires explicit
+ -- assignments, the Expression field gets set to Empty, but this flag
+ -- is still set, so we don't forget we had an initializing expression.
+
-- Note: if a range check is required for the initialization
-- expression then the Do_Range_Check flag is set in the Expression,
-- with the check being done against the type given by the object
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- No_Initialization (Flag13-Sem)
-- Assignment_OK (Flag15-Sem)
- -- Exception_Junk (Flag7-Sem)
- -- Delay_Finalize_Attach (Flag14-Sem)
+ -- Exception_Junk (Flag8-Sem)
-- Is_Subprogram_Descriptor (Flag16-Sem)
+ -- Has_Init_Expression (Flag14)
-------------------------------------
-- 3.3.1 Defining Identifier List --
-- Procedure_To_Call (Node2-Sem)
-- Coextensions (Elist4-Sem)
-- No_Initialization (Flag13-Sem)
+ -- Is_Static_Coextension (Flag14-Sem)
-- Do_Storage_Check (Flag17-Sem)
-- Is_Coextension (Flag18-Sem)
-- plus fields for expression
-- N_Label
-- Sloc points to <<
-- Identifier (Node1) direct name of statement identifier
- -- Exception_Junk (Flag7-Sem)
+ -- Exception_Junk (Flag8-Sem)
-------------------------------
-- 5.1 Statement Identifier --
-- True. Blocks constructed by the expander usually have no identifier,
-- and no corresponding entity.
- -- Note well: the block statement created for an extended return
- -- statement has an entity, and this entity is an E_Return_Statement,
- -- rather than the usual E_Block.
+ -- Note: the block statement created for an extended return statement
+ -- has an entity, and this entity is an E_Return_Statement, rather than
+ -- the usual E_Block.
+
+ -- Note: Exception_Junk is set for the wrapping blocks created during
+ -- local raise optimization (Exp_Ch11.Expand_Local_Exception_Handlers).
-- N_Block_Statement
-- Sloc points to DECLARE or BEGIN
-- Has_Created_Identifier (Flag15)
-- Is_Task_Allocation_Block (Flag6)
-- Is_Asynchronous_Call_Block (Flag7)
+ -- Exception_Junk (Flag8-Sem)
-------------------------
-- 5.7 Exit Statement --
-- N_Goto_Statement
-- Sloc points to GOTO
-- Name (Node2)
- -- Exception_Junk (Flag7-Sem)
+ -- Exception_Junk (Flag8-Sem)
---------------------------------
-- 6.1 Subprogram Declaration --
-- This is a GNAT extension, used to implement mutually recursive
-- types declared in different packages.
-
- -- WITH_TYPE_CLAUSE ::=
- -- with type type_NAME is access | with type type_NAME is tagged
-
- -- N_With_Type_Clause
- -- Sloc points to first token of type name
- -- Name (Node2)
- -- Tagged_Present (Flag15)
+ -- Note: this is now obsolete. The functionality of this construct
+ -- is now implemented by the Ada 2005 Limited_with_Clause.
---------------------
-- 10.2 Body stub --
-- Sloc points to EXCEPTION
-- Defining_Identifier (Node1)
-- Expression (Node3-Sem)
+ -- Renaming_Exception (Node2-Sem)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- Zero_Cost_Handling (Flag5-Sem)
-- Local_Raise_Statements (Elist1-Sem) (set to No_Elist if not present)
-- Local_Raise_Not_OK (Flag7-Sem)
+ -- Has_Local_Raise (Flag8-Sem)
------------------------------------------
-- 11.2 Choice parameter specification --
N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Concrete_Subprogram_Declaration,
- -- N_Push_xxx_Label
+ -- N_Push_xxx_Label, N_Push_Pop_xxx_Label
N_Push_Constraint_Error_Label,
N_Push_Program_Error_Label,
N_Push_Storage_Error_Label,
- -- N_Pop_xxx_Label
+ -- N_Pop_xxx_Label, N_Push_Pop_xxx_Label
N_Pop_Constraint_Error_Label,
N_Pop_Program_Error_Label,
N_Variant,
N_Variant_Part,
N_With_Clause,
- N_With_Type_Clause,
N_Unused_At_End);
for Node_Kind'Size use 8;
N_Pop_Constraint_Error_Label ..
N_Pop_Storage_Error_Label;
+ subtype N_Push_Pop_xxx_Label is Node_Kind range
+ N_Push_Constraint_Error_Label ..
+ N_Pop_Storage_Error_Label;
+
subtype N_Raise_xxx_Error is Node_Kind range
N_Raise_Constraint_Error ..
N_Raise_Storage_Error;
function Delay_Alternative
(N : Node_Id) return Node_Id; -- Node4
- function Delay_Finalize_Attach
- (N : Node_Id) return Boolean; -- Flag14
-
function Delay_Statement
(N : Node_Id) return Node_Id; -- Node2
(N : Node_Id) return List_Id; -- List5
function Exception_Junk
- (N : Node_Id) return Boolean; -- Flag7
+ (N : Node_Id) return Boolean; -- Flag8
function Exception_Label
(N : Node_Id) return Node_Id; -- Node5
function Has_Dynamic_Range_Check
(N : Node_Id) return Boolean; -- Flag12
+ function Has_Init_Expression
+ (N : Node_Id) return Boolean; -- Flag14
+
+ function Has_Local_Raise
+ (N : Node_Id) return Boolean; -- Flag8
+
function Has_No_Elaboration_Code
(N : Node_Id) return Boolean; -- Flag17
function Is_Protected_Subprogram_Body
(N : Node_Id) return Boolean; -- Flag7
+ function Is_Static_Coextension
+ (N : Node_Id) return Boolean; -- Flag14
+
function Is_Static_Expression
(N : Node_Id) return Boolean; -- Flag6
function Redundant_Use
(N : Node_Id) return Boolean; -- Flag13
+ function Renaming_Exception
+ (N : Node_Id) return Node_Id; -- Node2
+
function Result_Definition
(N : Node_Id) return Node_Id; -- Node4
procedure Set_Delay_Alternative
(N : Node_Id; Val : Node_Id); -- Node4
- procedure Set_Delay_Finalize_Attach
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
procedure Set_Delay_Statement
(N : Node_Id; Val : Node_Id); -- Node2
(N : Node_Id; Val : List_Id); -- List5
procedure Set_Exception_Junk
- (N : Node_Id; Val : Boolean := True); -- Flag7
+ (N : Node_Id; Val : Boolean := True); -- Flag8
procedure Set_Exception_Label
(N : Node_Id; Val : Node_Id); -- Node5
procedure Set_Has_Dynamic_Range_Check
(N : Node_Id; Val : Boolean := True); -- Flag12
+ procedure Set_Has_Init_Expression
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
+ procedure Set_Has_Local_Raise
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
procedure Set_Has_No_Elaboration_Code
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Is_Protected_Subprogram_Body
(N : Node_Id; Val : Boolean := True); -- Flag7
+ procedure Set_Is_Static_Coextension
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
procedure Set_Is_Static_Expression
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Redundant_Use
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Renaming_Exception
+ (N : Node_Id; Val : Node_Id); -- Node2
+
procedure Set_Result_Definition
(N : Node_Id; Val : Node_Id); -- Node4
4 => False, -- Library_Unit (Node4-Sem)
5 => False), -- Corresponding_Spec (Node5-Sem)
- N_With_Type_Clause =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
N_Subprogram_Body_Stub =>
(1 => True, -- Specification (Node1)
2 => False, -- unused
pragma Inline (Defining_Identifier);
pragma Inline (Defining_Unit_Name);
pragma Inline (Delay_Alternative);
- pragma Inline (Delay_Finalize_Attach);
pragma Inline (Delay_Statement);
pragma Inline (Delta_Expression);
pragma Inline (Digits_Expression);
pragma Inline (Has_Created_Identifier);
pragma Inline (Has_Dynamic_Length_Check);
pragma Inline (Has_Dynamic_Range_Check);
+ pragma Inline (Has_Init_Expression);
+ pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Priority_Pragma);
pragma Inline (Is_Overloaded);
pragma Inline (Is_Power_Of_2_For_Shift);
pragma Inline (Is_Protected_Subprogram_Body);
+ pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor);
pragma Inline (Is_Task_Allocation_Block);
pragma Inline (Reason);
pragma Inline (Record_Extension_Part);
pragma Inline (Redundant_Use);
+ pragma Inline (Renaming_Exception);
pragma Inline (Result_Definition);
pragma Inline (Return_Object_Declarations);
pragma Inline (Return_Statement_Entity);
pragma Inline (Set_Defining_Identifier);
pragma Inline (Set_Defining_Unit_Name);
pragma Inline (Set_Delay_Alternative);
- pragma Inline (Set_Delay_Finalize_Attach);
pragma Inline (Set_Delay_Statement);
pragma Inline (Set_Delta_Expression);
pragma Inline (Set_Digits_Expression);
pragma Inline (Set_Handler_List_Entry);
pragma Inline (Set_Has_Created_Identifier);
pragma Inline (Set_Has_Dynamic_Length_Check);
+ pragma Inline (Set_Has_Init_Expression);
+ pragma Inline (Set_Has_Local_Raise);
pragma Inline (Set_Has_Dynamic_Range_Check);
pragma Inline (Set_Has_No_Elaboration_Code);
pragma Inline (Set_Has_Priority_Pragma);
pragma Inline (Set_Is_Power_Of_2_For_Shift);
pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Has_Self_Reference);
+ pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor);
pragma Inline (Set_Is_Task_Allocation_Block);
pragma Inline (Set_Reason);
pragma Inline (Set_Record_Extension_Part);
pragma Inline (Set_Redundant_Use);
+ pragma Inline (Set_Renaming_Exception);
pragma Inline (Set_Result_Definition);
pragma Inline (Set_Return_Object_Declarations);
pragma Inline (Set_Reverse_Present);
projects / gcc.git / commitdiff