+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb: Sloc of wrapper is that of instantiation.
+
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch11.adb: Minor reformatting.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Get_Assoc_Expr): New routine internal to
+ Build_Array_Aggr_Code, used to initialized components covered
+ by a box association. If the component type is scalar and has
+ a default aspect, use it to initialize such components.
+
+2015-01-06 Pascal Obry <obry@adacore.com>
+
+ * rtinit.c (__gnat_runtime_initialize): Add a parameter to
+ control the setup of the exception handler.
+ * initialize.c: Remove unused declaration.
+ * bindgen.adb: Always call __gnat_runtime_initialize and pass
+ whether the exeception handler must be set or not.
+
2015-01-06 Thomas Quinot <quinot@adacore.com>
* freeze.adb (Set_SSO_From_Defaults): When setting scalar storage
-- installation, and indication of if it's been called previously.
WBI ("");
- WBI (" procedure Runtime_Initialize;");
+ WBI (" procedure Runtime_Initialize " &
+ "(Install_Handler : Integer);");
WBI (" pragma Import (C, Runtime_Initialize, " &
"""__gnat_runtime_initialize"");");
-- In .NET, when binding with -z, we don't install the signal handler
-- to let the caller handle the last exception handler.
- if Bind_Main_Program then
- WBI ("");
- WBI (" Runtime_Initialize;");
+ WBI ("");
+
+ if VM_Target /= CLI_Target
+ or else Bind_Main_Program
+ then
+ WBI (" Runtime_Initialize (1);");
+ else
+ WBI (" Runtime_Initialize (0);");
end if;
end if;
--
-- Otherwise we call Build_Code recursively
+ function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id;
+ -- For an association with a box, use default aspect of component type
+ -- if present, to initialize one or more components.
+
function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
function Local_Expr_Value (E : Node_Id) return Uint;
-- These two Local routines are used to replace the corresponding ones
return S;
end Gen_While;
+ --------------------
+ -- Get_Assoc_Expr --
+ --------------------
+
+ function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is
+ begin
+ if Box_Present (Assoc) then
+ if Is_Scalar_Type (Ctype)
+ and then Present (Default_Aspect_Value (Ctype))
+ then
+ return Default_Aspect_Value (Ctype);
+ else
+ return Empty;
+ end if;
+
+ else
+ return Expression (Assoc);
+ end if;
+ end Get_Assoc_Expr;
+
---------------------
-- Index_Base_Name --
---------------------
Expr : Node_Id;
Typ : Entity_Id;
- Others_Expr : Node_Id := Empty;
- Others_Box_Present : Boolean := False;
+ Others_Assoc : Node_Id := Empty;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Set_Loop_Actions (Assoc, New_List);
-
- if Box_Present (Assoc) then
- Others_Box_Present := True;
- else
- Others_Expr := Expression (Assoc);
- end if;
+ Others_Assoc := Assoc;
exit;
end if;
end if;
Nb_Choices := Nb_Choices + 1;
- if Box_Present (Assoc) then
- Table (Nb_Choices) := (Choice_Lo => Low,
- Choice_Hi => High,
- Choice_Node => Empty);
- else
- Table (Nb_Choices) := (Choice_Lo => Low,
- Choice_Hi => High,
- Choice_Node => Expression (Assoc));
- end if;
+
+ Table (Nb_Choices) :=
+ (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Get_Assoc_Expr (Assoc));
+
Next (Choice);
end loop;
-- We don't need to generate loops over empty gaps, but if there is
-- a single empty range we must analyze the expression for semantics
- if Present (Others_Expr) or else Others_Box_Present then
+ if Present (Others_Assoc) then
declare
First : Boolean := True;
then
First := False;
Append_List
- (Gen_Loop (Low, High, Others_Expr), To => New_Code);
+ (Gen_Loop (Low, High,
+ Get_Assoc_Expr (Others_Assoc)), To => New_Code);
end if;
end loop;
end;
-- Ada 2005 (AI-287)
- if Box_Present (Assoc) then
- Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
- Aggr_High,
- Empty),
- To => New_Code);
- else
- Expr := Expression (Assoc);
-
- Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
- Aggr_High,
- Expr), -- AI-287
- To => New_Code);
- end if;
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Get_Assoc_Expr (Assoc)), -- AI-287
+ To => New_Code);
end if;
end if;
/* __gnat_initialize (NT-mingw32 Version) */
/******************************************/
-extern void __gnat_install_handler(void);
-
#if defined (__MINGW32__)
extern void __gnat_install_SEH_handler (void *);
#include <windows.h>
extern void __gnat_init_float (void);
-extern void __gnat_install_SEH_handler (void *);
extern int gnat_argc;
extern char **gnat_argv;
#endif
void
-__gnat_runtime_initialize(void)
+__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
}
#endif
- __gnat_install_handler();
+ if (install_handler)
+ __gnat_install_handler();
}
/**************************************************/
extern void __gnat_init_float (void);
void
-__gnat_runtime_initialize(void)
+__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
__gnat_init_float ();
- __gnat_install_handler();
+ if (install_handler)
+ __gnat_install_handler();
}
/***********************************************/
extern void __gnat_init_float (void);
void
-__gnat_runtime_initialize(void)
+__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
__gnat_init_float ();
- __gnat_install_handler();
+ if (install_handler)
+ __gnat_install_handler();
}
#else
/***********************************************/
void
-__gnat_runtime_initialize(void)
+__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
if (__gnat_rt_init_count > 1)
return;
- __gnat_install_handler();
+ if (install_handler)
+ __gnat_install_handler();
}
#endif
elsif Nkind (Id1) /= N_Others_Choice
and then
(Id_Entity = Entity (Id1)
- or else (Id_Entity = Renamed_Entity (Entity (Id1))))
+ or else (Id_Entity = Renamed_Entity (Entity (Id1))))
then
if Handler /= Parent (Id) then
Error_Msg_Sloc := Sloc (Id1);
- Error_Msg_NE
- ("exception choice duplicates &#", Id, Id1);
+ Error_Msg_NE ("exception choice duplicates &#", Id, Id1);
else
if Ada_Version = Ada_83
and then Nkind (First (Statements (Handler))) = N_Raise_Statement
and then No (Name (First (Statements (Handler))))
and then (not Others_Present
- or else Nkind (First (Exception_Choices (Handler))) =
+ or else Nkind (First (Exception_Choices (Handler))) =
N_Others_Choice)
then
Error_Msg_N
-- See if preceding statement is an assignment
- if Present (P)
- and then Nkind (P) = N_Assignment_Statement
- then
+ if Present (P) and then Nkind (P) = N_Assignment_Statement then
L := Name (P);
-- Give warning for assignment to scalar formal
-- This avoids some false positives for the nested case.
and then Nearest_Dynamic_Scope (Current_Scope) =
- Scope (Entity (L))
+ Scope (Entity (L))
then
-- Don't give warning if we are covered by an exception
if No (Exception_Handlers (Par)) then
Error_Msg_N
- ("assignment to pass-by-copy formal " &
- "may have no effect??", P);
+ ("assignment to pass-by-copy formal "
+ & "may have no effect??", P);
Error_Msg_N
- ("\RAISE statement may result in abnormal return" &
- " (RM 6.4.1(17))??", P);
+ ("\RAISE statement may result in abnormal return "
+ & "(RM 6.4.1(17))??", P);
end if;
end if;
end if;
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Formal_Subp);
+ Loc : constant Source_Ptr := Sloc (Current_Scope);
Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
Actuals : List_Id;
Decl : Node_Id;
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Formal_Subp);
- Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
- Op_Type : constant Entity_Id := Get_Instance_Of
- (Etype (First_Formal (Formal_Subp)));
- Is_Binary : constant Boolean :=
+ Loc : constant Source_Ptr := Sloc (Current_Scope);
+ Ret_Type : constant Entity_Id :=
+ Get_Instance_Of (Etype (Formal_Subp));
+ Op_Type : constant Entity_Id :=
+ Get_Instance_Of (Etype (First_Formal (Formal_Subp)));
+ Is_Binary : constant Boolean :=
Present (Next_Formal (First_Formal (Formal_Subp)));
Decl : Node_Id;
projects / gcc.git / commitdiff