+2014-01-24 Doug Rupp <rupp@adacore.com>
+
+ * init.c: Add a handler section for Android.
+
+2014-01-24 Arnaud Charlet <charlet@adacore.com>
+
+ * i-cexten.ads (Unsigned_33..64, Unsigned_33..64): New types.
+
+2014-01-24 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Operator_Check): If one operand is a
+ Raise_Expression, set its type to that of the other operand.
+ * sem_res.adb (Resolve_Raise_Expression): new procedure.
+ (Resolve_Actuals): For an actual that is a Raise_Expression,
+ set the type to that of the formal.
+ * sem_type.adb (Find_Unique_Type): If one of the operands is a
+ Raise_Expression, return type of the other operand.
+
+2014-01-24 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): If a scalar
+ component of the record has a type with a default aspect, and
+ the corresponding aggregate component is initiaized with a box,
+ use the default value in the rewritten aggregate.
+
+2014-01-24 Tristan Gingold <gingold@adacore.com>
+
+ * s-interr.ads, s-interr.adb, s-interr-hwint.adb, s-interr-vms.adb,
+ s-interr-sigaction.adb,
+ s-interr-dummy.adb (Install_Restricted_Handlers): Add Prio parameter.
+ * exp_ch9.adb (Make_Initialize_Protection): Add Prio parameter
+ to the call to Install_Restricted_Handlers.
+
+2014-01-24 Emmanuel Briot <briot@adacore.com>
+
+ * prj-nmsc.adb (Check_File): Add protection when the source is
+ not fully initialized.
+
2014-01-24 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Is_Post_State): In a postcondition, a selected
L : constant List_Id := New_List;
Has_Entry : constant Boolean := Has_Entries (Ptyp);
Prio_Type : Entity_Id;
+ Prio_Var : Entity_Id := Empty;
Restricted : constant Boolean := Restricted_Profile;
begin
(Ptyp, Name_Priority, Check_Parents => False);
Prio : Node_Id;
- Temp : Entity_Id;
begin
-- Pragma Priority
Prio := Expression (Prio_Clause);
end if;
- -- If priority is a static expression, then we can duplicate it
- -- with no problem and simply append it to the argument list.
- -- However, it has only be pre-analyzed, so we need to check
- -- now that it is in the bounds of the priority type.
+ -- Always create a locale variable to capture the priority.
+ -- The priority is also passed to Install_Restriced_Handlers.
+ -- Note that it is really necessary to create this variable
+ -- explicitly. It might be thought that removing side effects
+ -- would the appropriate approach, but that could generate
+ -- declarations improperly placed in the enclosing scope.
- if Is_Static_Expression (Prio) then
- Set_Analyzed (Prio, False);
- Append_To (Args,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Prio_Type, Loc),
- Expression => Duplicate_Subexpr (Prio)));
-
- -- Otherwise, the priority may be a per-object expression, if
- -- it depends on a discriminant of the type. In this case,
- -- create local variable to capture the expression. Note that
- -- it is really necessary to create this variable explicitly.
- -- It might be thought that removing side effects would the
- -- appropriate approach, but that could generate declarations
- -- improperly placed in the enclosing scope.
+ Prio_Var := Make_Temporary (Loc, 'R', Prio);
+ Append_To (L,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Prio_Var,
+ Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
+ Expression => Relocate_Node (Prio)));
- else
- Temp := Make_Temporary (Loc, 'R', Prio);
- Append_To (L,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Prio_Type, Loc),
- Expression => Relocate_Node (Prio)));
-
- Append_To (Args, New_Occurrence_Of (Temp, Loc));
- end if;
+ Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
end;
-- When no priority is specified but an xx_Handler pragma is, we
-- or, in the case of Ravenscar:
-- Install_Restricted_Handlers
- -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
+ -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access));
declare
Args : constant List_Id := New_List;
Ritem : Node_Id := First_Rep_Item (Ptyp);
begin
+ -- Build the Priority parameter (only for ravenscar)
+
+ if Restricted then
+
+ -- Priority comes from a pragma
+
+ if Present (Prio_Var) then
+ Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
+
+ -- Priority is the default one
+
+ else
+ Append_To (Args,
+ New_Reference_To
+ (RTE (RE_Default_Interrupt_Priority), Loc));
+ end if;
+ end if;
+
-- Build the Attach_Handler table argument
while Present (Ritem) loop
-- --
-- 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- --
type Unsigned_32 is mod 2 ** 32;
for Unsigned_32'Size use 32;
+ type Unsigned_33 is mod 2 ** 33;
+ for Unsigned_33'Size use 33;
+
+ type Unsigned_34 is mod 2 ** 34;
+ for Unsigned_34'Size use 34;
+
+ type Unsigned_35 is mod 2 ** 35;
+ for Unsigned_35'Size use 35;
+
+ type Unsigned_36 is mod 2 ** 36;
+ for Unsigned_36'Size use 36;
+
+ type Unsigned_37 is mod 2 ** 37;
+ for Unsigned_37'Size use 37;
+
+ type Unsigned_38 is mod 2 ** 38;
+ for Unsigned_38'Size use 38;
+
+ type Unsigned_39 is mod 2 ** 39;
+ for Unsigned_39'Size use 39;
+
+ type Unsigned_40 is mod 2 ** 40;
+ for Unsigned_40'Size use 40;
+
+ type Unsigned_41 is mod 2 ** 41;
+ for Unsigned_41'Size use 41;
+
+ type Unsigned_42 is mod 2 ** 42;
+ for Unsigned_42'Size use 42;
+
+ type Unsigned_43 is mod 2 ** 43;
+ for Unsigned_43'Size use 43;
+
+ type Unsigned_44 is mod 2 ** 44;
+ for Unsigned_44'Size use 44;
+
+ type Unsigned_45 is mod 2 ** 45;
+ for Unsigned_45'Size use 45;
+
+ type Unsigned_46 is mod 2 ** 46;
+ for Unsigned_46'Size use 46;
+
+ type Unsigned_47 is mod 2 ** 47;
+ for Unsigned_47'Size use 47;
+
+ type Unsigned_48 is mod 2 ** 48;
+ for Unsigned_48'Size use 48;
+
+ type Unsigned_49 is mod 2 ** 49;
+ for Unsigned_49'Size use 49;
+
+ type Unsigned_50 is mod 2 ** 50;
+ for Unsigned_50'Size use 50;
+
+ type Unsigned_51 is mod 2 ** 51;
+ for Unsigned_51'Size use 51;
+
+ type Unsigned_52 is mod 2 ** 52;
+ for Unsigned_52'Size use 52;
+
+ type Unsigned_53 is mod 2 ** 53;
+ for Unsigned_53'Size use 53;
+
+ type Unsigned_54 is mod 2 ** 54;
+ for Unsigned_54'Size use 54;
+
+ type Unsigned_55 is mod 2 ** 55;
+ for Unsigned_55'Size use 55;
+
+ type Unsigned_56 is mod 2 ** 56;
+ for Unsigned_56'Size use 56;
+
+ type Unsigned_57 is mod 2 ** 57;
+ for Unsigned_57'Size use 57;
+
+ type Unsigned_58 is mod 2 ** 58;
+ for Unsigned_58'Size use 58;
+
+ type Unsigned_59 is mod 2 ** 59;
+ for Unsigned_59'Size use 59;
+
+ type Unsigned_60 is mod 2 ** 60;
+ for Unsigned_60'Size use 60;
+
+ type Unsigned_61 is mod 2 ** 61;
+ for Unsigned_61'Size use 61;
+
+ type Unsigned_62 is mod 2 ** 62;
+ for Unsigned_62'Size use 62;
+
+ type Unsigned_63 is mod 2 ** 63;
+ for Unsigned_63'Size use 63;
+
+ type Unsigned_64 is mod 2 ** 64;
+ for Unsigned_64'Size use 64;
+
type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1;
for Signed_2'Size use 2;
type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1;
for Signed_32'Size use 32;
+ type Signed_33 is range -2 ** 32 .. 2 ** 32 - 1;
+ for Signed_33'Size use 33;
+
+ type Signed_34 is range -2 ** 33 .. 2 ** 33 - 1;
+ for Signed_34'Size use 34;
+
+ type Signed_35 is range -2 ** 34 .. 2 ** 34 - 1;
+ for Signed_35'Size use 35;
+
+ type Signed_36 is range -2 ** 35 .. 2 ** 35 - 1;
+ for Signed_36'Size use 36;
+
+ type Signed_37 is range -2 ** 36 .. 2 ** 36 - 1;
+ for Signed_37'Size use 37;
+
+ type Signed_38 is range -2 ** 37 .. 2 ** 37 - 1;
+ for Signed_38'Size use 38;
+
+ type Signed_39 is range -2 ** 38 .. 2 ** 38 - 1;
+ for Signed_39'Size use 39;
+
+ type Signed_40 is range -2 ** 39 .. 2 ** 39 - 1;
+ for Signed_40'Size use 40;
+
+ type Signed_41 is range -2 ** 40 .. 2 ** 40 - 1;
+ for Signed_41'Size use 41;
+
+ type Signed_42 is range -2 ** 41 .. 2 ** 41 - 1;
+ for Signed_42'Size use 42;
+
+ type Signed_43 is range -2 ** 42 .. 2 ** 42 - 1;
+ for Signed_43'Size use 43;
+
+ type Signed_44 is range -2 ** 43 .. 2 ** 43 - 1;
+ for Signed_44'Size use 44;
+
+ type Signed_45 is range -2 ** 44 .. 2 ** 44 - 1;
+ for Signed_45'Size use 45;
+
+ type Signed_46 is range -2 ** 45 .. 2 ** 45 - 1;
+ for Signed_46'Size use 46;
+
+ type Signed_47 is range -2 ** 46 .. 2 ** 46 - 1;
+ for Signed_47'Size use 47;
+
+ type Signed_48 is range -2 ** 47 .. 2 ** 47 - 1;
+ for Signed_48'Size use 48;
+
+ type Signed_49 is range -2 ** 48 .. 2 ** 48 - 1;
+ for Signed_49'Size use 49;
+
+ type Signed_50 is range -2 ** 49 .. 2 ** 49 - 1;
+ for Signed_50'Size use 50;
+
+ type Signed_51 is range -2 ** 50 .. 2 ** 50 - 1;
+ for Signed_51'Size use 51;
+
+ type Signed_52 is range -2 ** 51 .. 2 ** 51 - 1;
+ for Signed_52'Size use 52;
+
+ type Signed_53 is range -2 ** 52 .. 2 ** 52 - 1;
+ for Signed_53'Size use 53;
+
+ type Signed_54 is range -2 ** 53 .. 2 ** 53 - 1;
+ for Signed_54'Size use 54;
+
+ type Signed_55 is range -2 ** 54 .. 2 ** 54 - 1;
+ for Signed_55'Size use 55;
+
+ type Signed_56 is range -2 ** 55 .. 2 ** 55 - 1;
+ for Signed_56'Size use 56;
+
+ type Signed_57 is range -2 ** 56 .. 2 ** 56 - 1;
+ for Signed_57'Size use 57;
+
+ type Signed_58 is range -2 ** 57 .. 2 ** 57 - 1;
+ for Signed_58'Size use 58;
+
+ type Signed_59 is range -2 ** 58 .. 2 ** 58 - 1;
+ for Signed_59'Size use 59;
+
+ type Signed_60 is range -2 ** 59 .. 2 ** 59 - 1;
+ for Signed_60'Size use 60;
+
+ type Signed_61 is range -2 ** 60 .. 2 ** 60 - 1;
+ for Signed_61'Size use 61;
+
+ type Signed_62 is range -2 ** 61 .. 2 ** 61 - 1;
+ for Signed_62'Size use 62;
+
+ type Signed_63 is range -2 ** 62 .. 2 ** 62 - 1;
+ for Signed_63'Size use 63;
+
+ type Signed_64 is range -2 ** 63 .. 2 ** 63 - 1;
+ for Signed_64'Size use 64;
+
end Interfaces.C.Extensions;
__gnat_handler_installed = 1;
}
+#elif defined(__ANDROID__)
+
+/*******************/
+/* Android Section */
+/*******************/
+
+#include <signal.h>
+#include <stdlib.h>
+
+static void
+__gnat_error_handler (int sig,
+ siginfo_t *si ATTRIBUTE_UNUSED,
+ void *ucontext ATTRIBUTE_UNUSED)
+{
+ struct Exception_Data *exception;
+ const char *msg;
+
+ switch (sig)
+ {
+ case SIGSEGV:
+ exception = &storage_error;
+ msg = "stack overflow or erroneous memory access";
+ break;
+
+ case SIGBUS:
+ exception = &constraint_error;
+ msg = "SIGBUS";
+ break;
+
+ case SIGFPE:
+ exception = &constraint_error;
+ msg = "SIGFPE";
+ break;
+
+ default:
+ exception = &program_error;
+ msg = "unhandled signal";
+ }
+
+ Raise_From_Signal_Handler (exception, msg);
+}
+
+/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */
+char __gnat_alternate_stack[16 * 1024];
+
+void
+__gnat_install_handler (void)
+{
+ struct sigaction act;
+
+ /* Set up signal handler to map synchronous signals to appropriate
+ exceptions. Make sure that the handler isn't interrupted by another
+ signal that might cause a scheduling event! Also setup an alternate
+ stack region for the handler execution so that stack overflows can be
+ handled properly, avoiding a SEGV generation from stack usage by the
+ handler itself. */
+
+ stack_t stack;
+ stack.ss_sp = __gnat_alternate_stack;
+ stack.ss_size = sizeof (__gnat_alternate_stack);
+ stack.ss_flags = 0;
+ sigaltstack (&stack, NULL);
+
+ act.sa_sigaction = __gnat_error_handler;
+ act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
+ sigemptyset (&act.sa_mask);
+
+ sigaction (SIGABRT, &act, NULL);
+ sigaction (SIGFPE, &act, NULL);
+ sigaction (SIGILL, &act, NULL);
+ sigaction (SIGBUS, &act, NULL);
+ act.sa_flags |= SA_ONSTACK;
+ sigaction (SIGSEGV, &act, NULL);
+
+ __gnat_handler_installed = 1;
+}
+
#else
/* For all other versions of GNAT, the handler does nothing. */
-- Check if it is OK to have the same file name in several
-- source directories.
- if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then
+ if Name_Loc.Source /= No_Source
+ and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank
+ then
Error_Msg_File_1 := File_Name;
Error_Msg
(Data.Flags,
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, AdaCore --
+-- Copyright (C) 1995-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- --
-- Install_Restricted_Handlers --
---------------------------------
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
begin
Unimplemented;
end Install_Restricted_Handlers;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Install_Restricted_Handlers --
---------------------------------
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
begin
for N in Handlers'Range loop
Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Install_Restricted_Handlers --
---------------------------------
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
begin
for N in Handlers'Range loop
Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Install_Restricted_Handlers --
---------------------------------
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
begin
for N in Handlers'Range loop
Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Install_Restricted_Handlers --
---------------------------------
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
begin
for N in Handlers'Range loop
Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
-- Store the old handlers in Object.Previous_Handlers and install
-- the new static handlers.
- procedure Install_Restricted_Handlers (Handlers : New_Handler_Array);
- -- Install the static Handlers for the given interrupts and do not store
- -- previously installed handlers. This procedure is used when the Ravenscar
- -- restrictions are in place since in that case there are only
- -- library-level protected handlers that will be installed at
- -- initialization and never be replaced.
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array);
+ -- Install the static Handlers for the given interrupts and do not
+ -- store previously installed handlers. This procedure is used when
+ -- the Ravenscar restrictions are in place since in that case there
+ -- are only library-level protected handlers that will be installed
+ -- at initialization and never be replaced.
end System.Interrupts;
end;
end if;
+ -- Ada 2012: If component is scalar with default value, use it
+
+ elsif Is_Scalar_Type (Ctyp)
+ and then Has_Default_Aspect (Ctyp)
+ then
+ Add_Association
+ (Component => Component,
+ Expr => Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp))),
+ Assoc_List => New_Assoc_List);
+
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
then
or else Etype (R) = Any_Type
or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
then
+ -- For the rather unusual case where one of the operands is
+ -- a Raise_Expression, whose initial type is Any_Type, use
+ -- the type of the other operand.
+
+ if Nkind (L) = N_Raise_Expression then
+ Set_Etype (L, Etype (R));
+ Set_Etype (N, Etype (R));
+
+ elsif Nkind (R) = N_Raise_Expression then
+ Set_Etype (R, Etype (L));
+ Set_Etype (N, Etype (L));
+ end if;
+
return;
-- We explicitly check for the case of concatenation of component
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
when N_Quantified_Expression
=> null;
- -- Nothing to do for Raise_Expression, since we took care of
- -- setting the Etype earlier, and no other processing is needed.
-
when N_Raise_Expression
- => null;
+ => Resolve_Raise_Expression (N, Ctx_Type);
when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type);
-- If we have an error in any actual or formal, indicated by a type
-- of Any_Type, then abandon resolution attempt, and set result type
- -- to Any_Type.
+ -- to Any_Type. Skip this if the actual is a Raise_Expression, whose
+ -- type is imposed from context.
elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type
then
- Set_Etype (N, Any_Type);
- return;
+ if Nkind (A) /= N_Raise_Expression then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
end if;
-- Case where actual is present
Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression;
+ ------------------------------
+ -- Resolve_Raise_Expression --
+ ------------------------------
+
+ procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Set_Etype (N, Typ);
+ end Resolve_Raise_Expression;
+
-------------------
-- Resolve_Range --
-------------------
then
return Etype (R);
+ -- If one operand is a raise_expression, use type of other operand
+
+ elsif Nkind (L) = N_Raise_Expression then
+ return Etype (R);
+
else
return Specific_Type (T, Etype (R));
end if;
projects / gcc.git / commitdiff