+2009-04-15 Pascal Obry <obry@adacore.com>
+
+ * adaint.h (__gnat_unlink): Add spec.
+ (__gnat_rename): Likewise.
+
+2009-04-15 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb: Minor spelling error corrections in error messages
+
+2009-04-15 Robert Dewar <dewar@adacore.com>
+
+ * sinfo.ads: Minor comment update
+
+ * opt.ads: Minor comment updates
+
+ * checks.adb (Enable_Overflow_Check): Do not set Do_Overflow_Check for
+ modular type.
+
+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_disp.ads, exp_disp.adb (Register_Primitive): Is now a function
+ that generates the code needed to update a dispatch table when a
+ primitive operation is declared with a subprogram body without previous
+ spec. Insertion of the generated code is responsibility of the caller.
+ (Make_DT): When building static tables, append the code created by
+ Register_Primitive to update a secondary table after it has been
+ constructed.
+
+ * exp_ch3.adb, exp_ch6.adb: use new version of Register_Primitive.
+
+ * sem_disp.adb (Check_Dispatching_Operation): Call Register_Primitive
+ on an overriding operation that implements an interface operation only
+ if not building static dispatch tables.
+
+2009-04-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-caldel-vms.adb (To_Duration): Declare a "safe" end of time which
+ does not cause overflow when converted to Duration. Use the safe value
+ as the maximum allowable time delay..
+
+2009-04-15 Jerome Lambourg <lambourg@adacore.com>
+
+ * g-comlin.adb (Set_Command_Line): When adding a switch with attached
+ parameter, specify that the delimiter is NUL, otherwise "-j2" will be
+ translated to "-j 2".
+
+2009-04-15 Bob Duff <duff@adacore.com>
+
+ * rtsfind.adb (Maybe_Add_With): Split out procedure to add implicit
+ with_clauses, to avoid code duplication. Change this processing so we
+ always add a with_clause on the main unit if needed.
+
2009-04-15 Pascal Obry <obry@adacore.com>
Add support for Win32 native encoding for delete/rename routines.
-----------------
function To_Duration (T : Time) return Duration is
+ Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0);
+ -- A value distant enough to emulate "end of time" but which does not
+ -- cause overflow.
+
+ Safe_T : Time;
+
begin
- return OSP.To_Duration (OSP.OS_Time (T), OSP.Absolute_Calendar);
+ if T > Safe_Ada_High then
+ Safe_T := Safe_Ada_High;
+ else
+ Safe_T := T;
+ end if;
+
+ return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar);
end To_Duration;
--------------------
extern int __gnat_mkdir (char *);
extern int __gnat_stat (char *,
struct stat *);
+extern int __gnat_unlink (char *);
+extern int __gnat_rename (char *, char *);
+
extern FILE *__gnat_fopen (char *, char *, int);
extern FILE *__gnat_freopen (char *, char *, FILE *,
int);
then
return;
+ -- Nothing to do for unsigned integer types, which do not overflow
+
+ elsif Is_Modular_Integer_Type (Typ) then
+ return;
+
-- Nothing to do if the range of the result is known OK. We skip this
-- for conversions, since the caller already did the check, and in any
-- case the condition for deleting the check for a type conversion is
and then Convention (Prim) = Convention_CPP
and then not Present (Interface_Alias (Prim))
then
- Register_Primitive (Loc,
- Prim => Prim,
- Ins_Nod => Last (Init_Tags_List));
+ Append_List_To (Init_Tags_List,
+ Register_Primitive (Loc, Prim => Prim));
end if;
Next_Elmt (E);
Register_Predefined_DT_Entry (Subp);
end if;
- Register_Primitive (Loc,
- Prim => Subp,
- Ins_Nod => N);
+ Insert_Actions_After (N,
+ Register_Primitive (Loc, Prim => Subp));
end if;
end if;
end;
-- Register_Primitive --
------------------------
- procedure Register_Primitive
+ function Register_Primitive
(Loc : Source_Ptr;
- Prim : Entity_Id;
- Ins_Nod : Node_Id)
+ Prim : Entity_Id) return List_Id
is
DT_Ptr : Entity_Id;
Iface_Prim : Entity_Id;
Iface_Typ : Entity_Id;
Iface_DT_Ptr : Entity_Id;
Iface_DT_Elmt : Elmt_Id;
- L : List_Id;
+ L : constant List_Id := New_List;
Pos : Uint;
Tag : Entity_Id;
Tag_Typ : Entity_Id;
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if not RTE_Available (RE_Tag) then
- return;
+ return L;
end if;
if not Present (Interface_Alias (Prim)) then
DT_Ptr :=
Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
and then RTE_Record_Component_Available (RE_Size_Func)
then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Size_Function (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Size_Func => Prim));
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Insert_After (Ins_Nod,
+ Append_To (L,
Build_Set_Prim_Op_Address (Loc,
Typ => Tag_Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
if not Is_Ancestor (Iface_Typ, Tag_Typ)
and then Present (Thunk_Code)
then
- -- Comment needed on why checks are suppressed. This is not just
- -- efficiency, but fundamental functionality (see 1.295 RH, which
- -- still does not answer this question) ???
-
- Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
-
-- Generate the code necessary to fill the appropriate entry of
-- the secondary dispatch table of Prim's controlling type with
-- Thunk_Id's address.
Iface_Prim := Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ);
- L := New_List;
+
+ Prepend_To (L, Thunk_Code);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
- Insert_Actions_After (Ins_Nod, L);
-
else
pragma Assert (Pos /= Uint_0
and then Pos <= DT_Entry_Count (Tag));
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
- Insert_Actions_After (Ins_Nod, L);
end if;
end if;
end if;
+
+ return L;
end Register_Primitive;
-------------------------
-- tagged types this routine imports the forward declaration of the tag
-- entity, that will be declared and exported by Make_DT.
- procedure Register_Primitive
+ function Register_Primitive
(Loc : Source_Ptr;
- Prim : Entity_Id;
- Ins_Nod : Node_Id);
- -- Register Prim in the corresponding primary or secondary dispatch table.
+ Prim : Entity_Id) return List_Id;
+ -- Build code to register Prim in the primary or secondary dispatch table.
-- If Prim is associated with a secondary dispatch table then generate also
-- its thunk and register it in the associated secondary dispatch table.
-- In general the dispatch tables are always generated by Make_DT and
-- Make_Secondary_DT; this routine is only used in two corner cases:
+ --
-- 1) To construct the dispatch table of a tagged type whose parent
-- is a CPP_Class (see Build_Init_Procedure).
-- 2) To handle late overriding of dispatching operations (see
- -- Check_Dispatching_Operation).
+ -- Check_Dispatching_Operation and Make_DT).
+ --
+ -- The caller is responsible for inserting the generated code in the
+ -- proper place.
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP
if Separator (Parser) = ASCII.NUL then
Add_Switch
- (Cmd, Sw & Parameter (Parser), "");
+ (Cmd, Sw & Parameter (Parser), "", ASCII.NUL);
else
Add_Switch
(Cmd, Sw, Parameter (Parser), Separator (Parser));
-- handlers that can never handle a local raise. This warning is only ever
-- generated if pragma Restrictions (No_Exception_Propagation) is set. The
-- default is not to generate the warnings except that if the source has
- -- at least one exception, and this restriction is set, and the warning
- -- was not explicitly turned off, then it is turned on by default.
+ -- at least one exception handler, and this restriction is set, and the
+ -- warning was not explicitly turned off, then it is turned on by default.
No_Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
-- This is set to True if the above warning is explicitly suppressed. We
-- use this to avoid turning it on by default when No_Exception_Propagation
- -- restriction is set.
+ -- restriction is set and an exception handler is present.
Warn_On_Obsolescent_Feature : Boolean := False;
-- GNAT
if Data.Qualifier = Dry and then Data.Source_Dirs /= Nil_String then
Error_Msg
(Project, In_Tree,
- "an abstract project need to have no language, no sources or no " &
- "source directories",
+ "an abstract project needs to have no language, no sources " &
+ "or no source directories",
Data.Location);
end if;
then
Error_Msg
(Project, In_Tree,
- "a reference symbol file need to be defined",
+ "a reference symbol file needs to be defined",
Lib_Symbol_Policy.Location);
end if;
-- the latter case it is critical to make a call to Set_RTU_Loaded to
-- ensure that the entry in this table reflects the load.
+ -- Withed is True if an implicit with_clause has been added from some unit
+ -- other than the main unit to this unit. Withed_By_Main is the same,
+ -- except from the main unit.
+
type RT_Unit_Table_Record is record
- Entity : Entity_Id;
- Uname : Unit_Name_Type;
- Unum : Unit_Number_Type;
- Withed : Boolean;
+ Entity : Entity_Id;
+ Uname : Unit_Name_Type;
+ Unum : Unit_Number_Type;
+ Withed : Boolean;
+ Withed_By_Main : Boolean;
end record;
RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
RE_Table : array (RE_Id) of Entity_Id;
- --------------------------
- -- Generation of WITH's --
- --------------------------
+ --------------------------------
+ -- Generation of with_clauses --
+ --------------------------------
-- When a unit is implicitly loaded as a result of a call to RTE, it is
- -- necessary to create an implicit WITH to ensure that the object is
- -- correctly loaded by the binder. We originally added such WITH clauses
- -- only if the extended main unit required them, and added them only to the
- -- extended main unit. They are currently added to whatever unit first
- -- needs them, which is not necessarily the main unit. This works because
- -- if the main unit requires some runtime unit also required by some other
- -- unit, the other unit's implicit WITH will force a correct elaboration
- -- order. This method is necessary for SofCheck Inspector.
-
- -- The flag Withed in the unit table record is initially set to False. It
- -- is set True if a WITH has been generated for the corresponding unit.
+ -- necessary to create one or two implicit with_clauses. We add such
+ -- with_clauses to the extended main unit if needed, and also to whatever
+ -- unit first needs them, which is not necessarily the main unit. The
+ -- former ensures that the object is correctly loaded by the binder. The
+ -- latter is necessary for SofCheck Inspector.
+
+ -- The flags Withed and Withed_By_Main in the unit table record are used to
+ -- avoid duplicates.
-----------------------
-- Local Subprograms --
-- If the unit is a child unit, build fully qualified name for use in
-- With_Clause.
+ procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record);
+ -- If necessary, add an implicit with_clause from the current unit to the
+ -- one represented by E and U.
+
procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity
-- corresponding to Id, appending the string given by Msg. This call
-- Otherwise we need to load the unit, First build unit name
-- from the enumeration literal name in type RTU_Id.
- U.Uname := Get_Unit_Name (U_Id);
- U.Withed := False;
+ U.Uname := Get_Unit_Name (U_Id);
+ U.Withed := False;
+ U.Withed_By_Main := False;
-- Now do the load call, note that setting Error_Node to Empty is
-- a signal to Load_Unit that we will regard a failure to find the
if not Analyzed (Cunit (U.Unum)) then
- -- If the unit is already loaded through a limited_with clause,
+ -- If the unit is already loaded through a limited_with_clause,
-- the relevant entities must already be available. We do not
-- want to load and analyze the unit because this would create
-- a real semantic dependence when the purpose of the limited_with
return Nam;
end Make_Unit_Name;
- -----------------------
+ --------------------
+ -- Maybe_Add_With --
+ --------------------
+
+ procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record) is
+ Is_Main : constant Boolean :=
+ In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit));
+
+ begin
+ -- We do not need to generate a with_clause for a call issued from
+ -- RTE_Component_Available.
+
+ if RTE_Available_Call then
+ return;
+ end if;
+
+ -- If the current unit is the main one, add the with_clause unless it's
+ -- already been done.
+
+ if Is_Main then
+ if U.Withed_By_Main then
+ return;
+ else
+ U.Withed_By_Main := True;
+ end if;
+
+ -- If the current unit is not the main one, add the with_clause unless
+ -- it's already been done for some non-main unit.
+
+ else
+ if U.Withed then
+ return;
+ else
+ U.Withed := True;
+ end if;
+ end if;
+
+ -- Here if we've decided to add the with_clause
+
+ declare
+ Lib_Unit : constant Node_Id := Unit (Cunit (U.Unum));
+ Withn : constant Node_Id :=
+ Make_With_Clause (Standard_Location,
+ Name =>
+ Make_Unit_Name
+ (E, Defining_Unit_Name (Specification (Lib_Unit))));
+
+ begin
+ Set_Library_Unit (Withn, Cunit (U.Unum));
+ Set_Corresponding_Spec (Withn, U.Entity);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
+
+ Mark_Rewrite_Insertion (Withn);
+ Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
+ Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
+ end;
+ end Maybe_Add_With;
+
+ ------------------------
-- Output_Entity_Name --
------------------------
end if;
end if;
- -- See if we have to generate a WITH for this entity. We generate a WITH
- -- if we have not already added the with. The WITH is added to the
- -- appropriate unit (the current one). We do not need to generate a WITH
- -- for a call issued from RTE_Available.
-
<<Found>>
- if not U.Withed and then not RTE_Available_Call then
- U.Withed := True;
-
- declare
- Withn : Node_Id;
- Lib_Unit : Node_Id;
-
- begin
- Lib_Unit := Unit (Cunit (U.Unum));
- Withn :=
- Make_With_Clause (Standard_Location,
- Name =>
- Make_Unit_Name
- (E, Defining_Unit_Name (Specification (Lib_Unit))));
- Set_Library_Unit (Withn, Cunit (U.Unum));
- Set_Corresponding_Spec (Withn, U.Entity);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
-
- Mark_Rewrite_Insertion (Withn);
- Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
- Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
- end;
- end if;
+ Maybe_Add_With (E, U);
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, RE_Table (E));
-- If we didn't find the entity we want, something is wrong. The
-- appropriate action will be taken by Check_CRT when we exit.
- -- Generate a with-clause if the current unit is part of the extended
- -- main code unit, and if we have not already added the with. The clause
- -- is added to the appropriate unit (the current one). We do not need to
- -- generate it for a call issued from RTE_Component_Available.
-
- if (not U.Withed)
- and then
- In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
- and then not RTE_Available_Call
- then
- U.Withed := True;
-
- declare
- Withn : Node_Id;
- Lib_Unit : Node_Id;
-
- begin
- Lib_Unit := Unit (Cunit (U.Unum));
- Withn :=
- Make_With_Clause (Standard_Location,
- Name =>
- Make_Unit_Name
- (E, Defining_Unit_Name (Specification (Lib_Unit))));
- Set_Library_Unit (Withn, Cunit (U.Unum));
- Set_Corresponding_Spec (Withn, U.Entity);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
-
- Mark_Rewrite_Insertion (Withn);
- Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
- Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
- end;
- end if;
+ Maybe_Add_With (E, U);
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, Found_E);
-- If entry is not set, set it now
if No (U.Entity) then
- U.Entity := E;
- U.Uname := Get_Unit_Name (U_Id);
- U.Unum := Unum;
- U.Withed := False;
+ U := (Entity => E,
+ Uname => Get_Unit_Name (U_Id),
+ Unum => Unum,
+ Withed => False,
+ Withed_By_Main => False);
end if;
return;
with Elists; use Elists;
with Einfo; use Einfo;
with Exp_Disp; use Exp_Disp;
+with Exp_Util; use Exp_Util;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Errout; use Errout;
end if;
else
- Register_Primitive (Sloc (Subp_Body),
- Prim => Subp,
- Ins_Nod => Subp_Body);
+ Insert_Actions_After (Subp_Body,
+ Register_Primitive (Sloc (Subp_Body),
+ Prim => Subp));
end if;
Generate_Reference (Tagged_Type, Subp, 'p', False);
-- Ada 2005 (AI-251): In case of late overriding of a primitive
-- that covers abstract interface subprograms we must register it
-- in all the secondary dispatch tables associated with abstract
- -- interfaces.
+ -- interfaces. We do this now only if not building static tables.
+ -- Otherwise the patch code is emitted after those tables are
+ -- built, to prevent access_before_elaboration in gigi.
if Body_Is_Last_Primitive then
declare
if Present (Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
+ and then not Building_Static_DT (Tagged_Type)
then
- Register_Primitive (Sloc (Prim),
- Prim => Prim,
- Ins_Nod => Subp_Body);
+ Insert_Actions_After (Subp_Body,
+ Register_Primitive (Sloc (Subp_Body), Prim => Prim));
end if;
Next_Elmt (Elmt);
-- See also the description of Do_Range_Check for this case. The only
-- attribute references which use this flag are Pred and Succ, where it
-- means that the result should be checked for going outside the base
- -- range.
+ -- range. Note that this flag is not set for modular types.
-- Do_Range_Check (Flag9-Sem)
-- This flag is set on an expression which appears in a context where a
projects / thirdparty / gcc.git / commitdiff
